mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-16 14:21:48 -08:00
Slot definitions are now always instances, not lists
This commit is contained in:
Juan Jose Garcia Ripoll
parent
519e6dcfbe
commit
5be366b8e0
7 changed files with 153 additions and 142 deletions
|
|
@ -15,38 +15,6 @@
|
|||
(defconstant +builtin-classes-pre-array+
|
||||
(make-array (1+ #.(length +builtin-classes-list+))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; The following macro is also used at bootstap for instantiating
|
||||
;;; a class based only on the s-form description.
|
||||
;;;
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defmacro with-early-make-instance (slots (object class &rest key-value-pairs)
|
||||
&rest body)
|
||||
(when (symbolp slots)
|
||||
(setf slots (symbol-value slots)))
|
||||
`(let* ((%class ,class)
|
||||
(,object (si::allocate-raw-instance nil %class
|
||||
,(length slots))))
|
||||
(declare (type standard-object ,object))
|
||||
,@(flet ((initializerp (name list)
|
||||
(not (eq (getf list name 'wrong) 'wrong))))
|
||||
(loop for (name . slotd) in slots
|
||||
for initarg = (getf slotd :initarg)
|
||||
for initform = (getf slotd :initform (si::unbound))
|
||||
for initvalue = (getf key-value-pairs initarg)
|
||||
for index from 0
|
||||
do (cond ((and initarg (initializerp initarg key-value-pairs))
|
||||
(setf initform (getf key-value-pairs initarg)))
|
||||
((initializerp name key-value-pairs)
|
||||
(setf initform (getf key-value-pairs name))))
|
||||
when (si:sl-boundp initform)
|
||||
collect `(si::instance-set ,object ,index ,initform)))
|
||||
(when %class
|
||||
(si::instance-sig-set ,object))
|
||||
(with-early-accessors (,slots)
|
||||
,@body))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Building the classes T, CLASS, STANDARD-OBJECT and STANDARD-CLASS.
|
||||
;;;
|
||||
|
|
@ -96,28 +64,31 @@
|
|||
do (remf (cdr j) :accessor)
|
||||
collect j))
|
||||
|
||||
(defun canonical-slots (slots)
|
||||
(declare (optimize speed (safety 0)))
|
||||
(loop for s in (parse-slots slots)
|
||||
collect (canonical-slot-to-direct-slot nil s)))
|
||||
|
||||
(defun add-slots (class slots)
|
||||
(declare (si::c-local)
|
||||
(optimize speed (safety 0)))
|
||||
;; It does not matter that we pass NIL instead of a class object,
|
||||
;; because CANONICAL-SLOT-TO-DIRECT-SLOT will make simple slots.
|
||||
(with-early-accessors (+standard-class-slots+)
|
||||
(loop with all-slots = (canonical-slots slots)
|
||||
with table = (make-hash-table :size (if all-slots 24 0))
|
||||
for i from 0
|
||||
for s in all-slots
|
||||
for name = (slot-definition-name s)
|
||||
do (setf (slot-definition-location s) i
|
||||
(gethash name table) s)
|
||||
finally (setf (class-slots class) all-slots
|
||||
(class-size class) (length all-slots)
|
||||
(slot-table class) table
|
||||
(class-direct-slots class) (copy-list all-slots)))))
|
||||
(with-early-accessors (+standard-class-slots+
|
||||
+slot-definition-slots+)
|
||||
(let* ((table (make-hash-table :size (if slots 24 0)))
|
||||
(slots (parse-slots slots))
|
||||
(direct-slots (loop for slotd in slots
|
||||
collect (apply #'make-simple-slotd
|
||||
(find-class 'standard-direct-slot-definition)
|
||||
slotd)))
|
||||
(effective-slots (loop for i from 0
|
||||
for slotd in slots
|
||||
for s = (apply #'make-simple-slotd
|
||||
(find-class 'standard-effective-slot-definition)
|
||||
slotd)
|
||||
do (setf (slot-definition-location s) i
|
||||
(gethash (getf slotd :name) table) s)
|
||||
collect s)))
|
||||
(setf (class-slots class) effective-slots
|
||||
(class-direct-slots class) direct-slots
|
||||
(class-size class) (length slots)
|
||||
(slot-table class) table))))
|
||||
|
||||
;; 1) Create the classes
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -27,45 +27,6 @@
|
|||
(defclass standard-effective-slot-definition (standard-slot-definition direct-slot-definition))
|
||||
|#
|
||||
|
||||
(defun convert-one-class (class)
|
||||
(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-plist 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-plist x))
|
||||
x))))
|
||||
(map-into direct-slots #'identity new-direct-slots)
|
||||
(map-into effective-slots #'identity new-effective-slots)
|
||||
(when (typep class 'std-class)
|
||||
(std-create-slots-table class)))
|
||||
(mapc #'convert-one-class (class-direct-subclasses class)))
|
||||
|
||||
;;;
|
||||
;;; 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 (metaobject)
|
||||
,(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)))
|
||||
|
||||
(defmethod reader-method-class ((class std-class)
|
||||
(direct-slot direct-slot-definition)
|
||||
&rest initargs)
|
||||
|
|
@ -240,7 +201,9 @@ their lambda lists ~A and ~A are not congruent."
|
|||
qualifiers specializers &optional error))
|
||||
|
||||
(labels ((create-accessors (class)
|
||||
(when (typep class 'standard-class)
|
||||
(when (and (typep class 'standard-class)
|
||||
(not (member (find-class 'slot-definition)
|
||||
(class-precedence-list class))))
|
||||
(std-class-generate-accessors class))
|
||||
(loop for i in (class-direct-subclasses class)
|
||||
do (create-accessors i))))
|
||||
|
|
|
|||
|
|
@ -152,6 +152,24 @@
|
|||
;; FIXME! Should be a :reader
|
||||
:accessor accessor-method-slot-definition)))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; SLOT-DEFINITION
|
||||
;;;
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defconstant +slot-definition-slots+
|
||||
'((name :initarg :name :initform nil :accessor slot-definition-name)
|
||||
(initform :initarg :initform :initform +initform-unsupplied+ :accessor slot-definition-initform)
|
||||
(initfunction :initarg :initfunction :initform nil :accessor slot-definition-initfunction)
|
||||
(declared-type :initarg :type :initform t :accessor slot-definition-type)
|
||||
(allocation :initarg :allocation :initform :instance :accessor slot-definition-allocation)
|
||||
(initargs :initarg :initargs :initform nil :accessor slot-definition-initargs)
|
||||
(readers :initarg :readers :initform nil :accessor slot-definition-readers)
|
||||
(writers :initarg :writers :initform nil :accessor slot-definition-writers)
|
||||
(docstring :initarg :documentation :initform nil :accessor slot-definition-documentation)
|
||||
(location :initarg :location :initform nil :accessor slot-definition-location)
|
||||
)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
;;
|
||||
|
|
@ -240,15 +258,40 @@
|
|||
;;;
|
||||
(eval-when (eval)
|
||||
(defconstant +class-hierarchy+
|
||||
`((standard-class
|
||||
`((standard-class)
|
||||
(standard-effective-slot-definition)
|
||||
(standard-direct-slot-definition)
|
||||
(standard-class
|
||||
:metaclass nil ; Special-cased in boot.lsp
|
||||
:direct-slots #1=#.+standard-class-slots+)
|
||||
:direct-slots #.+standard-class-slots+)
|
||||
(standard-direct-slot-definition
|
||||
:direct-slots #3=#.+slot-definition-slots+)
|
||||
(standard-effective-slot-definition
|
||||
:direct-slots #3#)
|
||||
(t
|
||||
:index 0)
|
||||
(standard-object
|
||||
:direct-superclasses (t))
|
||||
(metaobject
|
||||
:direct-superclasses (standard-object))
|
||||
(slot-definition
|
||||
:direct-superclasses (metaobject)
|
||||
:direct-slots #3#)
|
||||
(standard-slot-definition
|
||||
:direct-superclasses (slot-definition)
|
||||
:direct-slots #3#)
|
||||
(direct-slot-definition
|
||||
:direct-superclasses (slot-definition)
|
||||
:direct-slots #3#)
|
||||
(effective-slot-definition
|
||||
:direct-superclasses (slot-definition)
|
||||
:direct-slots #3#)
|
||||
(standard-direct-slot-definition
|
||||
:direct-superclasses (standard-slot-definition direct-slot-definition)
|
||||
:direct-slots #3#)
|
||||
(standard-effective-slot-definition
|
||||
:direct-superclasses (standard-slot-definition effective-slot-definition)
|
||||
:direct-slots #3#)
|
||||
(method-combination
|
||||
:direct-superclasses (metaobject)
|
||||
:direct-slots #.+method-combination-slots+)
|
||||
|
|
@ -266,7 +309,7 @@
|
|||
:direct-slots #.+class-slots+)
|
||||
(built-in-class
|
||||
:direct-superclasses (class)
|
||||
:direct-slots #1#)
|
||||
:direct-slots #1=#.+standard-class-slots+)
|
||||
(std-class
|
||||
:direct-superclasses (class)
|
||||
:direct-slots #1#)
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
|
||||
(defvar +clos-module-files+
|
||||
'("src:clos;package.lsp"
|
||||
"src:clos;slot.lsp"
|
||||
"src:clos;cpl.lsp"
|
||||
"src:clos;std-slot-value.lsp"
|
||||
"src:clos;slot.lsp"
|
||||
"src:clos;boot.lsp"
|
||||
"src:clos;kernel.lsp"
|
||||
"src:clos;method.lsp"
|
||||
|
|
|
|||
|
|
@ -17,39 +17,27 @@
|
|||
;;; ----------------------------------------------------------------------
|
||||
;;; SLOT descriptors
|
||||
;;;
|
||||
;;; We need slot definition objects both during bootstrap and also at
|
||||
;;; runtime. Here we set up a dual definition: if the class
|
||||
;;; SLOT-DEFINITION has been defined, we use it; otherwise we work
|
||||
;;; with slot definitions as by the effective structure
|
||||
;;;
|
||||
;;; (defstruct (slot-definition (:type list))
|
||||
;;; name initform initfunction type allocation initargs
|
||||
;;; readers writers documentation)
|
||||
;;;
|
||||
;;; However, this structure is not defined explicitely, to save
|
||||
;;; memory. We rather create a constructor
|
||||
;;; CANONICAL-SLOT-TO-DIRECT-SLOT and several accessors (closures)
|
||||
;;; down there.
|
||||
|
||||
(defconstant +slot-definition-slots+
|
||||
'((name :initarg :name :initform nil :accessor slot-definition-name)
|
||||
(initform :initarg :initform :initform #.+initform-unsupplied+ :accessor slot-definition-initform)
|
||||
(initfunction :initarg :initfunction :initform nil :accessor slot-definition-initfunction)
|
||||
(declared-type :initarg :type :initform t :accessor slot-definition-type)
|
||||
(allocation :initarg :allocation :initform :instance :accessor slot-definition-allocation)
|
||||
(initargs :initarg :initargs :initform nil :accessor slot-definition-initargs)
|
||||
(readers :initarg :readers :initform nil :accessor slot-definition-readers)
|
||||
(writers :initarg :writers :initform nil :accessor slot-definition-writers)
|
||||
(docstring :initarg :documentation :initform nil :accessor slot-definition-documentation)
|
||||
(location :initarg :location :initform nil :accessor slot-definition-location)
|
||||
))
|
||||
|
||||
(defun make-simple-slotd (&key name (initform +initform-unsupplied+) initfunction
|
||||
(defun make-simple-slotd (class
|
||||
&key name (initform +initform-unsupplied+) initfunction
|
||||
(type 'T) (allocation :instance)
|
||||
initargs readers writers documentation location)
|
||||
(when (listp initfunction)
|
||||
(setf initfunction (eval initfunction)))
|
||||
(list name initform initfunction type allocation initargs readers writers documentation location))
|
||||
(when (and (eq allocation :class)
|
||||
(functionp initfunction))
|
||||
(setf initfunction (constantly (funcall initfunction))))
|
||||
(with-early-make-instance +slot-definition-slots+
|
||||
(slotd class
|
||||
:name name
|
||||
:initform initform
|
||||
:initfunction (if (listp initfunction) (eval initfunction) initfunction)
|
||||
:type type
|
||||
:allocation allocation
|
||||
:initargs initargs
|
||||
:readers readers
|
||||
:writers writers
|
||||
:documentation documentation
|
||||
:location location)
|
||||
slotd))
|
||||
|
||||
(defun freeze-class-slot-initfunction (slotd)
|
||||
(when (eq (getf slotd :allocation) :class)
|
||||
|
|
@ -64,21 +52,31 @@
|
|||
(setf slotd (freeze-class-slot-initfunction slotd))
|
||||
(if (find-class 'slot-definition nil)
|
||||
(apply #'make-instance
|
||||
(apply #'direct-slot-definition-class class slotd)
|
||||
(apply #'direct-slot-definition-class class
|
||||
(freeze-class-slot-initfunction slotd))
|
||||
slotd)
|
||||
(apply #'make-simple-slotd slotd)))
|
||||
(apply #'make-simple-slotd class slotd)))
|
||||
|
||||
(let ((accessors (loop for i in +slot-definition-slots+
|
||||
collect (first (last i)))))
|
||||
(dotimes (i (length accessors))
|
||||
(let ((name (first (nth i +slot-definition-slots+)))
|
||||
(position i)
|
||||
(f (nth i accessors)))
|
||||
(setf (fdefinition f)
|
||||
#'(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) (si:instance-set x position v)))))))
|
||||
(defun direct-slot-to-canonical-slot (slotd)
|
||||
(list . #.(loop for (name . rest) in +slot-definition-slots+
|
||||
collect (getf rest :initarg)
|
||||
collect `(,(getf rest :accessor) slotd))))
|
||||
|
||||
(loop with all-slots = '#.+slot-definition-slots+
|
||||
for slotd in all-slots
|
||||
for i from 0
|
||||
for fname = (getf (rest slotd) :accessor)
|
||||
do (let ((name (first slotd)))
|
||||
(setf (fdefinition fname)
|
||||
#'(lambda (x)
|
||||
(if (consp x)
|
||||
(nth position x)
|
||||
(slot-value x name)))
|
||||
(fdefinition `(setf ,fname))
|
||||
#'(lambda (v x)
|
||||
(if (consp x)
|
||||
(setf (nth position x) v)
|
||||
(setf (slot-value x name) v))))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -331,9 +331,7 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(loop for name in free-slots
|
||||
with direct-slots = (class-direct-slots class)
|
||||
do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name))
|
||||
(def (loop for (name . rest) in +slot-definition-slots+
|
||||
nconc (list (getf rest :initarg)
|
||||
(funcall (getf rest :accessor) effective-slotd)))))
|
||||
(def (direct-slot-to-canonical-slot effective-slotd)))
|
||||
(push (apply #'make-instance (direct-slot-definition-class class def)
|
||||
def)
|
||||
direct-slots))
|
||||
|
|
|
|||
|
|
@ -70,6 +70,37 @@
|
|||
collect `(,accessor (object) `(si::instance-ref ,object ,,index))))
|
||||
,@body)))
|
||||
|
||||
;;;
|
||||
;;; The following macro is also used at bootstap for instantiating
|
||||
;;; a class based only on the s-form description.
|
||||
;;;
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defmacro with-early-make-instance (slots (object class &rest key-value-pairs)
|
||||
&rest body)
|
||||
(when (symbolp slots)
|
||||
(setf slots (symbol-value slots)))
|
||||
`(let* ((%class ,class)
|
||||
(,object (si::allocate-raw-instance nil %class
|
||||
,(length slots))))
|
||||
(declare (type standard-object ,object))
|
||||
,@(flet ((initializerp (name list)
|
||||
(not (eq (getf list name 'wrong) 'wrong))))
|
||||
(loop for (name . slotd) in slots
|
||||
for initarg = (getf slotd :initarg)
|
||||
for initform = (getf slotd :initform (si::unbound))
|
||||
for initvalue = (getf key-value-pairs initarg)
|
||||
for index from 0
|
||||
do (cond ((and initarg (initializerp initarg key-value-pairs))
|
||||
(setf initform (getf key-value-pairs initarg)))
|
||||
((initializerp name key-value-pairs)
|
||||
(setf initform (getf key-value-pairs name))))
|
||||
when (si:sl-boundp initform)
|
||||
collect `(si::instance-set ,object ,index ,initform)))
|
||||
(when %class
|
||||
(si::instance-sig-set ,object))
|
||||
(with-early-accessors (,slots)
|
||||
,@body))))
|
||||
|
||||
;;;
|
||||
;;; ECL classes store slots in a hash table for faster access. The
|
||||
;;; following functions create the cache and allow us to locate the
|
||||
|
|
@ -109,6 +140,10 @@
|
|||
(unless (eq s (class-slots (si::instance-class i)))
|
||||
(update-instance i)))))))
|
||||
|
||||
(defun update-instance (x)
|
||||
(si::instance-sig-set x))
|
||||
(declaim (notinline update-instance))
|
||||
|
||||
;;;
|
||||
;;; STANDARD-CLASS INTERFACE
|
||||
;;;
|
||||
|
|
@ -116,7 +151,8 @@
|
|||
;;;
|
||||
|
||||
(defun standard-instance-get (instance slotd)
|
||||
(with-early-accessors (+standard-class-slots+)
|
||||
(with-early-accessors (+standard-class-slots+
|
||||
+slot-definition-slots+)
|
||||
(ensure-up-to-date-instance instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(location (slot-definition-location slotd)))
|
||||
|
|
@ -130,7 +166,8 @@
|
|||
(invalid-slot-definition instance slotd))))))
|
||||
|
||||
(defun standard-instance-set (val instance slotd)
|
||||
(with-early-accessors (+standard-class-slots+)
|
||||
(with-early-accessors (+standard-class-slots+
|
||||
+slot-definition-slots+)
|
||||
(ensure-up-to-date-instance instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(location (slot-definition-location slotd)))
|
||||
|
|
@ -148,7 +185,8 @@
|
|||
(let* ((class (class-of self)))
|
||||
(if (or (eq (si:instance-class class) +the-standard-class+)
|
||||
(eq (si:instance-class class) +the-funcallable-standard-class+))
|
||||
(with-early-accessors (+standard-class-slots+)
|
||||
(with-early-accessors (+standard-class-slots+
|
||||
+slot-definition-slots+)
|
||||
(let ((slotd (gethash slot-name (slot-table class) nil)))
|
||||
(if slotd
|
||||
(let ((value (standard-instance-get self slotd)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue