cl-mcclim 0.9.6.dfsg.cvs20100315-1 / usr / share / common-lisp / source / mcclim / presentations.lisp

;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-

;;;  (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
;;;  (c) copyright 2001,2002 by Tim Moore (moore@bricoworks.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

;;; Implementation of the presentation type system, presentation generic
;;; functions and methods, presentation translators, finding an applicable
;;;presentation.

(in-package :clim-internals)

;;; PRESENTATION class

(defvar *allow-sensitive-inferiors* t)

(defclass presentation-mixin (presentation)
  ((object :accessor presentation-object :initarg :object)
   (type :accessor presentation-type :initarg :type)
   (view :accessor presentation-view :initarg :view)
   (single-box :accessor presentation-single-box :initarg :single-box
	       :initform nil)
   (modifier :reader presentation-modifier :initarg :modifier :initform nil)
   (is-sensitive :reader is-sensitive :initarg :is-sensitive
		 :initform *allow-sensitive-inferiors*)))


(defclass standard-presentation
    (presentation-mixin standard-sequence-output-record)
  ())

(defvar *print-presentation-verbose* nil)

(defmethod print-object ((self standard-presentation) stream)
  (print-unreadable-object (self stream :type t :identity t)
    (with-bounding-rectangle* (x1 y1 x2 y2)
	self
      (format stream "~D:~D,~D:~D ~S" x1 x2 y1 y2 (presentation-type self))
      (when *print-presentation-verbose*
	(format stream " ~S" (presentation-object self))))))

(defmacro with-output-as-presentation ((stream object type
					       &rest key-args
					       &key modifier single-box
					       (allow-sensitive-inferiors t)
					       parent
					       (record-type
						''standard-presentation)
					       &allow-other-keys)
				       &body body)
  (declare (ignore parent single-box modifier))
  (setq stream (stream-designator-symbol stream '*standard-output*))
  (multiple-value-bind (decls with-body)
      (get-body-declarations body)
    (with-gensyms (record-arg continuation)
      (with-keywords-removed (key-args (:record-type
					:allow-sensitive-inferiors))
	`(flet ((,continuation ()
		  ,@decls
		  ,@with-body))
	   (declare (dynamic-extent #',continuation))
	   (if (and (output-recording-stream-p ,stream)
		    *allow-sensitive-inferiors*)
	       (with-new-output-record
		   (,stream ,record-type ,record-arg
			    :object ,object
			    :type (expand-presentation-type-abbreviation
				   ,type)
			    ,@key-args)
		 (let ((*allow-sensitive-inferiors*
			,allow-sensitive-inferiors))
		   (,continuation)))
	       (,continuation)))))))

(defgeneric ptype-specializer (type)
  (:documentation "The specializer to use for this type in a presentation
method lambda list"))

;;; Metaclass for presentation types.  For presentation types not associated
;;; with CLOS classes, objects with this metaclass are used as a proxy for the
;;; type during presentation method dispatch. We don't prevent these
;;; presentation proxies from being subclasses of standard-object,
;;; but in presentation method dispatch we remove methods on standard
;;; object for presentation types that are not CLOS classes. The
;;; presentation type metaclass for T is the builtin object T instead
;;; of a presentation-type-class; in this way we can avoid weirdness
;;; with T being a subtype of standard-object!
;;;

(defclass presentation-type ()
  ((type-name :accessor type-name :initarg :type-name
	      :documentation "The name assigned to the presentation
type, as opposed to the name constructed for the class")
   (ptype-specializer :accessor ptype-specializer :initarg :ptype-specializer)
   (parameters :accessor parameters :initarg :parameters :initform nil)
   (parameters-lambda-list :accessor parameters-lambda-list
			   :initarg :parameters-lambda-list
			   :initform nil
			   :documentation "The parameters lambda list, altered for use in destructuring bind")
   (options :accessor options :initarg :options :initform nil)
   (options-lambda-list :accessor options-lambda-list
			:initarg :options-lambda-list
			:initform nil
			:documentation "The options lambda list,
altered for use in destructuring bind")
   (inherit-from :accessor inherit-from
		 :initarg :inherit-from
		 :documentation "Inherit-from form with dummys substituted")
   (inherit-from-function :accessor inherit-from-function
			  :initarg :inherit-from-function
			  :documentation "Function that returns the inherit-from form")
   (description :accessor description :initarg :description)
   (history :accessor history :initarg :history :initform nil
	    :documentation "Who knows?")
   (parameters-are-types :accessor parameters-are-types
			 :initarg :parameters-are-types
			 :initform nil)
   (expansion-function :accessor expansion-function
		       :initarg :expansion-function
		       :documentation "A function which expands the typespec
fully, including defaulting parameters and options.")))

(defmethod initialize-instance :after ((obj presentation-type) &key)
  (unless (slot-boundp obj 'ptype-specializer)
    (setf (slot-value obj 'ptype-specializer)
	  (make-presentation-type-name (slot-value obj 'type-name)))))

(defclass presentation-type-class (presentation-type standard-class)
  ())

(defmethod clim-mop:validate-superclass ((class presentation-type-class) 
					 (super standard-class))
  t)

(defclass clos-presentation-type (presentation-type)
  ((clos-class :accessor clos-class :initarg :clos-class
	       :documentation "Holds the class object of the CLOS class of this presentation type")))

(defmethod initialize-instance :after ((obj clos-presentation-type)
				       &key (ptype-specializer
					     nil
					     ptype-specializer-p))
  (declare (ignore ptype-specializer))
  (unless ptype-specializer-p
    (setf (slot-value obj 'ptype-specializer)
	  (slot-value obj 'type-name))))

(defmethod history ((ptype standard-class))
  "Default for CLOS types that are not defined explicitly as
presentation types."
  t)

(defvar *builtin-t-class* (find-class t))

;;;Methods for the T presentation type
(defmethod type-name ((class (eql *builtin-t-class*)))
  t)

(defmethod ptype-specializer ((class (eql *builtin-t-class*)))
  t)

(defmethod parameters ((class (eql *builtin-t-class*)))
  nil)

(defmethod parameters-lambda-list ((class (eql *builtin-t-class*)))
  nil)

(defmethod options ((class (eql *builtin-t-class*)))
  nil)

(defmethod options-lambda-list ((class (eql *builtin-t-class*)))
  nil)

(defmethod inherit-from ((class (eql *builtin-t-class*)))
  nil)

(defmethod inherit-from-function ((class (eql *builtin-t-class*)))
  #'(lambda (type)
      (declare (ignore type))
      nil))

(defmethod description ((class (eql *builtin-t-class*)))
  "The supertype of all presentation types.")

(defmethod history ((class (eql *builtin-t-class*)))
  t)

(defmethod parameters-are-types ((class (eql *builtin-t-class*)))
  nil)

(defmethod expansion-function ((class (eql *builtin-t-class*)))
  #'(lambda (type)
      (declare (ignore type))
      t))

(defun make-presentation-type-name (name)
  (intern (format nil "(presentation-type ~A::~A)"
		  (package-name (symbol-package name))
		  (symbol-name name))
	  :clim-internals))

(defun transform-parameters-lambda-list (ll)
  "Change the destructuring  lambda list so that any optional or key variable
that has no default is supplied with '*"
  (when (atom ll)
    (return-from transform-parameters-lambda-list ll))
  (let ((state 'required))
    (loop for lambda-var in ll
       collect
       (cond ((member lambda-var lambda-list-keywords :test #'eq)
	      (setq state lambda-var)
	      lambda-var)
	     ((eq state '&optional)
	      (if (atom lambda-var)
		  `(,lambda-var '*)
		  (cons (transform-parameters-lambda-list (car lambda-var))
			(or (cdr lambda-var) '('*)))))
	     ((eq state '&key)
	      (cond ((atom lambda-var)
		     `(,lambda-var '*))
		    ((atom (car lambda-var))
		     (cons (car lambda-var)
			   (or (cdr lambda-var) '('*))))
		    (t (destructuring-bind
			     ((var pattern)
			      &optional (default nil default-p)
			      &rest supplied-tail)
			   lambda-var
			 `((,var ,(transform-parameters-lambda-list
				   pattern))
			   ,(if default-p
				default
				'*)
			   ,@supplied-tail)))))
	     ((member state '(required &rest &body &whole))
	      (when (eq state '&whole)
		(setq state 'required))
	      (transform-parameters-lambda-list lambda-var))
	     (t lambda-var)))))

(defun fake-params-args (ll)
  (let ((state 'required))
    (flet ((do-arg (lambda-var)
	     (let ((var-name (symbol-name lambda-var)))
	       (cond ((or (eq state 'required) (eq state '&optional))
		      (list (gensym var-name)))
		     ((eq state '&key)
		      `(,(intern var-name :keyword) ,(gensym var-name)))
		     (t nil)))))
      (loop for lambda-var in ll
	 append (cond ((member lambda-var lambda-list-keywords :test #'eq)
		       (setq state lambda-var)
		       nil)
		      ((eq state '&whole)
		       (setq state 'required)
		       nil)
		      ((atom lambda-var)
		       (do-arg lambda-var))
		      ((consp lambda-var)
		       (let ((var (car lambda-var)))
			 (do-arg (if (and (eq state '&key) (consp var))
				     (car var)
				     var)))))))))

;;; Yet another variation on a theme...

(defun get-all-params (ll)
  (unless ll
    (return-from get-all-params nil))
  (when (atom ll)
    (return-from get-all-params (list ll)))
  (let ((state 'required))
    (loop for arg in ll
       append (cond ((member arg lambda-list-keywords :test #'eq)
		     (setq state arg)
		     nil)
		    ((eq state 'required)
		     (get-all-params arg))
		    ((or (eq state '&optional) (eq state '&aux))
		     (if (atom arg)
			 (list arg)
			 (get-all-params (car arg))))
		    ((eq state '&key)
		     (cond ((atom arg)
			    (list arg))
			   ((atom (car arg))
			    (list (car arg)))
			   (t (get-all-params (cadar arg)))))
		    ((member state '(required &rest &body &whole))
		     (when (eq state '&whole)
		       (setq state 'required))
		     (get-all-params arg))
		    (t nil)))))

;;; ...And another.  Given a lambda list, return a form that replicates the
;;; structure of the argument with variables filled in.

(defun map-over-lambda-list (function ll
			     &key (pass-lambda-list-keywords nil))
  (declare (ignore function pass-lambda-list-keywords))
  (unless ll
    (return-from map-over-lambda-list nil))
  (when (atom ll)
    (return-from map-over-lambda-list ll))
  (loop for args-tail = ll then (cdr args-tail)))

(defun make-keyword (sym)
  (intern (symbol-name sym) :keyword))

(defun cull-keywords (keys prop-list)
  (let ((plist (copy-list prop-list)))
    (loop for key in keys
       do (remf plist key))
    plist))

(defun recreate-lambda-list (ll)
  "Helper function.  Returns a form that, when evaluated inside a
DESTRUCTURING-BIND using ll, recreates the argument list with all defaults
filled in."
  (unless ll
    (return-from recreate-lambda-list nil))
  (when (atom ll)
    (return-from recreate-lambda-list ll))
  (let ((state 'required)
	(rest-var nil)
	(has-keys nil)
	(keys nil)
	(allow-other-keys nil))
    (loop for arg in ll
       append (cond ((member arg lambda-list-keywords :test #'eq)
		     (setq state arg)
		     (when (eq arg '&key)
		       (setq has-keys t))
		     (when (eq arg '&allow-other-keys)
		       (setq allow-other-keys t))
		     nil)
		    ((eq state '&whole)
		     nil)
		    ((eq state 'required)
		     (list (recreate-lambda-list arg)))
		    ((eq state '&optional)
		     (if (atom arg)
			 (list arg)
			 (list (recreate-lambda-list (car arg)))))
		    ((or (eq state '&rest) (eq state '&body))
		     (setq rest-var arg)
		     nil)
		    ((eq state '&key)
		     (let ((key nil)
			   (var nil))
		       (cond ((atom arg)
			      (setq key (make-keyword arg)
				    var arg))
			     ((atom (car arg))
			      (setq key (make-keyword (car arg))
				    var (car arg)))
				
			     (t (destructuring-bind
				      ((keyword pattern) &rest tail)
				    arg
				  (declare (ignore tail))
				  (setq key keyword
					var (recreate-lambda-list
					     pattern)))))
		       (push key keys)
		       (list key var)))
		    (t nil))
       into result-form
       finally (cond ((or (not rest-var)
			  (and has-keys
			       (not allow-other-keys)))
		      (return `(list ,@result-form)))
		     ((not has-keys)
		      (return `(list* ,@result-form ,rest-var)))
		     (t (return `(list* ,@result-form
					(cull-keywords ',(nreverse keys)
						       ,rest-var))))))))

(defun transform-options-lambda-list (ll)
  "Return a legal lambda list given an options specification"
  (let ((descriptionp nil))
    (loop for spec in ll
       collect (if (atom spec)
		   (progn
		     (when (eq (make-keyword spec) :description)
		       (setq descriptionp t))
		     spec)
		   (progn
		     (let ((key (if (atom (car spec))
				    (make-keyword (car spec))
				    (caar spec))))
		       (when (eq key :description)
			 (setq descriptionp t)))
		     (ldiff spec (cdddr spec))))
       into specs
       finally (return `(&key
			 ,@specs
			 ,@(unless descriptionp
				   `(((:description ,(gensym))))))))))


;;; External function
(declaim (inline presentation-type-name))

(defun presentation-type-name (type)
  (cond ((atom type)
	 type)
	((atom (car type))
	 (car type))
	(t (caar type))))

(defun decode-parameters (type)
  (cond ((atom type)
	 nil)
	((atom (car type))
	 (cdr type))
	(t (cdar type))))

(defun decode-options (type)
  (if (or (atom type) (atom (car type)))
      nil
      (cdr type)))

(defun make-inherit-from-lambda (params-ll options-ll form)
  (let ((type (gensym "TYPE")))
    `(lambda (,type)
       (destructuring-bind ,params-ll (decode-parameters ,type)
	 (declare (ignorable ,@(get-all-params params-ll)))
	 (destructuring-bind ,options-ll (decode-options ,type)
	   (declare (ignorable ,@(get-all-params options-ll)))
	   ,form)))))


(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-presentation-type-decoded ((name
					   &optional (params nil params-p)
					             (options nil options-p))
					  type &body body)
  (let ((type-var (gensym "TYPE-VAR")))
    `(let* ((,type-var ,type)
	    (,name (presentation-type-name ,type-var))
	    ,@(and params-p `((,params (decode-parameters ,type-var))))
	    ,@(and options-p `((,options (decode-options ,type-var)))))
       ,@body)))
)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun make-expansion-lambda (params-ll options-ll)
    (let ((params-form (recreate-lambda-list params-ll))
	  (options-form (recreate-lambda-list options-ll))
	  (parameters (gensym))
	  (options (gensym)))
      `(lambda (typespec)
	 (with-presentation-type-decoded (name ,parameters ,options)
	   typespec
	   (make-type-spec name
	    (destructuring-bind ,params-ll
		,parameters
	      ,params-form)
	    (destructuring-bind ,options-ll
		,options
	      ,options-form)))))))

(defvar *presentation-type-table* (make-hash-table :test #'eq))

(setf (gethash t *presentation-type-table*) (find-class t))

(defgeneric get-ptype-metaclass (type))

(defmethod get-ptype-metaclass ((type symbol))
  (let ((maybe-meta (gethash type *presentation-type-table*)))
    (if maybe-meta
	(get-ptype-metaclass maybe-meta)
	(let ((system-meta (find-class type nil)))
	  (and (typep system-meta 'standard-class)
	       system-meta)))))

(defmethod get-ptype-metaclass ((type presentation-type-class))
  type)

(defmethod get-ptype-metaclass ((type clos-presentation-type))
  (clos-class type))

(defmethod get-ptype-metaclass ((type (eql *builtin-t-class*)))
  type)

(defmethod get-ptype-metaclass ((type class))
  type)

(defmethod get-ptype-metaclass (type)
  (error "~A is not the name of a presentation type" type))

;;; external functions
(defun find-presentation-type-class (name &optional (errorp t) environment)
  (declare (ignore environment))
  (let ((metaclass (get-ptype-metaclass name)))
    (cond (metaclass
	   metaclass)
	  (errorp
	   (error "~S is not the name of a presentation type" name))
	  (t nil))))

(defun class-presentation-type-name (class &optional environment)
  (declare (ignore environment))
  (cond ((typep class 'presentation-type)
	 (type-name class))
	(t (class-name class))))

;;; For the presentation class T, the stand in object must not be a
;;; standard-object. So... why not the symbol T?

(defvar *class-t-prototype* t)

(defun prototype-or-error (name)
  (let ((ptype-meta (get-ptype-metaclass name)))
    (unless ptype-meta
      (error "~S is an unknown presentation type" name))
    (when (eq ptype-meta *builtin-t-class*)
      (return-from prototype-or-error *class-t-prototype*))
    (unless (clim-mop:class-finalized-p ptype-meta)
      (clim-mop:finalize-inheritance ptype-meta))
    (or (clim-mop:class-prototype ptype-meta)
      (error "Couldn't find a prototype for ~S" name))))

(defun safe-cpl (class)
  (unless (clim-mop:class-finalized-p class)
    (clim-mop:finalize-inheritance class))
  (clim-mop:class-precedence-list class))
  
(defun get-ptype (name)
  (or (gethash name *presentation-type-table*)
      (let ((meta (find-class name nil)))
	(and (typep meta 'standard-class)
	     meta))))

(defgeneric presentation-ptype-supers (type)
  (:documentation "Gets a list of the presentation type objects for those
supertypes of TYPE that are presentation types"))

(defmethod presentation-ptype-supers ((type symbol))
  (let ((ptype (gethash type *presentation-type-table*)))
    (if ptype
	(presentation-ptype-supers ptype)
	nil)))

(defmethod presentation-ptype-supers ((type presentation-type-class))
  (mapcan #'(lambda (class)
	      (typecase class
		(presentation-type
		 (list class))
		(standard-class
		 (let ((clos-ptype (gethash (class-name class)
					    *presentation-type-table*)))
		   (if clos-ptype
		       (list clos-ptype)
		       nil)))
		(t
		 nil)))
	  (clim-mop:class-direct-superclasses type)))

(defmethod presentation-ptype-supers ((type clos-presentation-type))
  (presentation-ptype-supers (clos-class type)))

;;; External function

(defun presentation-type-direct-supertypes (type)
  (with-presentation-type-decoded (name)
      type
    (let ((supers (presentation-ptype-supers name)))
      (mapcar #'class-presentation-type-name supers))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmethod ptype-specializer ((type symbol))
    (let ((ptype (gethash type *presentation-type-table*)))
      (cond (ptype
	     (ptype-specializer ptype))
	    ((find-class type nil)
	     (ptype-specializer (find-class type)))
	    ;; Assume it's a forward referenced CLOS class.
	    (t type))))

  (defmethod ptype-specializer ((type standard-class))
    (class-name type)))

;;; We need to patch defclass in every implementation to record a CLOS
;;; class at compiletime.  On the other hand, I think we can assume
;;; that if a CLOS class exists at compile time, it will exist at
;;; load/run time too.
(eval-when (:compile-toplevel :load-toplevel :execute)
  #-(or excl cmu sbcl openmcl)
  (defun compile-time-clos-p (name)
    (let ((meta (find-class name nil)))
      (and meta
	   (typep meta 'standard-class))))

  #+(or excl cmu sbcl openmcl)
  (defun compile-time-clos-p (name)
    (let ((metaclass (find-class name nil)))
      (or (and metaclass
	     (typep metaclass 'standard-class))
	(clim-lisp-patch::compile-time-clos-class-p name))))

  (defun make-default-description (name)
    "Create a description string from the type name"
    (let ((downcase-name (string-downcase name)))
      (setq downcase-name (nsubstitute-if-not #\Space
					      #'alphanumericp
					      downcase-name))
      (string-trim " " downcase-name)))

  (defun record-presentation-type (name parameters params-ll options options-ll
				   inherit-from-func description history
				   parameters-are-types
				   compile-time-p
				   supers expansion-func)
    (let* ((fake-name (make-presentation-type-name name))
	   (ptype-class-args (list :type-name name
				   :parameters parameters
				   :parameters-lambda-list params-ll
				   :options options
				   :options-lambda-list options-ll
				   :inherit-from-function inherit-from-func
				   :description description
				   :history history
				   :parameters-are-types parameters-are-types
				   :expansion-function expansion-func))
	   (ptype-meta
	    (if compile-time-p
		(apply #'make-instance
		       (if (compile-time-clos-p name)
			   'clos-presentation-type
			   'presentation-type)
		       ptype-class-args)
		(let* ((clos-meta (find-class name nil))
		       (closp (typep clos-meta 'standard-class)))
		  (if closp
		      (apply #'make-instance 'clos-presentation-type
			     :clos-class clos-meta
			     ptype-class-args)
		      (let ((directs (mapcan
				      #'(lambda (super)
					  (if (eq super t)
					      nil
					      (list (or (get-ptype-metaclass
							 super)
							super))))
					     supers)))
			(apply #'clim-mop:ensure-class fake-name
			       :name fake-name
			       :metaclass 'presentation-type-class
			       :direct-superclasses directs
			       ptype-class-args)))))))
      (setf (gethash name *presentation-type-table*) ptype-meta)
      ptype-meta))
  ); eval-when

(defgeneric massage-type-for-super (type-name super-name type-spec)
  (:documentation "translate TYPE-SPEC from that of TYPE-NAME to one
suitable for SUPER-NAME"))

;;; The default: there ain't no direct specification

(defmethod massage-type-for-super ((type-name t) (super-name t) type-spec)
  (declare (ignore type-spec))
  (values nil nil))

;;; Load-time actions for define-presentation-type
(defmacro %define-presentation-type (name parameters params-ll
				     options options-ll
				     inherit-from inherit-from-lambda
				     description history parameters-are-types)
  (declare (ignore inherit-from))
  (let* ((inherit-from-func (coerce inherit-from-lambda 'function))
	 (inherit-typespec (funcall inherit-from-func
				    (cons name (fake-params-args params-ll))))
	 (superclasses (if inherit-typespec
			   (with-presentation-type-decoded
			       (super-name super-params)
			     inherit-typespec
			     (if (eq super-name 'and)
				 (mapcar #'presentation-type-name super-params)
				 (list super-name)))
			   nil))
	 (expansion-lambda (make-expansion-lambda params-ll options-ll)))
    `(progn
       (record-presentation-type ',name ',parameters ',params-ll ',options
				   ',options-ll #',inherit-from-lambda
				   ',description ',history
				   ',parameters-are-types
				   nil ',superclasses
	                           #',expansion-lambda)
       ,@(cond ((eq (presentation-type-name inherit-typespec) 'and)
		(loop for super in superclasses
		    for i from 0
		    append (unless (or (not (atom super))
				       (eq super 'satisfies)
				       (eq super 'not))
			     `((defmethod massage-type-for-super
				   ((type-name (eql ',name))
				    (super-name (eql ',super))
				    type)
				 (values (nth ,i
					      (cdr (,inherit-from-lambda
						    type)))
					 t))))))
	       (superclasses
		`((defmethod massage-type-for-super
		      ((type-name (eql ',name))
		       (super-name (eql ',(car superclasses)))
		       type)
		    (values (,inherit-from-lambda type) t))))
	       (t nil)))))

(defmacro define-presentation-type (name parameters
				    &key options inherit-from
				    (description
				     (make-default-description name))
				    (history t)
				    parameters-are-types)
  (let* ((params-ll (transform-parameters-lambda-list parameters))
	 (options-ll (transform-options-lambda-list options))
	 (inherit-from-func (make-inherit-from-lambda params-ll
						      options-ll
						      inherit-from)))
    `(progn
       (eval-when (:compile-toplevel)
	 (record-presentation-type ',name ',parameters ',params-ll ',options
				   ',options-ll #',inherit-from-func
				   ',description ',history
				   ',parameters-are-types
				   t nil nil))
       (eval-when (:load-toplevel :execute)
	 (%define-presentation-type ,name ,parameters ,params-ll
				    ,options ,options-ll
				    ,inherit-from ,inherit-from-func
				    ,description ,history
				    ,parameters-are-types)))))

;;; These are used by the presentation method MOP code, but are
;;; actually defined in presentation-defs.lisp after the forms for these
;;; types are executed.

(defvar *ptype-t-class*)

(defvar *ptype-expression-class*)

(defvar *ptype-form-class*)

(defun presentation-type-parameters (type-name &optional env)
  (declare (ignore env))
  (let ((ptype (gethash type-name *presentation-type-table*)))
    (unless ptype
      (error "~S is not the name of a presentation type" type-name))
    (parameters ptype)))

(defun presentation-type-options (type-name &optional env)
  (declare (ignore env))
  (let ((ptype (gethash type-name *presentation-type-table*)))
    (unless ptype
      (error "~S is not the name of a presentation type" type-name))
    (options ptype)))

(defmacro with-presentation-type-parameters ((type-name type) &body body)
  (let ((ptype (get-ptype type-name)))
    (unless (or ptype (compile-time-clos-p type-name))
      (warn "~S is not a presentation type name." type-name))
    (if (typep ptype 'presentation-type)
	(let* ((params-ll (parameters-lambda-list ptype))
	       (params (gensym "PARAMS"))
	       (type-var (gensym "TYPE-VAR"))
	       (ignorable-vars (get-all-params params-ll)))
	  `(let ((,type-var ,type))
	    (unless (eq ',type-name (presentation-type-name ,type-var))
	      (error "Presentation type specifier ~S does not match the name ~S"
		     ,type-var
		     ',type-name))
	    (let ((,params (decode-parameters ,type-var)))
	      (declare (ignorable ,params))
	      (destructuring-bind ,params-ll ,params
		(declare (ignorable ,@ignorable-vars))
		,@body))))
	`(let ()
	   ,@body))))


(defmacro with-presentation-type-options ((type-name type) &body body)
  (let ((ptype (get-ptype type-name)))
    (unless (or ptype (compile-time-clos-p type-name))
      (warn "~S is not a presentation type name." type-name))
    (if (typep ptype 'presentation-type)
	(let* ((options-ll (options-lambda-list ptype))
	       (options (gensym "OPTIONS"))
	       (type-var (gensym "TYPE-VAR"))
	       (ignorable-vars (get-all-params options-ll)))
	  `(let ((,type-var ,type))
	    (unless (eq ',type-name (presentation-type-name ,type-var))
	      (error "Presentation type specifier ~S does not match the name ~S"
		     ,type-var
		     ',type-name))
	    (let ((,options (decode-options ,type-var)))
	      (declare (ignorable ,options))
	      (destructuring-bind ,options-ll ,options
		(declare (ignorable ,@ignorable-vars))
		,@body))))
	`(let ()
	   ,@body))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *presentation-type-abbreviations* (make-hash-table :test #'eq)))

(defmacro define-presentation-type-abbreviation (name parameters
						 equivalent-type
						 &key options)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf (gethash ',name *presentation-type-abbreviations*)
	   #',(make-inherit-from-lambda
	       (transform-parameters-lambda-list parameters)
	       (transform-options-lambda-list options)
	       equivalent-type))))

(defun make-type-spec (name parameters options)
  (cond (options
	 `((,name ,@parameters) ,@options))
	(parameters
	 `(,name ,@parameters))
	(t name)))

(defun expand-presentation-type-abbreviation-1 (type &optional env)
  (flet ((expand-list (specs)
	   (loop with expand-any-p = nil
		 for spec in specs
		 collect (multiple-value-bind (expansion expanded)
			     (expand-presentation-type-abbreviation-1 spec env)
			   (setq expand-any-p (or expand-any-p expanded))
			   expansion)
		 into new-params
		 finally (return (if expand-any-p
				     (values new-params t)
				     (values specs nil))))))
    (with-presentation-type-decoded (name parms options)
      type
      (case name
	((and or sequence sequence-enumerated)
	 (multiple-value-bind (expansion expanded)
	     (expand-list parms)
	   (if expanded
	       (values (make-type-spec name expansion options) t)
	       (values type nil))))
	(t (let* ((expander (gethash name *presentation-type-abbreviations*)))
	     (flet ((copy-description (expanded-typespec)
		      (with-presentation-type-decoded (expand-name
						       expand-params
						       expand-options)
			expanded-typespec
			(let ((description (getf options :description))
			      (expand-desc (getf expand-options :description)))
			  (if (and description
				   (null expand-desc))
			      (make-type-spec expand-name
					      expand-params
					      `(:description ,description
						,@expand-options))
			      expanded-typespec)))))
	       (if expander
		 (values (copy-description (funcall expander type)) t)
		 (values type nil)))))))))


(defun expand-presentation-type-abbreviation (type &optional env)
  (let ((expand-any-p nil))
    (loop
     (multiple-value-bind (expansion expanded)
	 (expand-presentation-type-abbreviation-1 type env)
       (if expanded
	   (progn
	     (setq expand-any-p t)
	     (setq type expansion))
	   (return (values type expand-any-p)))))))

(defun make-presentation-type-specifier (name-and-params &rest options)
  (with-presentation-type-decoded (name)
    name-and-params
    (let ((ptype (gethash name *presentation-type-table*)))
      (unless ptype
	(return-from make-presentation-type-specifier name-and-params))
      (with-presentation-type-decoded (name parameters defaults)
	(funcall (expansion-function ptype) name-and-params)
	(declare (ignore name parameters))
	(loop for (key val) on options by #'cddr
	      for default = (getf defaults key)
	      unless (equal val default)
	      nconc (list key val) into needed-options
	      finally (return (if needed-options
				  `(,name-and-params ,@needed-options)
				  name-and-params)))))))

;;; Presentation methods.
;;;
;;; The basic dispatch is performed via CLOS instances that are standins
;;; for the presentation types.  There are a couple of complications to
;;; this simple plan.  First, methods on the presentation type class
;;;STANDARD-OBJECT -- if there are any -- should not be applicable to
;;;presentation types that are not CLOS classes, even though STANDARD-OBJECT
;;;is in the class precedence list of the standin object. Our own methods on
;;;COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-APPLICABLE-METHODS
;;;remove methods specialized on standard-object.
;;;
;;; The second major complication is the whole raison d'etre of presentation
;;; type methods: type parameters and options are massaged so that
;;; applicable methods written on the supertype of a presentation type get
;;; parameters and options in the expected form.  "Real" CLIM apparently
;;; does this massaging in the body of the effective method and passes the
;;; massaged parameters as an argument into the method.  We do it with a
;;; function call within the body of the method.  This is potentially more
;;; expensive, but caching should help that.  Our method has the huge
;;; advantage of working with any method combination.

(defclass presentation-gf-info ()
  ((generic-function-name :accessor generic-function-name
			  :initarg :generic-function-name)
   (lambda-list :accessor lambda-list :initarg :lambda-list)
   (type-key-arg :accessor type-key-arg :initarg :type-key-arg)
   (parameters-arg :accessor parameters-arg :initarg :parameters-arg
		   :initform nil)
   (options-arg :accessor options-arg :initarg :options-arg :initform nil)
   (type-arg-position :accessor type-arg-position
		      :initarg :type-arg-position)))

(defvar *presentation-gf-table* (make-hash-table :test #'eq))

(defclass presentation-generic-function (standard-generic-function)
  ()
  (:metaclass clim-mop:funcallable-standard-class))

(defvar *standard-object-class* (find-class 'standard-object))

#-scl
(defmethod clim-mop:compute-applicable-methods-using-classes :around
    ((gf presentation-generic-function) classes)
  (multiple-value-bind (methods success)
      (call-next-method)
    (let ((ptype-class (car classes)))
      (if (or (null success)
	      (not (typep ptype-class 'presentation-type-class)))
	  (values methods success)
	  (values (remove-if #'(lambda (method)
				 (eq (car (clim-mop:method-specializers
					   method))
				     *standard-object-class*))
			     methods)
		  t)))))

#+scl
(defmethod clim-mop:compute-applicable-methods-using-classes :around
    ((gf presentation-generic-function) classes)
  (multiple-value-bind (methods success non-class-positions)
      (call-next-method)
    (let ((ptype-class (car classes)))
      (if (or (null success)
	      (not (typep ptype-class 'presentation-type-class)))
	  (values methods non-class-positions non-class-positions)
	  (values (remove-if #'(lambda (method)
				 (eq (car (clim-mop:method-specializers
					   method))
				     *standard-object-class*))
			     methods)
		  t
		  non-class-positions)))))

(defun method-applicable (method arguments)
  (loop for arg in arguments
	for specializer in (clim-mop:method-specializers method)
	always (cond ((typep specializer 'clim-mop:eql-specializer)
		      (eql arg (clim-mop:eql-specializer-object specializer)))
		     ((typep arg specializer)
		      t)
		     ((and (not (typep (class-of arg)
				       'presentation-type-class))
			   (or (eq specializer *ptype-form-class*)
			       (eq specializer *ptype-expression-class*)))
		      t)
		     (t nil))))

(defmethod compute-applicable-methods :around
    ((gf presentation-generic-function) arguments)
  (let ((methods (call-next-method)))
    (if (typep (class-of (car arguments)) 'presentation-type-class)
	(remove-if #'(lambda (method)
		       (eq (car (clim-mop:method-specializers method))
			   *standard-object-class*))
		   methods)
	methods)))

;;; The hard part of presentation methods: translating the type specifier for
;;; superclasses.
;;;

(defmethod type-name ((type standard-class))
  (class-name type))

(defmethod expansion-function ((type standard-class))
  #'(lambda (typespec)
      (with-presentation-type-decoded (name)
	typespec
	name)))

(defmethod presentation-ptype-supers ((type standard-class))
  (mapcan #'(lambda (class)
	      (let ((ptype (gethash (class-name class)
				    *presentation-type-table*)))
		(and ptype (list ptype))))
	  (clim-mop:class-direct-superclasses type)))

(defun translate-specifier-for-type (type-name super-name specifier)
  (when (eq type-name super-name)
    (return-from translate-specifier-for-type (values specifier t)))
  (multiple-value-bind (translation found)
      (massage-type-for-super type-name super-name specifier)
    (when found
      (return-from translate-specifier-for-type (values translation t))))
  (loop for super in (presentation-ptype-supers type-name)
	do (multiple-value-bind (translation found)
	       (translate-specifier-for-type (type-name super)
					     super-name
					     (massage-type-for-super
					      type-name
					      (type-name super)
					      specifier))
	     (when found
	       (return-from translate-specifier-for-type (values translation
								 t)))))
  (values super-name nil))

;;; XXX can options be specified without parameters?  I think not.
(defmacro define-presentation-generic-function (generic-function-name
						presentation-function-name
						lambda-list
						&rest options)
    (let ((type-key-arg (car lambda-list))
	  (parameters-arg (cadr lambda-list))
	  (options-arg (caddr lambda-list)))
      (unless (or (eq type-key-arg 'type-key) (eq type-key-arg 'type-class))
	(error "The first argument in a presentation generic function must be
type-key or type-class"))
      (unless (eq parameters-arg 'parameters)
	(setq parameters-arg nil))
      (unless (eq options-arg 'options)
	(setq options-arg nil))
      (let* ((gf-lambda-list (cons type-key-arg
				   (cond (options-arg
					  (cdddr lambda-list))
					 (parameters-arg
					  (cddr lambda-list))
					 (t (cdr lambda-list)))))
	     ;; XXX should check that it's required
	     (type-arg-pos (position 'type gf-lambda-list)))
	(unless type-arg-pos
	  (error "type must appear as an argument in a presentation generic
function lambda list"))
	`(progn
	   (eval-when (:compile-toplevel :load-toplevel :execute)
	     (setf
	      (gethash ',presentation-function-name *presentation-gf-table*)
	      (make-instance 'presentation-gf-info
			     :generic-function-name ',generic-function-name
			     :lambda-list ',lambda-list
			     :type-key-arg ',type-key-arg
			     :parameters-arg ',parameters-arg
			     :options-arg ',options-arg
			     :type-arg-position ,type-arg-pos)))
	   (defgeneric ,generic-function-name ,gf-lambda-list
	     (:generic-function-class presentation-generic-function)
	     ,@options)))))

(defun parse-method-body (args)
  (loop for arglist on args
     for (arg) = arglist
     while (atom arg)
     collect arg into qualifiers
     finally (if (and (consp arglist)
		      (consp (cdr arglist))
		      (consp (cadr arglist))
		      (eq (caadr arglist) 'declare))
		 (return (values qualifiers arg (cadr arglist) (cddr arglist)))
		 (return (values qualifiers arg nil (cdr arglist))))))

(defun type-name-from-type-key (type-key)
  (if (symbolp type-key)
      't
      (type-name (class-of type-key))))

(defmacro define-presentation-method (name &rest args)
  (when (eq name 'presentation-subtypep)
    ;; I feel so unclean!
    (return-from define-presentation-method
      `(define-subtypep-method ,@args)))
  (let ((gf (gethash name *presentation-gf-table*)))
    (unless gf
      (error "~S is not a presentation generic function" name))
    (with-accessors ((parameters-arg parameters-arg)
		     (options-arg options-arg))
      gf
      (multiple-value-bind (qualifiers lambda-list decls body)
	  (parse-method-body args)
	(let ((type-arg (nth (1- (type-arg-position gf)) lambda-list)))
	  (unless (consp type-arg)
	    (error "Type argument in presentation method must be specialized"))
	  (unless (eq (car type-arg)  'type)
	    (error "Type argument mismatch with presentation generic function
 definition"))
	  (destructuring-bind (type-var type-name) type-arg
	    (let* ((method-ll `((,(type-key-arg gf)
				 ,(ptype-specializer type-name))
				,@(copy-list lambda-list)))
		   (real-body body)
		   (massaged-type (gensym "MASSAGED-TYPE")))
	      (when options-arg
		(setq real-body
		      `((let ((,options-arg (decode-options ,massaged-type)))
			  (declare (ignorable ,options-arg))
			  (with-presentation-type-options (,type-name
							   ,massaged-type)
			    ,@real-body)))))
 	      (when parameters-arg
		(setq real-body
		      `((let ((,parameters-arg (decode-parameters
						,massaged-type)))
			  (declare (ignorable ,parameters-arg))
			  (with-presentation-type-parameters (,type-name
							      ,massaged-type)
			    ,@real-body)))))
	      (when (or options-arg parameters-arg)
		(setq real-body
		      `((let ((,massaged-type (translate-specifier-for-type
					       (type-name-from-type-key
						,(type-key-arg gf))
					       ',type-name
					       ,type-var)))
			  ,@real-body))))
	      (setf (nth (type-arg-position gf) method-ll) type-var)
	      `(defmethod ,(generic-function-name gf) ,@qualifiers ,method-ll
		 ,@(when decls
		     (list decls))
		 (block ,name
		   ,@real-body)))))))))



(defmacro define-default-presentation-method (name &rest args)
  (let ((gf (gethash name *presentation-gf-table*)))
    (unless gf
      (error "~S is not a presentation generic function" name))
    (multiple-value-bind (qualifiers lambda-list decls body)
	(parse-method-body args)
      `(defmethod ,(generic-function-name gf) ,@qualifiers (,(type-key-arg gf)
							    ,@lambda-list)
	 (declare (ignorable ,(type-key-arg gf))
		  ,@(cdr decls))
	 (block ,name
	   ,@body)))))

;;; Somewhat obsolete, but keep it around for apply-presentation-generic-function.
(defun %funcall-presentation-generic-function (name gf type-arg-position
					       &rest args)
  (declare (ignore name))
  (let* ((type-spec (nth (1- type-arg-position) args))
	 (ptype-name (presentation-type-name type-spec)))
    (apply gf (prototype-or-error ptype-name) args)))

;;; I wonder if this pattern for preserving order of evaluation is
;;; has a more general use...

(defmacro funcall-presentation-generic-function (name &rest args)
  (let ((gf (gethash name *presentation-gf-table*)))
    (unless gf
      (error "~S is not a presentation generic function" name))
    (let* ((rebound-args (loop for arg in args
                            unless (symbolp arg)
                            collect (list (gensym "ARG") arg)))
           (gf-name (generic-function-name gf))
           (type-spec-var (nth (1- (type-arg-position gf)) args)))
      `(let ,rebound-args
         (,gf-name (prototype-or-error (presentation-type-name
                                        ,(or (first (find type-spec-var rebound-args :key #'second))
                                             type-spec-var)))
                   ,@(mapcar #'(lambda (arg)
                                 ;; Order of evaluation doesn't matter
                                 ;; for symbols, and this shuts up
                                 ;; warnings about arguments in a
                                 ;; keyword position not being
                                 ;; constant. By the way, why do we
                                 ;; care about order of evaluation
                                 ;; here? -trh
                                 (or (first (find arg rebound-args :key #'second))
                                     arg)) args))))))

(defmacro apply-presentation-generic-function (name &rest args)
  (let ((gf (gethash name *presentation-gf-table*)))
    (unless gf
      (error "~S is not a presentation generic function" name))
    `(apply #'%funcall-presentation-generic-function ',name
	    #',(generic-function-name gf)
	    ,(type-arg-position gf)
	    ,@args)))

;;; 23.7.1 Defining Presentation Translators

(defclass presentation-translator ()
  ((name :reader name :initarg :name)   
   (from-type :reader from-type :initarg :from-type)
   (to-type :reader to-type :initarg :to-type)
   (gesture :reader gesture :initarg :gesture)
   (tester :reader tester :initarg :tester)
   (tester-definitive :reader tester-definitive :initarg :tester-definitive)
   (documentation :reader translator-documentation :initarg :documentation)
   (pointer-documentation :reader pointer-documentation
			  :initarg :pointer-documentation)
   (menu :reader menu :initarg :menu)
   (priority :reader priority :initarg :priority :initform 0)
   (translator-function :reader translator-function
			:initarg :translator-function)))

(defmethod initialize-instance :after ((obj presentation-translator)
				       &key &allow-other-keys)
  (unless (slot-boundp obj 'pointer-documentation)
    (setf (slot-value obj 'pointer-documentation)
	  (translator-documentation obj))))

(defmethod print-object ((obj presentation-translator) stream)
  (print-unreadable-object (obj stream :identity t)
    (format stream "Translator ~S from ~S to ~S"
	    (name obj) (from-type obj) (to-type obj))))

(defclass presentation-action (presentation-translator)
  ())

(defmethod initialize-instance :after ((obj presentation-action)
				       &key &allow-other-keys)
  (setf (slot-value obj 'tester-definitive) t))

(defmethod print-object ((obj presentation-action) stream)
  (print-unreadable-object (obj stream :identity t)
    (format stream "Action from ~S to ~S" (from-type obj) (to-type obj))))

;;; This lives in a command table

(defvar *current-translator-cache-generation* 0
  "This is incremented whenever presentation translators are defined,
and used to ensure that presentation-translators-caches are up to date.")

(defclass translator-table ()
  ((translators :accessor translators :initarg :translators
		:initform (make-hash-table :test #'eq)
		:documentation "Translators keyed by name.")
   (simple-type-translators :accessor simple-type-translators
			    :initarg :simple-type-translators
			    :initform (make-hash-table :test #'eq)
			    :documentation "Holds transators with a simple
  from-type (i.e. doesn't contain \"or\" or \"and\").")
   (translator-cache-generation :accessor translator-cache-generation :initform 0)
   (presentation-translators-cache
    :writer (setf presentation-translators-cache)
    :initform (make-hash-table :test #'equal))))

(defun invalidate-translator-caches ()
  (incf *current-translator-cache-generation*))

(defmethod presentation-translators-cache ((table translator-table))
  (with-slots ((cache presentation-translators-cache)
	       (generation translator-cache-generation))
      table    
    (unless (or (= generation *current-translator-cache-generation*)
		(zerop (hash-table-size cache)))            
      (clrhash cache))
    (setf generation *current-translator-cache-generation*)
    cache))
      
      

;;; Returns function lambda list, ignore forms
(defun make-translator-ll (translator-args)
  (let ((object-arg (find "object" translator-args :test #'string-equal))
	(ignore-form nil))
    (if object-arg
	(setq translator-args (remove "object" translator-args
				      :test #'string-equal))
	(progn
	  (setq object-arg (gensym "OBJECT-ARG"))
	  (setq ignore-form `(declare (ignore ,object-arg)))))
    (values `(,object-arg &key ,@translator-args &allow-other-keys)
	    ignore-form)))

(defun default-translator-tester (object-arg &key &allow-other-keys)
  (declare (ignore object-arg))
  t)

(defun add-translator (table translator)
  ;; Remove old one.
  (with-accessors ((translators translators)
		   (simple-type-translators simple-type-translators))
      table
    (let ((old (gethash (name translator) translators)))
      (when old
	(setf (gethash (presentation-type-name (from-type old))
		       simple-type-translators)
	      (remove old
		      (gethash (presentation-type-name (from-type old))
			       simple-type-translators))))
      (invalidate-translator-caches)
      (setf (gethash (name translator) translators) translator)
      (push translator
	    (gethash (from-type translator) simple-type-translators))
      translator)))

(defun make-translator-fun (args body)
  (multiple-value-bind (ll ignore)
      (make-translator-ll args)
    `(lambda ,ll
       ,@(and ignore (list ignore))
       ,@body)))

(defun make-documentation-fun (doc-arg)
  (cond ((and doc-arg (symbolp doc-arg))
	 doc-arg)
	((consp doc-arg)
	 (make-translator-fun (car doc-arg) (cdr doc-arg)))
	((stringp doc-arg)
	 `(lambda (object &key stream &allow-other-keys)
	    (declare (ignore object))
	    (write-string ,doc-arg stream)))
	((null doc-arg)
	 `(lambda (object &key presentation stream &allow-other-keys)
	    (present object (presentation-type presentation)
		     :stream stream :sensitive nil)))
	(t (error "Can't handle doc-arg ~S" doc-arg))))

(defmacro define-presentation-translator
    (name (from-type to-type command-table &rest translator-options &key
	   (gesture :select)
	   (tester 'default-translator-tester testerp)
	   (tester-definitive (if testerp nil t))
	   (documentation nil documentationp)
	   (pointer-documentation nil pointer-documentation-p)
	   (menu t)
	   (priority 0)
	   (translator-class 'presentation-translator)
	   &allow-other-keys)
     arglist
     &body body)
  ;; null tester should be the same as no tester
  (unless tester
    (setq tester 'default-translator-tester)
    (setq tester-definitive t))
  (let* ((real-from-type (expand-presentation-type-abbreviation from-type))
	 (real-to-type (expand-presentation-type-abbreviation to-type)))
    (with-keywords-removed (translator-options
			    (:gesture :tester :tester-definitive :documentation
			     :pointer-documentation :menu :priority
			     :translator-class))
      `(add-translator (presentation-translators (find-command-table
						  ',command-table))
		       (make-instance
			',translator-class
			:name ',name
			:from-type ',real-from-type
			:to-type ',real-to-type
			:gesture ,(if (eq gesture t)
				      t
				      `(gethash ',gesture *gesture-names*))
			:tester ,(if (symbolp tester)
				     `',tester
				     `#',(make-translator-fun (car tester)
							      (cdr tester)))
			:tester-definitive ',tester-definitive
			:documentation #',(make-documentation-fun
					   (if documentationp
					       documentation
					       (command-name-from-symbol
						name)))
			,@(when pointer-documentation-p
				`(:pointer-documentation
				  #',(make-documentation-fun
				      pointer-documentation)))
			:menu ',menu
			:priority ,priority
			:translator-function #',(make-translator-fun arglist
								     body)
			,@translator-options)))))

(defmacro define-presentation-action
    (name (from-type to-type command-table &key
	   (gesture :select)
	   (tester 'default-translator-tester)
	   (documentation nil documentationp)
	   (pointer-documentation nil pointer-documentation-p)
	   (menu t)
	   (priority 0))
     arglist
     &body body)
  (let* ((real-from-type (expand-presentation-type-abbreviation from-type))
	 (real-to-type (expand-presentation-type-abbreviation to-type)))
    `(add-translator (presentation-translators (find-command-table
						',command-table))
      (make-instance
       'presentation-action
       :name ',name
       :from-type ',real-from-type
       :to-type ',real-to-type
       :gesture ,(if (eq gesture t)
		     t
		     `(gethash ',gesture *gesture-names*))
       :tester ,(if (symbolp tester)
		    `',tester
		    `#',(make-translator-fun (car tester)
					     (cdr tester)))
       :tester-definitive t
       :documentation #',(make-documentation-fun (if documentationp
						     documentation
						     (command-name-from-symbol
						      name)))
       ,@(when pointer-documentation-p
	       `(:pointer-documentation
		 #',(make-documentation-fun pointer-documentation)))
       :menu ',menu
       :priority ,priority
       :translator-function #',(make-translator-fun arglist
						    body)))))

;;; define-presentation-to-command-translator is in commands.lisp

;;; 23.7.2 Presentation Translator Functions

;;; Used by map-over-presentation-type-supertypes as well

(defun map-over-ptype-superclasses (function type)
  (let* ((type-name (presentation-type-name type))
	 (type-meta (get-ptype-metaclass type-name))
	 (type-is-ptype (typep type-meta 'presentation-type-class)))
    (unless type-meta
      (return-from map-over-ptype-superclasses nil))
    (loop
       for super-meta in (safe-cpl type-meta)
       ;; structure classes?
       when (and (or (typep super-meta 'standard-class)
		     (eq super-meta *builtin-t-class*))
		 (not (and type-is-ptype
			   (eq super-meta *standard-object-class*))))
       do (funcall function super-meta))))

;;; This is to implement the requirement on presentation translators
;;; for doing subtype calculations without reference to type
;;; parameters.  We are generous in that we return T when we are
;;; unsure, to give translator testers a chance to accept or reject
;;; the translator.  This is essentially 
;;;   (multiple-value-bind (yesp surep)
;;;       (presentation-subtypep maybe-subtype type)
;;;     (or yesp (not surep)))
;;; except faster.
(defun stupid-subtypep (maybe-subtype type)
  "Return t if maybe-subtype is a presentation subtype of type, regardless of
  parameters."
  (when (or (eq maybe-subtype nil) (eq type t))
    (return-from stupid-subtypep t))
  (when (eql maybe-subtype type)
    (return-from stupid-subtypep t))
  (let ((maybe-subtype-name (presentation-type-name maybe-subtype))
	(type-name (presentation-type-name type)))
    (cond
      ;; see DEFUN PRESENTATION-SUBTYPEP for some caveats
      ((eq maybe-subtype-name 'or)
       (let ((or-types (decode-parameters maybe-subtype)))
         (every (lambda (x) (stupid-subtypep x type)) or-types)))
      ((eq type-name 'and)
       (stupid-subtypep maybe-subtype (car (decode-parameters type))))
      ((eq type-name 'or)
       (let ((or-types (decode-parameters type)))
         (some (lambda (x) (stupid-subtypep maybe-subtype x)) or-types)))
      ((eq maybe-subtype-name 'and)
       ;; this clause is actually not conservative, but probably in a
       ;; way that no-one will complain about too much.  Basically, we
       ;; will only return T if the first type in the AND (which is
       ;; treated specially by CLIM) is subtypep the maybe-supertype
       (stupid-subtypep (car (decode-parameters maybe-subtype)) type))
      (t
       (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name))
             (type-meta (get-ptype-metaclass type-name)))
         (unless (and subtype-meta type-meta)
           (return-from stupid-subtypep nil))
         (map-over-ptype-superclasses #'(lambda (super)
                                          (when (eq type-meta super)
                                            (return-from stupid-subtypep t)))
                                      maybe-subtype-name)
         nil)))))

(defun find-presentation-translators (from-type to-type command-table)
  (let* ((command-table (find-command-table command-table))	 
	 (from-name (presentation-type-name from-type))
	 (to-name (presentation-type-name to-type))
	 (cached-translators (gethash (cons from-name to-name)
				      (presentation-translators-cache
				       (presentation-translators
					command-table)))))
    (when cached-translators
      (return-from find-presentation-translators cached-translators))
    (let ((translator-vector (make-array 8 :adjustable t :fill-pointer 0))
	  (table-counter 0))
      (do-command-table-inheritance (table command-table)
	(let ((translator-map (simple-type-translators
			       (presentation-translators table))))
	  (flet ((get-translators (type)
		   (let ((translators (gethash type translator-map)))
		     (loop for translator in translators
			   if (stupid-subtypep (to-type translator)
					       to-type)
			   do (vector-push-extend (cons translator
							table-counter)
						  translator-vector)))))
	    (map-over-ptype-superclasses #'(lambda (super)
					     (get-translators (type-name
							       super)))
					 from-name)))
	(incf table-counter))
      (let ((from-super-names nil))
	(map-over-ptype-superclasses #'(lambda (super)
					 (push (type-name super)
					       from-super-names))
				     from-name)
	(setq from-super-names (nreverse from-super-names))
	;; The Spec mentions "high order priority" and "low order priority"
	;; without saying what that is!  Fortunately, the Franz CLIM user guide
	;; says that high order priority is (floor priority 10), low order
 	;; priority is (mod priority 10.) That's pretty wacked...
	(flet ((translator-lessp (a b)
		 (destructuring-bind (translator-a . table-num-a)
		     a
		   (destructuring-bind (translator-b . table-num-b)
		       b
		     (multiple-value-bind (hi-a low-a)
			 (floor (priority translator-a))
		       (multiple-value-bind (hi-b low-b)
			   (floor (priority translator-b))
			 ;; High order priority
			 (cond ((> hi-a hi-b)
				(return-from translator-lessp t))
			       ((< hi-a hi-b)
				(return-from translator-lessp nil)))
			 ;; more specific
			 (let ((a-precedence (position 
					      (presentation-type-name
					       (from-type translator-a))
					      from-super-names))
			       (b-precedence (position 
					      (presentation-type-name
					       (from-type translator-b))
					      from-super-names)))
			   (cond ((< a-precedence b-precedence)
				  (return-from translator-lessp t))
				 ((> a-precedence b-precedence)
				  (return-from translator-lessp nil))))
			 ;; Low order priority
			 (cond ((> low-a low-b)
				(return-from translator-lessp t))
			       ((< low-a low-b)
				(return-from translator-lessp nil)))))
		     ;; Command table inheritance
		     (< table-num-a table-num-b)))))
	  ;; Add translators to their caches.
	  (setf (gethash (cons from-name to-name)
			 (presentation-translators-cache
			  (presentation-translators command-table)))
                (remove-duplicates
                 (map 'list
                      #'car
                      (sort translator-vector #'translator-lessp)))))))))

(defgeneric call-presentation-translator
    (translator presentation context-type frame event window x y))

(defmethod call-presentation-translator
    ((translator presentation-translator) presentation context-type
     frame event window x y)
  ;; Let the translator return an explict ptype of nil to, in effect, abort the
  ;; presentation throw.
  (multiple-value-call
      #'(lambda (object &optional (ptype context-type) options)
	  (values object ptype options))
    (funcall (translator-function translator)
	     (presentation-object presentation)
	     :presentation presentation
	     :context-type context-type
	     :frame frame
	     :event event
	     :window window
	     :x x
	     :y y)))

(defmethod call-presentation-translator
    ((translator presentation-action) presentation context-type
     frame event window x y)
  (funcall (translator-function translator)
	   (presentation-object presentation)
	   :presentation presentation
	   :context-type context-type
	   :frame frame
	   :event event
	   :window window
	   :x x
	   :y y)
  (values nil nil nil))

(defun document-presentation-translator (translator
					 presentation
					 context-type
					 frame
					 event
					 window
					 x y
					 &key (stream *standard-output*)
					 (documentation-type :normal))
  (funcall (if (eq documentation-type :normal)
	       (translator-documentation translator)
	       (pointer-documentation translator))
	   (presentation-object presentation)
	   :presentation presentation
	   :context-type context-type
	   :frame frame
	   :event event
	   :window window
	   :x x
	   :y y
	   :stream stream))

;;; :button is a pointer button state, for performing matches where we want to
;;; restrict the match to certain gestures but don't have a real event.

(defun test-presentation-translator
    (translator presentation context-type frame window x y
     &key event (modifier-state 0) for-menu button)
  (flet ((match-gesture (gesture event modifier-state)
	   (let ((modifiers (if event
				(event-modifier-state event)
				modifier-state)))
	     (or (eq gesture t)
		 for-menu
		 (loop for g in gesture
		       thereis (and (eql modifiers (caddr g))
				    (or (and button (eql button (cadr g)))
					(and (null button)
					     (or (null event)
						 (eql (pointer-event-button
						       event)
						      (cadr g)))))))))))
    (let* ((from-type (from-type translator)))
      (unless (match-gesture (gesture translator) event modifier-state)
	(return-from test-presentation-translator nil))
      (unless (or (null (decode-parameters from-type))
		  (presentation-typep (presentation-object presentation)
				      from-type))
	(return-from test-presentation-translator nil))
      (unless (or (null (tester translator))
		  (funcall (tester translator)
			   (presentation-object presentation)
			   :presentation presentation
			   :context-type context-type
			   :frame frame
			   :window window
			   :x x
			   :y y
			   :event event))
	(return-from test-presentation-translator nil))
      (unless (or (tester-definitive translator)
		  (null (decode-parameters context-type))
		  (presentation-typep (call-presentation-translator
				       translator
				       presentation
				       context-type
				       frame
				       event
				       window
				       x y)
				      context-type))
	(return-from test-presentation-translator nil))))
  t)

;;; presentation-contains-position moved to presentation-defs.lisp

(defun map-over-presentations-containing-position (func record x y)
  "maps recursively over all presentations in record, including record."
  (map-over-output-records-containing-position
   #'(lambda (child)
       (when (output-record-p child)	; ? What else could it be? --moore
	 (map-over-presentations-containing-position func child x y))
       #+nil
       (when (presentationp child)
	 (funcall func child)))
   record
   x y)
  (when (and (presentationp record)
	     (presentation-contains-position record x y))
    (funcall func record)))

(defvar *null-presentation*)

(defun map-applicable-translators (func
				   presentation input-context frame window x y
				   &key event (modifier-state 0)
					for-menu
					button)
  (flet ((process-presentation (context context-ptype presentation)
	   (let ((maybe-translators
		  (find-presentation-translators (presentation-type 
						  presentation)
						 context-ptype
						 (frame-command-table
						  frame))))
	     (loop for translator in maybe-translators
		 when (and (or (not for-menu) (eql for-menu (menu translator)))
			   (test-presentation-translator translator
							 presentation
							 context-ptype
							 frame
							 window
							 x y
							 :event event
							 :modifier-state
							 modifier-state
							 :for-menu for-menu
							 :button button))
		 do (funcall func translator presentation context)))))
    (if (and (presentationp presentation)
	     (presentation-subtypep (presentation-type presentation) 
				    'blank-area))
	(loop for context in input-context
	      for (context-ptype) = context
	      do (process-presentation context context-ptype presentation))
	(loop for context in input-context
	      for (context-ptype) = context
	      do (map-over-presentations-containing-position
		  #'(lambda (p)
		      (process-presentation context context-ptype p))
		  presentation
		  x y)))))

(defun window-modifier-state (window)
  "Provides default modifier state for presentation translator functions."
  (let ((pointer (port-pointer (port window))))
    (pointer-modifier-state pointer)))

(defun find-applicable-translators
    (presentation input-context frame window x y
     &key event (modifier-state (window-modifier-state window)) for-menu fastp)
  (let ((results nil))
    (flet ((fast-func (translator presentation context)
	     (declare (ignore translator presentation context))
	     (return-from find-applicable-translators t))
	   (slow-func (translator presentation context)
	     (push (list translator presentation (input-context-type context))
		   results)))
      (map-applicable-translators (if fastp #'fast-func #'slow-func)
				  presentation input-context frame window x y
				  :event event
				  :modifier-state modifier-state
				  :for-menu for-menu)
      (nreverse results))))

(defun presentation-matches-context-type
    (presentation context-type frame window x y &key event (modifier-state 0))
  (let* ((ptype (expand-presentation-type-abbreviation (presentation-type
						       presentation)))
	 (ctype (expand-presentation-type-abbreviation context-type))
	 (translators (find-presentation-translators ptype
						     ctype
						     (frame-command-table
						      frame))))
    (loop for translator in translators
	  if (test-presentation-translator translator
					   presentation
					   ctype
					   frame
					   window
					   x y
					   :event event
					   :modifier-state modifier-state)
	  do (return-from presentation-matches-context-type t))
    nil))

;;; 23.7.3 Finding Applicable Presentations

(defun find-innermost-presentation-match
    (input-context top-record frame window x y event modifier-state button)
  "Helper function that implements the \"innermost-smallest\" input-context
  presentation matching algorithm.  Returns presentation, translator, and
  matching input context."
  (let ((result nil)
	(result-translator nil)
	(result-context nil)
	(result-size nil))
    (map-applicable-translators
     #'(lambda (translator presentation context)
         (if (and result-context (not (eq result-context context)))
	     ;; Return inner presentation
	     (return-from find-innermost-presentation-match
	       (values result result-translator result-context))
	     (multiple-value-bind (min-x min-y max-x max-y)
		 (output-record-hit-detection-rectangle* presentation)
	       (let ((size (* (- max-x min-x) (- max-y min-y))))
		 (when (or (not result) (< size result-size))
		   (setq result presentation)
		   (setq result-translator translator)
		   (setq result-context context)
		   (setq result-size size))))))
     top-record
     input-context
     frame
     window
     x y
     :event event
     :modifier-state modifier-state
     :button button)
    (when result
      (return-from find-innermost-presentation-match
	(values result result-translator result-context)))
    (map-applicable-translators
     #'(lambda (translator presentation context)
	 (return-from find-innermost-presentation-match
	   (values presentation translator context)))
     *null-presentation*
     input-context
     frame
     window
     x y
     :event event
     :modifier-state modifier-state
     :button button))
  nil)

(defun find-innermost-applicable-presentation
    (input-context window x y
     &key (frame *application-frame*)
     (modifier-state (window-modifier-state window))
     event)
  (values (find-innermost-presentation-match input-context
                                             (stream-output-history window)
                                             frame
                                             window
                                             x y
                                             event
                                             modifier-state
					     nil)))

(defun find-innermost-presentation-context
    (input-context window x y
     &key (top-record (stream-output-history window))
     (frame *application-frame*)
     event
     (modifier-state (window-modifier-state window))
     button)
  (find-innermost-presentation-match input-context
				     top-record
				     frame
				     window
				     x y
				     event
				     modifier-state
				     button))

(defun throw-highlighted-presentation (presentation input-context event)
  (let ((x (pointer-event-x event))
	(y (pointer-event-y event))
	(window (event-sheet event)))
    (multiple-value-bind (p translator context)
	(find-innermost-presentation-match input-context
					   presentation
					   *application-frame*
					   (event-sheet event)
					   x y
					   event
					   0
					   nil)
      (when p
	(multiple-value-bind (object ptype options)
	    (call-presentation-translator translator
					  p
					  (input-context-type context)
					  *application-frame*
					  event
					  window
					  x y)
	  (when ptype
	    (funcall (cdr context) object ptype event options)))))))

(defvar *input-context*)

(defun throw-object-ptype (object type
			   &key (input-context *input-context*) sheet)
  "Throw an object and presentation type within input-context without
a presentation"
  (throw-highlighted-presentation
                          (make-instance 'standard-presentation
                                         :object object :type type
					 :single-box t)
			  input-context
                          (make-instance 'pointer-button-press-event
                                         :sheet sheet
                                         :x 0 :y 0
                                         :modifier-state 0
                                         :button +pointer-left-button+)))

(defstruct presentation-translator-menu-item
  translator
  presentation
  context)

(defun call-presentation-menu
    (presentation input-context frame window x y
     &key (for-menu t) label)
  (let (items)
    (map-applicable-translators
     #'(lambda (translator presentation context)
	 (push
          `(,(make-presentation-translator-menu-item :translator translator
                                                     :presentation presentation
                                                     :context context)
             :documentation ,(with-output-to-string (stream)
                               (document-presentation-translator
                                translator
                                presentation
                                input-context
                                frame nil window x y
                                :stream stream)))
          items))
     presentation input-context frame window x y :for-menu for-menu)
    (when items
      (setq items (nreverse items))
      (multiple-value-bind (item object event)
          (menu-choose items
                       :label label
                       :associated-window window
                       :printer #'(lambda (item stream)
                                    (let ((object (first item)))
                                     (document-presentation-translator
                                      (presentation-translator-menu-item-translator object)
                                      (presentation-translator-menu-item-presentation object)
                                      (presentation-translator-menu-item-context object)
                                      frame nil window x y
                                      :stream stream)))
                       :label label
                       :pointer-documentation *pointer-documentation-output*)
        (declare (ignore object))
        (when item
          (multiple-value-bind (object ptype options)
              (call-presentation-translator (presentation-translator-menu-item-translator item)
                                            (presentation-translator-menu-item-presentation item)
                                            (presentation-translator-menu-item-context item)
                                            frame
                                            event
                                            window
                                            x y)
            (when ptype
              (funcall (cdr (presentation-translator-menu-item-context item)) object ptype event options))))))))

#+nil
(defmethod highlight-output-record ((record standard-presentation)
				    stream state)
  (map-over-output-records
   (lambda (child)
     (highlight-output-record child stream state))
   record))

;;; Context-dependent input
;;; An input context is a cons of a presentation type and a continuation to
;;; call to return a presentation to that input context.

(defvar *input-context* nil)

(defun input-context-type (context-entry)
  (car context-entry))

;;; Many presentation functions, internal and external, take an input
;;; context as an argument, but they really only need to look at one
;;; presentation type.
(defun make-fake-input-context (ptype)
  (list (cons (expand-presentation-type-abbreviation ptype)
	      #'(lambda (object type event options)
		  (declare (ignore event options))
		  (error "Fake input context called with object ~S type ~S. ~
                          This shouldn't happen!"
			 object type)))))

(defun input-context-wait-test (stream)
  (let* ((queue (stream-input-buffer stream))
	 (event (event-queue-peek queue)))
    (when event
      (let ((sheet (event-sheet event)))
	(when (and (output-recording-stream-p sheet)
		   (or (typep event 'pointer-event)
		       (typep event 'keyboard-event))
		   (not (gadgetp sheet)))
	  (return-from input-context-wait-test t))))
    nil))

(defun highlight-applicable-presentation (frame stream input-context
					  &optional (prefer-pointer-window t))
  (let* ((queue (stream-input-buffer stream))
	 (event (event-queue-peek queue)))
    (when (and event
	       (or (and (typep event 'pointer-event)
			(or prefer-pointer-window 
			    (eq stream (event-sheet event))))
		   (typep event 'keyboard-event)))
      ;; Stream only needs to see button press events.
      ;; XXX Need to think about this more.  Should any pointer events be
      ;; passed through?  If there's no presentation, maybe?
      (unless (typep event 'keyboard-event)
	(event-queue-read queue))
      (progn
	(frame-input-context-track-pointer frame
					   input-context
					   (event-sheet event)
					   event)
	(when (typep event 'pointer-button-press-event)
	  (funcall *pointer-button-press-handler* stream event)))
      #+nil
      (if (and (typep event 'pointer-motion-event)
	       (pointer-event-button event))
	  (frame-drag frame input-context (event-sheet event) event)
	  ))))

(defun input-context-event-handler (stream)
  (highlight-applicable-presentation *application-frame*
				     stream
				     *input-context*))

(defun input-context-button-press-handler (stream button-event)
  (declare (ignore stream))
  (frame-input-context-button-press-handler *application-frame*
					    (event-sheet button-event)
					    button-event))

(defun highlight-current-presentation (frame input-context)
  (let ((event (synthesize-pointer-motion-event (port-pointer
						 (port
						  *application-frame*)))))
    (when event
      (frame-input-context-track-pointer frame
                                         input-context
                                         (event-sheet event)
                                         event))))

(defmacro with-input-context ((type &key override)
			      (&optional (object-var (gensym))
					 (type-var (gensym))
					 event-var
					 options-var)
			      form
			      &body pointer-cases)
  (let ((vars `(,object-var
		,type-var
		,@(and event-var `(,event-var))
		,@(and options-var `(,options-var))))
	(return-block (gensym "RETURN-BLOCK"))
	(context-block (gensym "CONTEXT-BLOCK")))
    `(block ,return-block
       (multiple-value-bind ,vars
	   (block ,context-block
	     (let ((*input-context*
		    (cons (cons (expand-presentation-type-abbreviation ,type)
                                #'(lambda (object type event options)
				    (return-from ,context-block
				      (values object type event options))))
			  ,(if override nil '*input-context*)))
		   (*pointer-button-press-handler*
		    #'input-context-button-press-handler)
		   (*input-wait-test* #'input-context-wait-test)
		   (*input-wait-handler* #'input-context-event-handler))
	       (return-from ,return-block ,form )))
         (declare (ignorable ,@vars))
	 (highlight-current-presentation *application-frame* *input-context*)
	 (cond ,@(mapcar #'(lambda (pointer-case)
			     (destructuring-bind (case-type &body case-body)
				 pointer-case
			       `((presentation-subtypep ,type-var ',case-type)
				 ,@case-body)))
			 pointer-cases))))))