From 61d014339f7775dddff12f703782275defd4d96c Mon Sep 17 00:00:00 2001 From: jgarcia Date: Tue, 18 Apr 2006 19:27:47 +0000 Subject: [PATCH] Fixed the transformation of slot definitions from the list form to the final standard-slot-definition instances. --- src/clos/boot.lsp | 4 +-- src/clos/fixup.lsp | 63 +++++++++++++++++++++++-------------------- src/clos/slot.lsp | 7 ++--- src/clos/standard.lsp | 5 ++-- 4 files changed, 43 insertions(+), 36 deletions(-) diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index cc41de073..b445a9564 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -63,7 +63,7 @@ (dolist (slotd class-slots) (setf (slot-definition-location slotd) (slot-definition-location (gethash (slot-definition-name slotd) hash-table)))) - (setf (class-slots the-class) class-slots + (setf (class-slots the-class) (copy-list class-slots) (slot-table the-class) hash-table (class-direct-slots the-class) class-slots (class-slots standard-class) standard-slots @@ -163,7 +163,7 @@ ;; shared slot (car location)) (t - (error "Effective slot definition lacks a valid location:~%~A" + (error "Effective slot definition lacks a valid location:~%~A" slotd))))) (defun standard-instance-set (val instance slotd) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index b64ef8755..39d25de0c 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -25,38 +25,43 @@ |# (defun convert-one-class (class) - (dolist (l (class-direct-slots class)) - (let ((x (first l))) - (when (consp x) - (setf (first l) - (apply #'make-instance 'standard-direct-slot-definition - (slot-definition-to-list x)))))) - (dolist (l (class-slots class)) - (let ((x (first l))) - (when (consp x) - (setf (first l) - (apply #'make-instance 'standard-effective-slot-definition - (slot-definition-to-list x)))))) + (let* ((direct-slots (class-direct-slots class)) + (effective-slots (class-slots class)) + (new-direct-slots + (loop for x in direct-slots + collect (if (consp x) + (apply #'make-instance 'standard-direct-slot-definition + (slot-definition-to-list x)) + x))) + (new-effective-slots + (loop for x in effective-slots + collect (if (consp x) + (apply #'make-instance 'standard-effective-slot-definition + (slot-definition-to-list x)) + x)))) + (map-into direct-slots #'identity new-direct-slots) + (map-into effective-slots #'identity new-effective-slots) + (when (typep class 'standard-class) + (std-create-slots-table class))) (mapc #'convert-one-class (class-direct-subclasses class))) -(progn - (eval `(defclass slot-definition () - ,(mapcar #'(lambda (x) (butlast x 2)) +slot-definition-slots+))) - (defclass standard-slot-definition (slot-definition) ()) - (defclass direct-slot-definition (slot-definition) ()) - (defclass effective-slot-definition (slot-definition) ()) - (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) ()) - (defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) ()) - #| - (convert-one-class (find-class 'slot-definition)) - (convert-one-class (find-class 'standard-class)) - (convert-one-class (find-class 't)) - |# +;;; +;;; We cannot redefine the class for slot definitions because this +;;; causes an infinite loop. Hence, we avoid evaluating the following +;;; forms at compile time. +;;; +(eval-when (:load-toplevel :execute) + (eval + `(progn + (defclass slot-definition () + ,(mapcar #'(lambda (x) (butlast x 2)) +slot-definition-slots+)) + (defclass standard-slot-definition (slot-definition) ()) + (defclass direct-slot-definition (slot-definition) ()) + (defclass effective-slot-definition (slot-definition) ()) + (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) ()) + (defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) ()))) (make-instances-obsolete (find-class 't)) - (convert-one-class (find-class 't)) - #+nil - (eval (print `(defclass slot-definition () - ,(mapcar #'(lambda (x) (butlast x 2)) +slot-definition-slots+))))) + (convert-one-class (find-class 't))) ;;; ---------------------------------------------------------------------- ;;; Fixup diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index bf56fd44f..f57cd3aee 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -38,7 +38,7 @@ (readers :initarg :readers :initform nil :accessor slot-definition-readers) (writers :initarg :writers :initform nil :accessor slot-definition-writers) (documentation :initarg :documentation :initform nil :accessor slot-definition-documentation) - (location :initarg :documentation :initform nil :accessor slot-definition-location) + (location :initarg :location :initform nil :accessor slot-definition-location) )) (defun make-simple-slotd (&key name initform initfunction type allocation initargs readers writers documentation location) @@ -57,9 +57,10 @@ (position i) (f (nth i accessors))) (setf (fdefinition f) - #'(lambda (x) (if (consp x) (nth position x) (slot-value x name)))) + #'(lambda (x) + (if (consp x) (nth position x) (si:instance-ref x position)))) (setf (fdefinition `(setf ,f)) - #'(lambda (v x) (if (consp x) (setf (nth position x) v) (setf (slot-value x name) v))))))) + #'(lambda (v x) (if (consp x) (setf (nth position x) v) (si:instance-set x position v))))))) ;;; ---------------------------------------------------------------------- ;;; diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 8a1b6332f..56b055667 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -270,7 +270,8 @@ because it contains a reference to the undefined class~% ~A" :initargs (slot-definition-initargs slotd) :readers (slot-definition-readers slotd) :writers (slot-definition-writers slotd) - :documentation (slot-definition-documentation slotd))) + :documentation (slot-definition-documentation slotd) + :location (slot-definition-location slotd))) (defmethod compute-effective-slot-definition ((class class) name direct-slots) (flet ((direct-to-effective (old-slot) @@ -420,7 +421,7 @@ because it contains a reference to the undefined class~% ~A" (install-method fname nil `(,standard-class) '(self) nil nil reader)) (dolist (fname (slot-definition-writers slotd)) - (install-method fname nil `(nil ,standard-class) '(value self) + (install-method fname nil `(,(find-class t) ,standard-class) '(value self) nil nil setter))))) ;;; ======================================================================