diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 894cb22f9..a1c1205e6 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -53,10 +53,18 @@ (the-t (make-empty-standard-class 'T the-class)) ;; It does not matter that we pass NIL instead of a class object, ;; because CANONICAL-SLOT-TO-DIRECT-SLOT will make simple slots. - (class-slots (loop for s in (parse-slots '#.(remove-accessors +class-slots+)) - collect (canonical-slot-to-direct-slot nil s))) - (standard-slots (loop for s in (parse-slots '#.(remove-accessors +standard-class-slots+)) - collect (canonical-slot-to-direct-slot nil s))) + (specializer-slots + (loop for s in (parse-slots '#.(remove-accessors +specializer-slots+)) + collect (canonical-slot-to-direct-slot nil s))) + (eql-specializer-slots + (loop for s in (parse-slots '#.(remove-accessors +eql-specializer-slots+)) + collect (canonical-slot-to-direct-slot nil s))) + (class-slots + (loop for s in (parse-slots '#.(remove-accessors +class-slots+)) + collect (canonical-slot-to-direct-slot nil s))) + (standard-slots + (loop for s in (parse-slots '#.(remove-accessors +standard-class-slots+)) + collect (canonical-slot-to-direct-slot nil s))) (hash-table (make-hash-table :size 24))) ;; 2) STANDARD-CLASS and CLASS and others are classes with slots. Create a @@ -76,6 +84,14 @@ (class-size the-class) (length class-slots) (slot-table the-class) hash-table (class-direct-slots the-class) class-slots) + (setf (class-slots specializer) (copy-list specializer-slots) + (class-size specializer) (length specializer-slots) + (slot-table specializer) hash-table + (class-direct-slots specializer) specializer-slots) + (setf (class-slots eql-specializer) (copy-list eql-specializer-slots) + (class-size eql-specializer) (length eql-specializer-slots) + (slot-table eql-specializer) hash-table + (class-direct-slots eql-specializer) eql-specializer-slots) (setf (class-slots standard-class) standard-slots (class-size standard-class) (length standard-slots) (slot-table standard-class) hash-table @@ -128,7 +144,7 @@ (class-direct-superclasses metaobject) (list standard-object) (class-direct-subclasses metaobject) (list specializer) (class-direct-superclasses specializer) (list metaobject) - (class-direct-subclasses specializer) (list the-class) + (class-direct-subclasses specializer) (list the-class eql-specializer) (class-direct-superclasses eql-specializer) (list specializer) (class-direct-superclasses the-class) (list specializer) (class-direct-subclasses the-class) (list std-class) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index ac007e828..191019ef3 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -271,8 +271,6 @@ their lambda lists ~A and ~A are not congruent." (error "In method ~A~%No next method given arguments ~A" method args)) (defun no-primary-method (gf &rest args) - (print gf) - (print args) (error "Generic function: ~A. No primary method given arguments: ~S" (generic-function-name gf) args)) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 18cf50abd..db9d61289 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -31,29 +31,26 @@ (eval-when (compile eval) (defun create-accessors (slotds type) - (let ((i 0) - (output '()) - (names '()) - name) - (dolist (s slotds) - (when (setf name (getf (cdr s) :accessor)) - (push name names) - (setf output - (append output - `((defun ,name (obj) - (si:instance-ref obj ,i)) - (defsetf ,name (obj) (x) - `(si:instance-set ,obj ,,i ,x)) - #+nil - (define-compiler-macro ,name (obj) - `(si:instance-ref ,obj ,,i)) - )))) - (incf i)) + (let* ((names '()) + (forms (loop for i from 0 + for s in slotds + for accessor = (getf (cdr s) :accessor) + for reader = (getf (cdr s) :reader) + when reader + do (pushnew reader names) + and collect `(defun ,reader (obj) + (si::instance-ref obj ,i)) + when accessor + do (pushnew accessor names) + and collect `(defun ,accessor (obj) + (si::instance-ref obj ,i)) + and collect `(defsetf ,accessor (obj) (x) + `(si::instance-set ,obj ,,i ,x))))) `(progn #+nil (eval-when (:compile-toplevel :execute) (proclaim '(notinline ,@names))) - ,@output))) + ,@forms))) (defun remove-accessors (slotds) (loop for i in slotds for j = (copy-list i) @@ -61,12 +58,29 @@ collect j)) ) +;;; ---------------------------------------------------------------------- +;;; Class SPECIALIZER + +(eval-when (compile eval) + (defparameter +specializer-slots+ + '((flag :initform nil :accessor specializer-flag) + (direct-methods :initform nil :accessor specializer-direct-methods) + (direct-generic-functions :initform nil :accessor specializer-direct-generic-functions))) + (defparameter +eql-specializer-slots+ + '((flag :initform t :accessor specializer-flag) + (direct-methods :initform nil :accessor specializer-direct-methods) + (direct-generic-functions :initform nil :accessor specializer-direct-generic-functions) + (object :initarg :object :accessor eql-specializer-object)))) + +#.(create-accessors +eql-specializer-slots+ 'eql-specializer) + ;;; ---------------------------------------------------------------------- ;;; Class CLASS (eval-when (compile eval) (defparameter +class-slots+ - '((name :initarg :name :initform nil :accessor class-id) + `(,@+specializer-slots+ + (name :initarg :name :initform nil :accessor class-id) (direct-superclasses :initarg :direct-superclasses :accessor class-direct-superclasses) (direct-subclasses :initform nil :accessor class-direct-subclasses) @@ -82,7 +96,12 @@ (sealedp :initarg :sealedp :initform nil :accessor class-sealedp) (prototype) (dependents :initform nil :accessor class-dependents) - (valid-initargs :accessor class-valid-initargs)))) + (valid-initargs :accessor class-valid-initargs))) + + (defconstant +class-name-ndx+ + (position 'name +class-slots+ :key #'first)) + (defconstant +class-precedence-list-ndx+ + (position 'precedence-list +class-slots+ :key #'first))) ;#.(create-accessors +class-slots+ 'class) diff --git a/src/h/object.h b/src/h/object.h index 9db0eee1d..998474a31 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -967,11 +967,13 @@ struct ecl_condition_variable { #ifdef CLOS #define CLASS_OF(x) (x)->instance.clas -#define CLASS_NAME(x) (x)->instance.slots[0] -#define CLASS_SUPERIORS(x) (x)->instance.slots[1] -#define CLASS_INFERIORS(x) (x)->instance.slots[2] -#define CLASS_SLOTS(x) (x)->instance.slots[3] -#define CLASS_CPL(x) (x)->instance.slots[4] +#define ECL_SPEC_FLAG(x) (x)->instance.slots[0] +#define ECL_SPEC_OBJECT(x) (x)->instance.slots[3] +#define CLASS_NAME(x) (x)->instance.slots[3+0] +#define CLASS_SUPERIORS(x) (x)->instance.slots[3+1] +#define CLASS_INFERIORS(x) (x)->instance.slots[3+2] +#define CLASS_SLOTS(x) (x)->instance.slots[3+3] +#define CLASS_CPL(x) (x)->instance.slots[3+4] #define ECL_INSTANCEP(x) ((IMMEDIATE(x)==0) && ((x)->d.t==t_instance)) #define ECL_NOT_FUNCALLABLE 0 #define ECL_STANDARD_DISPATCH 1 diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index 92696e5d7..068b1fea4 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -557,19 +557,16 @@ Returns T if X belongs to TYPE; NIL otherwise." #+clos (defun subclassp (low high) (or (eq low high) - (member high (sys:instance-ref low 4) :test #'eq)) ; (class-precedence-list low) - #+(or) - (or (eq low high) - (dolist (class (sys:instance-ref low 1)) ; (class-superiors low) - (when (si::subclassp class high) (return t))))) + (member high (sys:instance-ref low clos::+class-precedence-list-ndx+) + :test #'eq))) ; (class-precedence-list low) #+clos (defun of-class-p (object class) (declare (optimize (speed 3) (safety 0))) (macrolet ((class-precedence-list (x) - `(instance-ref ,x 4)) + `(si::instance-ref ,x clos::+class-precedence-list-ndx+)) (class-name (x) - `(instance-ref ,x 0))) + `(si::instance-ref ,x clos::+class-name-ndx+))) (let* ((x-class (class-of object))) (declare (class x-class)) (if (eq x-class class)