new new initialization protocol blues

[Gregor.pa@Xerox.COM]

Here is another example of a fully procedural initialization protocol.
This message also includes an example of using that protocol to solve
the x-y-rho-theta problem.

In this protocol, make-instance, compute-initargs,
class-default-initargs and class-legal-initargs are documented generic
functions.

The method for make-instance on standard-class is documented to call
compute-initargs and allocate-instance.  The method for
allocate-instance on standard-class is documented to allocate storage
and evluate and store all the initforms.  The method for
compute-initargs on object is documented to call class-default-initargs
and class-legal-initargs and do the kind of defaulting we have all come
to expect.

Many users will just want to define methods on class-default-initargs
and class-legal-initargs.  Users trying to deal with problems like the
x-y-rho-theta problem will usually have to define methods on
compute-initargs as well.

(defmethod make-instance ((class symbol) &rest supplied-initargs)
  (apply #'make-instance (class-named symbol) supplied-initargs))

(defmethod make-instance ((class standard-class) &rest
supplied-initargs)
  (let* ((proto (class-prototype class))
	 (total-initargs (compute-initargs proto supplied-initargs))
	 (instance (apply #'allocate-instance class total-initargs)))
    (apply #'initialize-instance instance total-initargs)
    instance))

(defmethod compute-initargs ((object object) supplied-initargs)
  (let* ((default (class-default-initargs object))
	 (legal (class-legal-initargs object))
	 (total supplied-initargs)
	 (magic-value (list nil)))
    (do ((prop default (cddr prop))
	 (val (cdr default) (cddr val)))
	((null prop))
      (when (eq (getf total prop magic-value) magic-value)
	(push (eval val) total)
	(push prop total)))
    (do ((prop total (cddr prop)))
	((null prop))
      (unless (member prop legal)
	(error "~S is not a legal initarg for the class ~S"
	       prop
	       (class-of object))))
    total))

(defgeneric-options class-legal-initargs (class)
  (:method-comination-type append))

(defmethod class-legal-initargs ((class object)) '(:allow-other-keys))

(defgeneric-options class-default-initargs (class)
  (:method-combination-type append))

(defmethod class-default-initargs ((class object)) ())


;;;
;;; Here is an example of all this in use to solve the notorious
;;; x-y-rho-theta problem.
;;; We define a class named position, which can be mixed into
;;; a class that implements either x-y-position primitives or
;;; rho-theta-position primitives.  This class takes care of providing
;;; the other set of primitives, and more importantly takes care of
;;; handling the :x :y :rho :theta defaulting properly.
;;; 
(defclass position () ())

(defmethod class-legal-initargs ((pos position))
  '(:rho :theta :x :y))

(defmethod class-default-initargs ((pos position))
  '((:x 0) (:y 0) (:rho 0) (:theta 0)))

(defmethod compute-initargs ((pos position) supplied)
  (let ((x-p (memq ':x supplied))
	(y-p (memq ':y supplied))
	(r-p (memq ':rho supplied))
	(t-p (memq ':theta supplied))
	(defaults (class-default-initargs class)))
    (when (and (or x-p y-p) (or r-p t-p))
      (error "make up your mind loser"))
    (cond ((and x-p y-p))
	  ((and r-p t-p))
	  (x-p
	   (setf (getf supplied :y)
		 (eval-default-initarg (getf defaults :y))))
	  (y-p
	   (setf (getf supplied :x)
		 (eval-default-initarg (getf defaults :x))))
	  (r-p
	   (setf (getf supplied :theta)
		 (eval-default-initarg (getf defaults :theta))))
	  (t-p
	   (setf (getf supplied :rho)
		 (eval-default-initarg (getf defaults :rho)))))
    (call-next-method pos supplied)))

(defmethod x-position ((p position))
  (convert-rho-theta-to-x (rho-position p)
			  (theta-position p)))

(defmethod y-position ((p position))
  (convert-rho-theta-to-y (rho-position p)
			  (theta-position p)))

(defmethod rho-position ((p position))
  (convert-x-y-to-rho (x-position p)
		      (y-position p)))

(defmethod theta-position ((p position))
  (convert-x-y-to-theta (x-position p)
			(y-position p)))



(defclass x-y-position (position) (x y))

(defmethod initialize-instance :after
	   ((pos x-y-position) &key x y &allow-other-keys)
  (setf (slot-value pos 'x) x
	(slot-value pos 'y) y))
    


(defclass rho-theta-position (position) (rho theta))

(defmethod initialize-instance :after
	   ((pos rho-theta-position) &key rho theta &allow-other-keys)
  (setf (slot-value pos 'rho) rho
	(slot-value pos 'theta) theta))