From d41d4544e8dbb79be56428784008a07705b8a600 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 20 Mar 2006 09:03:43 +0000 Subject: [PATCH] Slot accessors go now through slot definition objects. --- src/CHANGELOG | 9 +++ src/clos/boot.lsp | 141 ++++++++++++++++++++++++------------ src/clos/builtin.lsp | 10 +-- src/clos/fixup.lsp | 23 +----- src/clos/kernel.lsp | 3 +- src/clos/slot.lsp | 5 +- src/clos/standard.lsp | 164 +++++++++++++----------------------------- src/cmp/sysfun.lsp | 2 - 8 files changed, 163 insertions(+), 194 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 72e578a9b..46dc68b12 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -79,6 +79,15 @@ ECL 0.9i - New manual file for 'ecl-config' contributed by Peter Van Eynde. +* MOP compatibility: + + - SLOT-VALUE, SLOT-BOUNDP, etc, together with MOP SLOT*-USING-CLASS generic + functions now rely entirely on slot-definition objects. + + - Effective slot definitions now have a "location" slot. Around methods for + COMPUTE-SLOTS assign a location to each slot definition that has allocation + :INSTANCE or :CLASS. + * Errors fixed: - The intermediate output of the compiler is written in the directory in which diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 9d29a4f8f..cc41de073 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -12,9 +12,8 @@ ;;; ---------------------------------------------------------------------- ;;; Building the classes T, CLASS, STANDARD-OBJECT and STANDARD-CLASS. ;;; -;;; We cannot use the functions CREATE-STANDARD-CLASS and others because -;;; SLOT-INDEX-TABLE, SLOTS, DIRECT-SLOTS, etc are empty and therefore -;;; SLOT-VALUE does not work. +;;; We cannot use the functions CREATE-STANDARD-CLASS and others because SLOTS, +;;; DIRECT-SLOTS, etc are empty and therefore SLOT-VALUE does not work. (defun make-empty-standard-class (name metaclass) (let ((class (si:allocate-raw-instance nil metaclass #.(length +standard-class-slots+)))) @@ -31,8 +30,7 @@ (class-finalized-p class) t (find-class name) class) (unless (eq name 'T) - (setf (slot-index-table class) (make-hash-table :size 2) - (class-shared-slots class) nil)) + (setf (slot-table class) (make-hash-table :size 2))) class)) ;; 1) Create the classes @@ -59,12 +57,17 @@ (do* ((i 0 (1+ i)) (slots standard-slots (cdr slots))) ((endp slots)) - (setf (gethash (caar slots) hash-table) i)) + (let ((slotd (first slots))) + (setf (slot-definition-location slotd) i) + (setf (gethash (slot-definition-name slotd) hash-table) slotd))) + (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 - (slot-index-table the-class) hash-table + (slot-table the-class) hash-table (class-direct-slots the-class) class-slots (class-slots standard-class) standard-slots - (slot-index-table standard-class) hash-table + (slot-table standard-class) hash-table (class-direct-slots standard-class) (set-difference standard-slots class-slots)) ;; 3) Fix the class hierarchy @@ -91,6 +94,8 @@ ;; 5) Generate accessors (In macros.lsp) ) +(defconstant +the-standard-class+ (find-class 'standard nil)) + (defmethod class-prototype ((class class)) (unless (slot-boundp class 'prototype) (setf (slot-value class 'prototype) (allocate-instance class))) @@ -103,62 +108,104 @@ ;;; 1) Functional interface ;;; +(defun find-slot-definition (class slot-name) + (declare (si::c-local)) + (if (eq (si:instance-class class) +the-standard-class+) + (gethash (class-slot-table class) slot-name nil) + (find slot-name (class-slots class) :key #'slot-definition-name))) + (defun slot-value (self slot-name) - (slot-value-using-class (class-of self) self slot-name)) + (let* ((class (class-of self)) + (slotd (find-slot-definition class slot-name))) + (if slotd + (slot-value-using-class class self slotd) + (values (slot-missing class self slot-name 'SLOT-VALUE))))) (defun slot-boundp (self slot-name) - (slot-boundp-using-class (class-of self) self slot-name)) + (let* ((class (class-of self)) + (slotd (find-slot-definition class slot-name))) + (if slotd + (slot-boundp-using-class class self slotd) + (values (slot-missing class self slot-name 'SLOT-BOUNDP))))) (defun (setf slot-value) (value self slot-name) - (funcall #'(setf slot-value-using-class) value (class-of self) self slot-name)) + (let* ((class (class-of self)) + (slotd (find-slot-definition class slot-name))) + (if slotd + (funcall #'(setf slot-value-using-class) value class self slotd) + (slot-missing class self slot-name 'SETF value)) + value)) (defun slot-makunbound (self slot-name) - (slot-makunbound-using-class (class-of self) self slot-name)) + (let* ((class (class-of self)) + (slotd (find-slot-definition class slot-name))) + (if slotd + (slot-makunbound-using-class class self slotd) + (slot-missing class self slot-name 'SLOT-MAKUNBOUND)) + self)) (defun slot-exists-p (self slot-name) - (slot-exists-p-using-class (class-of self) self slot-name)) + (and (find-slot-definition (class-of self) slot-name) + t)) ;;; ;;; 2) Overloadable methods on which the previous functions are based ;;; -(defmethod slot-value-using-class ((class class) self slot-name) - (ensure-up-to-date-instance self) - (let* ((index (position slot-name (class-slots class) - :key #'slot-definition-name :test #'eq))) - (values - (if index - (let ((val (si:instance-ref self (the fixnum index)))) - (if (si:sl-boundp val) - val - (slot-unbound (si::instance-class class) class slot-name))) - (slot-missing (si:instance-class class) class slot-name - 'SLOT-VALUE))))) +(defun standard-instance-get (instance slotd) + (ensure-up-to-date-instance instance) + (let* ((class (si:instance-class instance)) + (location (slot-definition-location slotd))) + (cond ((si:fixnump location) + ;; local slot + (si:instance-ref instance (the fixnum location))) + ((consp location) + ;; shared slot + (car location)) + (t + (error "Effective slot definition lacks a valid location:~%~A" + slotd))))) -(defmethod slot-boundp-using-class ((class class) self slot-name) - (ensure-up-to-date-instance self) - (let* ((index (position slot-name (class-slots class) - :key #'slot-definition-name :test #'eq))) - (values - (if index - (si:sl-boundp (si:instance-ref self (the fixnum index))) - (slot-missing (si:instance-class class) class slot-name - 'SLOT-BOUNDP))))) +(defun standard-instance-set (val instance slotd) + (ensure-up-to-date-instance instance) + (let* ((class (si:instance-class instance)) + (location (slot-definition-location slotd))) + (cond ((si:fixnump location) + ;; local slot + (si:instance-set instance (the fixnum location) val)) + ((consp location) + ;; shared slot + (setf (car location) val)) + (t + (error "Effective slot definition lacks a valid location:~%~A" + slotd))) + val)) -(defmethod (setf slot-value-using-class) (val (class class) self slot-name) - (ensure-up-to-date-instance self) - (let* ((index (position slot-name (class-slots class) - :key #'slot-definition-name :test #'eq))) - (if index - (si:instance-set self (the fixnum index) val) - (slot-missing (si:instance-class self) self slot-name - 'SETF val))) - val) +(defmethod slot-value-using-class ((class class) self slotd) + (let ((value (standard-instance-get self slotd))) + (if (si:sl-boundp value) + value + (values (slot-unbound class self (slot-definition-name slotd)))))) -(defmethod slot-exists-p-using-class ((class class) self slot-name) - (ensure-up-to-date-instance self) - (and (position slot-name (class-slots class) :key #'slot-definition-name :test #'eq) - t)) +(defmethod slot-boundp-using-class ((class class) self slotd) + (si::sl-boundp (standard-instance-get self slotd))) + +(defmethod (setf slot-value-using-class) (val (class class) self slotd) + (standard-instance-set val self slotd)) + +(defmethod slot-makunbound-using-class ((class class) instance slotd) + (ensure-up-to-date-instance instance) + (let* ((location (slot-definition-location slotd))) + (cond ((si:fixnump location) + ;; local slot + (si:sl-makunbound instance (the fixnum location))) + ((consp location) + ;; shared slot + (setf (car location) (unbound))) + (t + (error "Effective slot definition lacks a valid location:~%~A" + slotd)))) + instance) ;;; ;;; 3) Error messages related to slot access diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp index bc893b623..3fac0b717 100644 --- a/src/clos/builtin.lsp +++ b/src/clos/builtin.lsp @@ -102,19 +102,19 @@ (defmethod make-instance ((class-name symbol) &rest initargs) (apply #'make-instance (find-class class-name) initargs)) -(defmethod slot-makunbound-using-class ((class built-in-class) self slot-name) +(defmethod slot-makunbound-using-class ((class built-in-class) self slotd) (error "SLOT-MAKUNBOUND-USING-CLASS cannot be applied on built-in objects")) -(defmethod slot-boundp-using-class ((class built-in-class) self slot-name) +(defmethod slot-boundp-using-class ((class built-in-class) self slotd) (error "SLOT-BOUNDP-USING-CLASS cannot be applied on built-in objects")) -(defmethod slot-value-using-class ((class built-in-class) self slot-name) +(defmethod slot-value-using-class ((class built-in-class) self slotd) (error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects")) -(defmethod (setf slot-value-using-class) (val (class built-in-class) self slot-name) +(defmethod (setf slot-value-using-class) (val (class built-in-class) self slotd) (error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects")) -(defmethod slot-exists-p-using-class ((class built-in-class) self slot-name) +(defmethod slot-exists-p-using-class ((class built-in-class) self slotd) nil) ;;; ====================================================================== diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 95e0b2bb9..b64ef8755 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -25,7 +25,7 @@ |# (defun convert-one-class (class) - (dolist (l (class-slots class)) + (dolist (l (class-direct-slots class)) (let ((x (first l))) (when (consp x) (setf (first l) @@ -219,24 +219,3 @@ their lambda lists ~A and ~A are not congruent." (t (error "~A is not a class." new-value)))) new-value) ) - -;;; ---------------------------------------------------------------------- -;;; Slot accessors -;;; - -(defmethod slot-value-using-class ((class standard-class) instance - (slot standard-effective-slot-definition)) - (slot-value-using-class class instance (slot-definition-name slot))) - -(defmethod slot-boundp-using-class ((class standard-class) instance - (slot standard-effective-slot-definition)) - (slot-boundp-using-class class instance (slot-definition-name slot))) - -(defmethod (setf slot-value-using-class) (val (class standard-class) instance - (slot standard-effective-slot-definition)) - (standard-instance-set val instance (slot-definition-name slot))) - -(defmethod slot-makunbound-using-class ((class standard-class) instance - (slot standard-effective-slot-definition)) - (slot-makunbound-using-class class instance (slot-definition-name slot))) - diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 8a9387942..ddd796dc8 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -73,8 +73,7 @@ (eval-when (compile eval) (defparameter +standard-class-slots+ (append +class-slots+ - '((slot-index-table :accessor slot-index-table) - (shared-slots :initform nil :accessor class-shared-slots) + '((slot-table :accessor slot-table) (forward))))) #.(create-accessors +standard-class-slots+ 'standard-class) diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index 5d37775d2..bf56fd44f 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -38,10 +38,11 @@ (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) )) -(defun make-simple-slotd (&key name initform initfunction type allocation initargs readers writers documentation) - (list name initform initfunction type allocation initargs readers writers documentation)) +(defun make-simple-slotd (&key name initform initfunction type allocation initargs readers writers documentation location) + (list name initform initfunction type allocation initargs readers writers documentation location)) (defun canonical-slot-to-direct-slot (class slotd) (if (find-class 'slot-definition nil) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 428c798d7..0db10c4e7 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -234,9 +234,16 @@ because it contains a reference to the undefined class~% ~A" :direct-superclasses (class-direct-superclasses subclass))) ) +(defun std-create-slots-table (class) + (let* ((all-slots (class-slots class)) + (table (make-hash-table :size (max 32 (length all-slots))))) + (dolist (slotd (class-slots class)) + (setf (gethash (slot-definition-name slotd) table) slotd)) + (setf (slot-table class) table))) + (defmethod finalize-inheritance ((class standard-class)) (call-next-method) - (std-class-allocate-slots class) + (std-create-slots-table class) (std-class-generate-accessors class)) (defmethod compute-class-precedence-list ((class class)) @@ -346,38 +353,44 @@ because it contains a reference to the undefined class~% ~A" (list* :direct-superclasses direct-superclasses options))) ;;; ---------------------------------------------------------------------- -;;; Slots hashing for standard classes +;;; Around methods for COMPUTE-SLOTS which assign locations to each slot. ;;; -(defun std-class-allocate-slots (class) +(defun class-compute-slots (class slots) + (let ((local-index -1)) + (declare (fixnum local-index)) + (dolist (slotd slots) + (when (eq (slot-definition-allocation slotd) :instance) + (setf (slot-definition-location slotd) (incf local-index)))) + slots)) + +(defmethod compute-slots :around ((class class)) + (class-compute-slots class (call-next-method))) + +(defun std-class-compute-slots (class slots) (declare (si::c-local)) - (let* ((slots (class-slots class)) - (direct-slots (class-direct-slots class)) - (slot-instance-count (count-instance-slots class)) - (table (make-hash-table :size (max 32 (* 2 slot-instance-count)))) - (local-index -1) - (shared-index -1)) - (declare (fixnum local-index shared-index)) - (dolist (slot slots) - (let* ((name (slot-definition-name slot)) - (allocation (slot-definition-allocation slot)) - location) - (cond ((eq allocation :INSTANCE) ; local slot - (setq location (incf local-index))) + (let* ((direct-slots (class-direct-slots class))) + (dolist (slotd slots) + (let* ((name (slot-definition-name slotd)) + (allocation (slot-definition-allocation slotd))) + (cond ((not (eq (slot-definition-allocation slotd) :class))) ((find name direct-slots :key #'slot-definition-name) ; new shared slot - (setq location (cons class (incf shared-index)))) + (setf (slot-definition-location slotd) (list (unbound)))) (t ; inherited shared slot (dolist (c (class-precedence-list class)) - (when (and - (not (eql c class)) - (typep c 'STANDARD-CLASS) - (setq location - (gethash name (slot-value c 'SLOT-INDEX-TABLE)))) - (return))))) - (setf (gethash name table) location))) - (setf (class-shared-slots class) - (make-array (1+ shared-index) :initial-element (unbound)) - (slot-index-table class) table))) + (unless (eql c class) + (let ((other (find (slot-definition-name slotd) + (class-slots c) + :key #'slot-definition-name))) + (when (and other + (eq (slot-definition-allocation other) allocation) + (setf (slot-definition-location slotd) + (slot-definition-location other))) + (return))))))))) + slots)) + +(defmethod compute-slots :around ((class standard-class)) + (std-class-compute-slots class (call-next-method))) ;;; ---------------------------------------------------------------------- ;;; Optional accessors @@ -391,28 +404,26 @@ because it contains a reference to the undefined class~% ~A" ;; the liberty of using SI:INSTANCE-REF because they know the class of ;; the instance. ;; - (do* ((slots (class-slots standard-class) (cdr slots)) - (i 0)) - ((endp slots)) - (declare (fixnum i)) - (let* ((slotd (first slots)) - (slot-name (slot-definition-name slotd)) - (index i) + (dolist (slotd (class-slots standard-class)) + (let* ((slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) reader setter) (declare (fixnum index)) - (if (eql (slot-definition-allocation slotd) :instance) + (if (and (eql (slot-definition-allocation slotd) :instance) + (si:fixnump index)) (setf reader #'(lambda (self) (let ((value (si:instance-ref self index))) (if (si:sl-boundp value) value (values (slot-unbound (class-of self) self slot-name))))) setter #'(lambda (value self) - (si:instance-set self index value)) - i (1+ i)) + (si:instance-set self index value))) (setf reader #'(lambda (self) - (slot-value self slot-name)) + (slot-value-using-class (si:instance-class self) + self slotd)) setter #'(lambda (value self) - (setf (slot-value self slot-name) value)))) + (setf (slot-value-using-class (si:instance-class self) + self slotd) value)))) (dolist (fname (slot-definition-readers slotd)) (install-method fname nil `(,standard-class) '(self) nil nil reader)) @@ -426,48 +437,6 @@ because it contains a reference to the undefined class~% ~A" ;;; Standard-object has no slots and inherits only from t: ;;; (defclass standard-object (t) ()) -(defmethod slot-value-using-class ((class standard-class) instance slot-name) - (multiple-value-bind (val condition) - (standard-instance-get instance slot-name) - (case condition - (:VALUE val) - (:UNBOUND (values (slot-unbound (si:instance-class instance) instance - slot-name))) - (:MISSING (values (slot-missing (si:instance-class instance) instance - slot-name 'SLOT-VALUE))) - ))) - -(defmethod slot-boundp-using-class ((class standard-class) instance slot-name) - (multiple-value-bind (val condition) - (standard-instance-get instance slot-name) - (declare (ignore val)) - (case condition - (:VALUE t) - (:UNBOUND nil) - (:MISSING (values (slot-missing (si:instance-class instance) instance - slot-name 'SLOT-BOUNDP))) - ))) - -(defmethod (setf slot-value-using-class) (val (class standard-class) instance - slot-name) - (standard-instance-set val instance slot-name)) - -(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name) - (and (nth-value 0 (gethash slot-name (slot-index-table class) nil)) - t)) - -(defmethod slot-makunbound-using-class ((class standard-class) instance slot-name) - (let* ((index (slot-index slot-name (slot-index-table class)))) - (if index - (if (atom index) - (si:sl-makunbound instance (the fixnum index)) - ;; else it is a shared slot - (setf (svref (class-shared-slots (car index)) (cdr index)) - (unbound))) - (slot-missing (si:instance-class instance) instance slot-name - 'SLOT-MAKUNBOUND))) - instance) - (defmethod describe-object ((obj standard-object) (stream t)) (let* ((class (si:instance-class obj)) (slotds (class-slots class)) @@ -556,39 +525,6 @@ because it contains a reference to the undefined class~% ~A" (t (setf unknown-key name))))))) -;;; ---------------------------------------------------------------------- -;;; Basic access to instances - -(defun standard-instance-get (instance slot-name) - (ensure-up-to-date-instance instance) - (let* ((class (si:instance-class instance)) - (index (gethash slot-name (slot-index-table class)))) - (declare (type standard-class class)) - (if (null index) - (values nil :MISSING) - (let ((val (if (atom index) - ;; local slot - (si:instance-ref instance (the fixnum index)) - ;; shared slot - (svref (class-shared-slots (car index)) (cdr index))))) - (if (si:sl-boundp val) - (values val :VALUE) - (values nil :UNBOUND)))))) - -(defun standard-instance-set (val instance slot-name) - (ensure-up-to-date-instance instance) - (let* ((class (si:instance-class instance)) - (index (gethash slot-name (slot-index-table class)))) - (declare (type standard-class class)) - (if index - (if (atom index) - (si:instance-set instance (the fixnum index) val) - ;; else it is a shared slot - (setf (svref (class-shared-slots (car index)) (cdr index)) val)) - (slot-missing (si:instance-class instance) instance slot-name - 'SETF val)) - val)) - ;;; ---------------------------------------------------------------------- ;;; Methods diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index d4b17c61a..6b9d4d533 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -1412,9 +1412,7 @@ type_of(#0)==t_bitvector") clos::class-direct-subclasses clos::class-slots clos::class-precedence-list - clos::slot-index-table clos::class-direct-slots - clos::class-shared-slots clos::default-initargs-of clos::generic-function-lambda-list clos::generic-function-argument-precedence-order