Add slots to SPECIALIZER and EQL-SPECIALIZER

parent 1ecb59b7
......@@ -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)
......
......@@ -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))
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment