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))))