🚀 go-pugleaf

My message outlining a new instance structure protocol has (at least)
three significant brainos.  They make it much harder to understand what
is being proposed.  (Thanks to Dan Friedman for pointing these out.)

(1) The methods on compute-getter-and-setter should accept four
arguments, not three.  This missing one is a list of all the eslotds.

(2) The setter for :instance allocation slots should accept a new value
argument and then return it.

(3) The dynamic slots example is written using an older version of the
protocol.  It needs a lot of changes.

Here is all the code, with these amendments:



(defmethod finalize-inheritance ((class standard-class))
  (setf (slot-value class 'cpl)   (compute-class-precedence-list class))
  (setf (slot-value class 'slots) (compute-slots class))
  ;
  ; This is the new part.
  ;
  ; Each of the eslotds is asked how it wants to be read and set.
  ; As part of answering that, it can request that it be given
  ; one field in the instance, to store whatever it wants.  By
  ; keeping track of how many fields are requested, we know how
  ; big to make the instance.  More on getters and setters in
  ; a moment.
  ;
  (let* ((nfields 0)
         (field-allocator #'(lambda () (prog1 nfields (incf nfields))))
		 (eslotds (class-slots class)))
    (setf (slot-value class 'getters-n-setters)
	  (mapcar #'(lambda (eslotd)
		      (compute-getter-and-setter class
						 eslotd
						 eslotds
						 field-allocator))
		  eslotds))
    (setf (slot-value class 'nfields) nfields))
  ;
  ; end of new part
  ;	
  (setf (slot-value class 'default-initargs)
	(compute-default-initargs class)))

(defmethod allocate-instance ((class standard-class))
  (%%allocate-std-instance (slot-value class 'nfields)))


(defmethod compute-getter-and-setter ((class standard-class)
                                      (eslotd standard-effective-slotd)
                                      eslotds
				      field-allocator)
  (ecase (slotd-allocation eslotd)
    (:instance (list eslotd
		     (funcall field-allocator)
		     #'(lambda (x) x)
		     #'(lambda (x new) new)))
    (:class    (let ((cell (cons ..put-initial-value-here.. nil)))
		 (list eslotd
		       nil
		       #'(lambda (ignore) (car cell))
		       #'(lambda (ignore new) (rplaca cell new)))))))



(defun slot-value (object slot-name)
  (let* ((class (class-of object))
	 (eslotd  (find slot-name (class-slots class) :key #'slotd-name)))
    (destructuring-bind (field getter setter)
	(cdr (assoc eslotd (slot-value class 'getters-n-setters)))
      (funcall getter (and field (%%get-field object field))))))
	  
(defun (setf slot-value) (new object slot-name)
  (let* ((class (class-of object))
	 (eslotd  (find slot-name (class-slots class) :key #'slotd-name)))
    (destructuring-bind (field getter setter)
	(cdr (assoc eslotd (slot-value class 'getters-n-setters)))
      (if field
	  (%%set-field object
		       field
		       (funcall setter (%%get-field object field) new))
	  (funcall setter nil new)))))



(defclass dynamic-class (standard-class)
     ((dynamic-slots-field :initform nil)))
  
(defmethod compute-getter-and-setter ((class dynamic-class)
                                      eslotd
                                      eslotds
				      field-allocator)
  (let ((name (slot-definition-name eslotd))
        (allocation (slot-definition-allocation eslotd)))
    (if (not (eq allocation ':dynamic))
        (call-next-method)
	(list (or (slot-value class 'dynamic-slots-field)
                  (setf (slot-value class 'dynamic-slots-field)
                        (funcall field-allocator)))
              #'(lambda (alist)
		  (cdr (assq name alist)))
	      #'(lambda (alist new)
		  (let ((entry (assq name alist)))
		    (cond (entry (rplacd entry new) alist)
			  (t (cons (cons name new) alist)))))))))