Add slots to SPECIALIZER and EQL-SPECIALIZER

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)

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

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)
 

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

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)