mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 05:43:19 -08:00
Code Issues Projects Releases Packages Wiki Activity

Fixed the transformation of slot definitions from the list form to the final standard-slot-definition instances.

Browse source
This commit is contained in:
jgarcia 2006-04-18 19:27:47 +00:00
parent a952b2c796
commit 61d014339f
4 changed files with 43 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/clos/boot.lsp
View file

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

63
src/clos/fixup.lsp
View file

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

7
src/clos/slot.lsp
View file

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

5
src/clos/standard.lsp
View file

@ -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)))))
;;; ======================================================================