From: Dennis Dunn
Subject: Fix for shared slot allocation
Date: 
Message-ID: <7C8k9.2360$Ov6.126851@e3500-atl1.usenetserver.com>
Hello again,

This patch is for CMUCL 18d and fixes the shared-slot initializaiton problem
I discussed in an earlier thread.  Thanks to Gerd Moellmann
(··············@t-online.de) for the patch and for allowing me to post the
fix to c.l.l.

To apply the patch, save the patch to a file "shared-slot-patch.lisp" and
then run cmucl 18d.  At the top-level evaluate

(compile-file "shared-slot-patch" :load t)

and then

(save-lisp "lisp.core")

Finally, run your new core with

#lisp -core lisp.core

--dennis

(in-package "PCL")

(defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
  (let* ((initialize-form-list (cons nil nil))
(type (cond ((structure-class-p class)
      'structure)
     ((standard-class-p class)
      'standard)
     ((funcallable-standard-class-p class)
      'funcallable)
     (t (error "error in make-shared-initialize-form-list"))))
(wrapper (class-wrapper class))
(constants (when simple-p
      (make-list (wrapper-no-of-instance-slots wrapper)
:initial-element *slot-unbound*)))
(slots (class-slots class))
(slot-names (mapcar #'slot-definition-name slots))
(slots-key (mapcar (lambda (slot)
      (let ((index most-positive-fixnum))
(dolist (key (slot-definition-initargs slot))
  (let ((pos (position key keys)))
    (when pos (setq index (min index pos)))))
(cons slot index)))
    slots))
(slots (stable-sort slots-key #'< :key #'cdr)))
    (let ((n-popped 0))
      (dolist (slot+index slots)
(let* ((slot (car slot+index))
       (name (slot-definition-name slot))
       (npop (1+ (- (cdr slot+index) n-popped))))
  (unless (eql (cdr slot+index) most-positive-fixnum)
    (let* ((pv-offset (1+ (position name slot-names))))
      (add-forms `(,@(when (plusp npop)
       `((pop-initargs ,(* 2 npop))))
   (instance-set ,pv-offset ,slot))
initialize-form-list))
    (incf n-popped npop)))))
    (dolist (slot+index slots)
      (let* ((slot (car slot+index))
     (name (slot-definition-name slot)))
(when (and (eql (cdr slot+index) most-positive-fixnum)
   (eq (slot-definition-allocation slot) :instance)
   (or (eq si-slot-names t)
       (member name si-slot-names)))
  (let* ((initform (slot-definition-initform slot))
(initfunction (slot-definition-initfunction slot))
(location (unless (eq type 'structure)
     (slot-definition-location slot)))
(pv-offset (1+ (position name slot-names)))
(forms (cond ((null initfunction)
       nil)
      ((constantp initform)
       (let ((value (funcall initfunction)))
(if (and simple-p (integerp location))
     (progn (setf (nth location constants) value)
    nil)
     `((const ,value)
       (instance-set ,pv-offset ,slot)))))
      (t
       `((funcall ,(slot-definition-initfunction slot))
(instance-set ,pv-offset ,slot))))))
    (add-forms `(,@(unless (or simple-p (null forms))
     `((skip-when-instance-boundp ,pv-offset ,slot
,(length forms))))
,@forms)
       initialize-form-list)))))
    (values (car initialize-form-list) constants)))


(defmethod shared-initialize ((instance slot-object) slot-names &rest
initargs)
  (cond ((eq slot-names t)
  (call-initialize-function
   (initialize-info-shared-initialize-t-function
    (initialize-info (class-of instance) initargs))
   instance initargs))
 ((null slot-names)
  (call-initialize-function
   (initialize-info-shared-initialize-nil-function
    (initialize-info (class-of instance) initargs))
   instance initargs))
 (t
  (flet ((initialize-slot-from-initarg (class instance slotd)
    (let ((slot-initargs (slot-definition-initargs slotd)))
      (doplist (initarg value) initargs
        (when (memq initarg slot-initargs)
   (setf (slot-value-using-class class instance slotd)
         value)
   (return t)))))
  (initialize-slot-from-initfunction (class instance slotd)
    (unless (or (slot-boundp-using-class class instance slotd)
         (null (slot-definition-initfunction slotd)))
      (setf (slot-value-using-class class instance slotd)
     (funcall (slot-definition-initfunction slotd)))))
  (class-slot-p (slotd)
    ;; Note: contrary to AMOP, SLOT-DEFINITION-ALLOCATION
    ;; returns a class and not :CLASS for class slots.
    (classp (slot-definition-allocation slotd))))
    (loop with class = (class-of instance)
   for slotd in (class-slots class)
   unless (or (class-slot-p slotd)
       (initialize-slot-from-initarg class instance slotd))
     when (memq (slot-definition-name slotd) slot-names) do
       (initialize-slot-from-initfunction class instance slotd))
  instance))))