From: Jon L White

Subject: Re: defclass slot with method-combination?

Date: 1998-9-4 12:32

re: It's a pitty that we can't develop such things portable from scratch 
    as it's not yet standardized.

It's not quite as bad as it seems.  All of Harlequin's current Common 
Lisp products admit a very similar protocol.

Back as early as 1989, Liquid Common Lisp  (formerly "Lucid Common Lisp") 
had a MOP capable of doing your :INITFORM task, but it wasn't "standardized";
so in 1992, in an effort to be compliant to the AMOP de facto standard  
("The Art of the Metaobject Protocol"), it was changed accordingly.

Here is how it is coded for Harlequin's Lisps to get the desired results, 
with additional comments by me showing the differences from Heiko's code.



(defclass user-class (standard-class) ())

;;; ###### JonL: AMOP requires that sub-Metaclasses must defaultly be 
;;;   assumed to be NOT of a compatible representation; thus when 
;;;   compatibility is assured, the class designer has to put the 
;;;   following sort of method on VALIDATE-SUPERCLASS.
(defmethod validate-superclass ((class user-class) (super standard-class))
  t)


(defmethod clos:compute-effective-slot-definition
    ((the-class user-class) 
      ;; ###### JonL: There is no SLOT-NAME argument in AMOP's specification.
      #-Liquid slot-name 
     ;; The order of the direct slots in direct-slot-definitions may
     ;; be reversed in other LISPs (this is code written & tested with
     ;; ACL 4.3):
     direct-slot-definitions
     )
  #-Liquid
  (declare (ignore slot-name))
  (let ((slot-definition (call-next-method))
	(new-initform nil))
    ;; ###### JonL: LCL's caller of this function, COMPUTE-SLOTS,  produces 
    ;;   one entry for every class in the Class-Precedence-List (in CPL order)
    ;;   so that some entries will be NIL instead of a slot-definition object;
    ;;   hence the NOT NULL test in the loop below.  I don't think this is part
    ;;   of the standard, but was probably considered helpful for coordinating
    ;;   fixed-slot-index layout schemes.
    (loop with initform
	for slot in direct-slot-definitions
	when (and (not (null slot))
		  (setq initform (clos:slot-definition-initform slot))
		  (stringp initform))
	do
	  ;; Collecting the result string could be done perhaps more
	  ;; elegant:
	  (setf new-initform (if new-initform
				 (concatenate 'string initform " "
					      new-initform)
			       initform)))
    (when new-initform
      ;; Since at (call-next-method) both the initform and
      ;; initfunction of the effective-slot had been set, both must be
      ;; changed here, too:
      (setf (slot-value slot-definition 'clos::initform) new-initform)
      (setf (slot-value slot-definition 'clos::initfunction)
	(constantly new-initform)))
    slot-definition))

(defclass super ()
  ((f :accessor f :initform "head"))
  (:metaclass user-class))

(defclass sub (super)
  ((f :accessor f :initform "tail"))
  (:metaclass user-class))

(f (make-instance 'sub))





-- JonL --