From 5be366b8e06378b562c77a0bedf0ea68aadaf35e Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 7 Oct 2012 20:25:48 +0200 Subject: [PATCH] Slot definitions are now always instances, not lists --- src/clos/boot.lsp | 69 +++++++++--------------------- src/clos/fixup.lsp | 43 ++----------------- src/clos/hierarchy.lsp | 49 ++++++++++++++++++++-- src/clos/load.lsp.in | 2 +- src/clos/slot.lsp | 84 ++++++++++++++++++------------------- src/clos/standard.lsp | 4 +- src/clos/std-slot-value.lsp | 44 +++++++++++++++++-- 7 files changed, 153 insertions(+), 142 deletions(-) diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index b2bc492e0..8ae1cc444 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -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 ;; diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 2025b0538..cb01223ff 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -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)))) diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp index 42bce14f6..800fba7ec 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -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#) diff --git a/src/clos/load.lsp.in b/src/clos/load.lsp.in index 59716400d..256507d2a 100644 --- a/src/clos/load.lsp.in +++ b/src/clos/load.lsp.in @@ -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" diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index b485e1f76..90e3176ad 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.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)))))) ;;; ---------------------------------------------------------------------- ;;; diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 2392d2a6e..d4d5be068 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -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)) diff --git a/src/clos/std-slot-value.lsp b/src/clos/std-slot-value.lsp index b661df3be..38a718a4e 100644 --- a/src/clos/std-slot-value.lsp +++ b/src/clos/std-slot-value.lsp @@ -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)))