mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 15:40:55 -08:00
Implemented SLOT-DEFINITION objects together with the associated protocols (Field position still missing).
This commit is contained in:
jjgarcia
parent
b8beb2cdf8
commit
39d35ffa38
14 changed files with 284 additions and 194 deletions
|
|
@ -72,6 +72,13 @@ ECL 0.9f
|
|||
|
||||
- When *PRINT-READABLY*=T, vectors just print as arrays.
|
||||
|
||||
* MOP Compatibility:
|
||||
|
||||
- We have implemented the *-SLOT-DEFINITION classes, as well as the protocol
|
||||
for computing effective slot definitions from direct ones, and the methods
|
||||
DIRECT/EFFECTIVE-SLOT-DEFINITION-CLASS. (Position field in slot-def. objects
|
||||
still missing).
|
||||
|
||||
* Contributed modules:
|
||||
|
||||
- MIT test unit rt.lisp is now available as #p"sys:rt"
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
#define EXT_PACKAGE SI_PACKAGE
|
||||
#define KEYWORD_PACKAGE 8
|
||||
#define MP_PACKAGE 12
|
||||
#define CLOS_PACKAGE 16
|
||||
#define ORDINARY_SYMBOL 0
|
||||
#define CONSTANT_SYMBOL 1
|
||||
#define SPECIAL_SYMBOL 2
|
||||
|
|
@ -27,6 +28,7 @@
|
|||
#define MP_ORDINARY MP_PACKAGE | ORDINARY_SYMBOL
|
||||
#define MP_SPECIAL MP_PACKAGE | SPECIAL_SYMBOL
|
||||
#define MP_CONSTANT MP_PACKAGE | CONSTANT_SYMBOL
|
||||
#define CLOS_ORDINARY CLOS_PACKAGE | ORDINARY_SYMBOL
|
||||
#define KEYWORD KEYWORD_PACKAGE | CONSTANT_SYMBOL
|
||||
|
||||
#include "symbols_list.h"
|
||||
|
|
@ -172,12 +174,15 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
|
|||
case CONSTANT_SYMBOL: stp = stp_constant; break;
|
||||
case FORM_SYMBOL: form = 1; stp = stp_ordinary;
|
||||
}
|
||||
switch (code & 12) {
|
||||
switch (code & 28) {
|
||||
case CL_PACKAGE: package = cl_core.lisp_package; break;
|
||||
case SI_PACKAGE: package = cl_core.system_package; break;
|
||||
case KEYWORD_PACKAGE: package = cl_core.keyword_package; break;
|
||||
#ifdef ECL_THREADS
|
||||
case MP_PACKAGE: package = cl_core.mp_package; break;
|
||||
#endif
|
||||
#ifdef CLOS
|
||||
case CLOS_PACKAGE: package = cl_core.clos_package; break;
|
||||
#endif
|
||||
}
|
||||
s->symbol.t = t_symbol;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
# define _D(x) NULL
|
||||
#endif
|
||||
#ifdef DPP
|
||||
#define CLOS_ "CLOS::"
|
||||
#define EXT_ "EXT::"
|
||||
#define SYS_ "SI::"
|
||||
#define MP_ "MP::"
|
||||
|
|
@ -17,6 +18,7 @@ struct {
|
|||
const char *name, *translation;
|
||||
}
|
||||
#else
|
||||
#define CLOS_
|
||||
#define EXT_
|
||||
#define SYS_
|
||||
#define MP_
|
||||
|
|
@ -1483,6 +1485,19 @@ cl_symbols[] = {
|
|||
{SYS_ "QUASIQUOTE", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
{SYS_ "*EXIT-HOOKS*", SI_SPECIAL, NULL, -1, Cnil},
|
||||
|
||||
#ifdef CLOS
|
||||
{CLOS_ "SLOT-DEFINITION", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-ALLOCATION", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-INITARGS", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-INITFORM", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-INITFUNCTION", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-NAME", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-TYPE", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-READERS", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-WRITERS", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
{CLOS_ "SLOT-DEFINITION-DOCUMENTATION", CLOS_ORDINARY, NULL, -1, OBJNULL},
|
||||
#endif
|
||||
|
||||
/* Tag for end of list */
|
||||
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
|
||||
|
||||
|
|
|
|||
|
|
@ -44,8 +44,9 @@
|
|||
(standard-object (make-empty-standard-class 'STANDARD-OBJECT standard-class))
|
||||
(the-class (make-empty-standard-class 'CLASS standard-class))
|
||||
(the-t (make-empty-standard-class 'T standard-class))
|
||||
(class-slots '#.+class-slots+)
|
||||
(standard-slots '#.+standard-class-slots+)
|
||||
(class-slots (mapcar #'canonical-slot-to-direct-slot (parse-slots '#.+class-slots+)))
|
||||
(standard-slots (mapcar #'canonical-slot-to-direct-slot
|
||||
(parse-slots '#.+standard-class-slots+)))
|
||||
(hash-table (make-hash-table :size 24)))
|
||||
|
||||
;; 2) STANDARD-CLASS and CLASS are the only classes with slots. Create a
|
||||
|
|
@ -56,12 +57,12 @@
|
|||
(slots standard-slots (cdr slots)))
|
||||
((endp slots))
|
||||
(setf (gethash (caar slots) hash-table) i))
|
||||
(setf (class-slots the-class) (parse-slots class-slots)
|
||||
(setf (class-slots the-class) class-slots
|
||||
(slot-index-table the-class) hash-table
|
||||
(class-direct-slots the-class) (class-slots the-class)
|
||||
(class-slots standard-class) (parse-slots standard-slots)
|
||||
(class-direct-slots the-class) class-slots
|
||||
(class-slots standard-class) standard-slots
|
||||
(slot-index-table standard-class) hash-table
|
||||
(class-direct-slots standard-class) (class-slots standard-class))
|
||||
(class-direct-slots standard-class) class-slots)
|
||||
|
||||
;; 3) Fix the class hierarchy
|
||||
(setf (class-direct-superclasses the-t) nil
|
||||
|
|
@ -120,7 +121,7 @@
|
|||
(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 #'slotd-name :test #'eq)))
|
||||
:key #'slot-definition-name :test #'eq)))
|
||||
(values
|
||||
(if index
|
||||
(let ((val (si:instance-ref self (the fixnum index))))
|
||||
|
|
@ -133,7 +134,7 @@
|
|||
(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 #'slotd-name :test #'eq)))
|
||||
:key #'slot-definition-name :test #'eq)))
|
||||
(values
|
||||
(if index
|
||||
(si:sl-boundp (si:instance-ref self (the fixnum index)))
|
||||
|
|
@ -143,7 +144,7 @@
|
|||
(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 #'slotd-name :test #'eq)))
|
||||
: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
|
||||
|
|
@ -152,7 +153,7 @@
|
|||
|
||||
(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 #'slotd-name :test #'eq)
|
||||
(and (position slot-name (class-slots class) :key #'slot-definition-name :test #'eq)
|
||||
t))
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -132,7 +132,7 @@
|
|||
(defmethod finalize-inheritance ((class structure-class))
|
||||
(call-next-method)
|
||||
(dolist (slot (class-slots class))
|
||||
(unless (eq :INSTANCE (slotd-allocation slot))
|
||||
(unless (eq :INSTANCE (slot-definition-allocation slot))
|
||||
(error "The structure class ~S can't have shared slots" (class-name class)))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
@ -171,7 +171,7 @@
|
|||
(return))
|
||||
(setq sv (si:instance-ref obj i))
|
||||
(write-string " :" stream)
|
||||
(prin1 (slotd-name (car scan)) stream)
|
||||
(prin1 (slot-definition-name (car scan)) stream)
|
||||
(write-string " " stream)
|
||||
(prin1 sv stream))
|
||||
(write-string ")" stream)
|
||||
|
|
|
|||
|
|
@ -42,10 +42,10 @@
|
|||
((old-data standard-object) (new-data standard-object) &rest initargs)
|
||||
(let ((old-local-slotds (si::instance-sig old-data))
|
||||
(new-local-slotds (remove :instance (si::instance-sig new-data)
|
||||
:test-not #'eq :key #'slotd-allocation))
|
||||
:test-not #'eq :key #'slot-definition-allocation))
|
||||
added-slots)
|
||||
(setf added-slots (set-difference (mapcar #'slotd-name new-local-slotds)
|
||||
(mapcar #'slotd-name old-local-slotds)))
|
||||
(setf added-slots (set-difference (mapcar #'slot-definition-name new-local-slotds)
|
||||
(mapcar #'slot-definition-name old-local-slotds)))
|
||||
(check-initargs (class-of new-data) initargs
|
||||
(append (compute-applicable-methods
|
||||
#'update-instance-for-different-class
|
||||
|
|
@ -69,8 +69,8 @@
|
|||
(new-local-slotds (class-slots (class-of instance))))
|
||||
(dolist (new-slot new-local-slotds)
|
||||
;; CHANGE-CLASS can only operate on the value of local slots.
|
||||
(when (eq (slotd-allocation new-slot) :INSTANCE)
|
||||
(let ((name (slotd-name new-slot)))
|
||||
(when (eq (slot-definition-allocation new-slot) :INSTANCE)
|
||||
(let ((name (slot-definition-name new-slot)))
|
||||
(if (and (slot-exists-p old-instance name)
|
||||
(slot-boundp old-instance name))
|
||||
(setf (slot-value instance name) (slot-value old-instance name))
|
||||
|
|
@ -141,20 +141,20 @@
|
|||
(si::instance-sig-set instance)
|
||||
(let* ((new-i 0)
|
||||
(old-local-slotds (remove :instance old-slotds :test-not #'eq
|
||||
:key #'slotd-allocation))
|
||||
:key #'slot-definition-allocation))
|
||||
(new-local-slotds (remove :instance new-slotds :test-not #'eq
|
||||
:key #'slotd-allocation)))
|
||||
:key #'slot-definition-allocation)))
|
||||
(declare (fixnum new-i))
|
||||
(setq discarded-slots
|
||||
(set-difference (mapcar #'slotd-name old-local-slotds)
|
||||
(mapcar #'slotd-name new-local-slotds)))
|
||||
(set-difference (mapcar #'slot-definition-name old-local-slotds)
|
||||
(mapcar #'slot-definition-name new-local-slotds)))
|
||||
(dolist (slot-name discarded-slots)
|
||||
(let* ((ndx (position slot-name old-local-slotds :key #'slotd-name)))
|
||||
(let* ((ndx (position slot-name old-local-slotds :key #'slot-definition-name)))
|
||||
(push (cons slot-name (si::instance-ref old-instance ndx))
|
||||
property-list)))
|
||||
(dolist (new-slot new-local-slotds)
|
||||
(let* ((name (slotd-name new-slot))
|
||||
(old-i (position name old-local-slotds :key #'slotd-name)))
|
||||
(let* ((name (slot-definition-name new-slot))
|
||||
(old-i (position name old-local-slotds :key #'slot-definition-name)))
|
||||
(if old-i
|
||||
(si::instance-set instance new-i
|
||||
(si::instance-ref old-instance old-i))
|
||||
|
|
@ -170,11 +170,11 @@
|
|||
:lambda-list '(class &rest initargs))
|
||||
|
||||
(defmethod reinitialize-instance ((class class) &rest initargs
|
||||
&key direct-superclasses)
|
||||
&key direct-superclasses (direct-slots nil direct-slots-p))
|
||||
(let ((name (class-name class)))
|
||||
(if (member name '(CLASS BUILT-IN-CLASS) :test #'eq)
|
||||
(error "The kernel CLOS class ~S cannot be changed." name)
|
||||
#+nil(warn "Redefining class ~S" name)))
|
||||
(warn "Redefining class ~S" name)))
|
||||
|
||||
;; remove previous defined accessor methods
|
||||
(when (class-finalized-p class)
|
||||
|
|
@ -182,15 +182,21 @@
|
|||
|
||||
(call-next-method)
|
||||
|
||||
;; the list of direct slots is converted to direct-slot-definitions
|
||||
(when direct-slots-p
|
||||
(setf (class-direct-slots class)
|
||||
(mapcar #'canonical-slot-to-direct-slot direct-slots)))
|
||||
|
||||
;; set up inheritance checking that it makes sense
|
||||
(dolist (l (setf (class-direct-superclasses class)
|
||||
(check-direct-superclasses class direct-superclasses)))
|
||||
(add-direct-subclass l class))
|
||||
|
||||
;; if there are no forward references, we can just finalize the class here
|
||||
(setf (class-finalized-p class) nil)
|
||||
(unless (find-if #'forward-referenced-class-p
|
||||
(class-direct-superclasses class))
|
||||
(unless (find-if #'forward-referenced-class-p (class-direct-superclasses class))
|
||||
(finalize-inheritance class))
|
||||
|
||||
class)
|
||||
|
||||
(defmethod make-instances-obsolete ((class class))
|
||||
|
|
@ -200,43 +206,9 @@
|
|||
(defun remove-optional-slot-accessors (class)
|
||||
(let ((class-name (class-name class)))
|
||||
(dolist (slotd (class-slots class))
|
||||
(dolist (accessor (slotd-accessors slotd))
|
||||
(let* ((gf-object (symbol-function accessor))
|
||||
(setf-accessor (list 'setf accessor))
|
||||
(setf-gf-object (fdefinition setf-accessor))
|
||||
found)
|
||||
;; primary reader method
|
||||
(when (setq found
|
||||
(find-method gf-object nil (list class-name) nil))
|
||||
(remove-method gf-object found))
|
||||
;; before reader method
|
||||
(when (setq found
|
||||
(find-method gf-object ':before (list class-name) nil))
|
||||
(remove-method gf-object found))
|
||||
;; after reader method
|
||||
(when (setq found
|
||||
(find-method gf-object ':after (list class-name) nil))
|
||||
(remove-method gf-object found))
|
||||
(when (null (generic-function-methods gf-object))
|
||||
(fmakunbound accessor))
|
||||
;; primary writer method
|
||||
(when (setq found
|
||||
(find-method setf-gf-object nil (list nil class-name) nil))
|
||||
(remove-method setf-gf-object found))
|
||||
;; before writer method
|
||||
(when (setq found
|
||||
(find-method setf-gf-object ':before (list nil class-name) nil))
|
||||
(remove-method setf-gf-object found))
|
||||
;; after writer method
|
||||
(when (setq found
|
||||
(find-method setf-gf-object ':after (list nil class-name) nil))
|
||||
(remove-method setf-gf-object found))
|
||||
(when (null (generic-function-methods gf-object))
|
||||
(fmakunbound setf-accessor))))
|
||||
|
||||
;; remove previous defined reader methods
|
||||
(dolist (reader (slotd-readers slotd))
|
||||
(let* ((gf-object (symbol-function reader))
|
||||
(dolist (reader (slot-definition-readers slotd))
|
||||
(let* ((gf-object (fdefinition reader))
|
||||
found)
|
||||
;; primary method
|
||||
(when (setq found
|
||||
|
|
@ -254,20 +226,20 @@
|
|||
(fmakunbound reader))))
|
||||
|
||||
;; remove previous defined writer methods
|
||||
(dolist (writer (slotd-writers slotd))
|
||||
(let* ((gf-object (symbol-function writer))
|
||||
(dolist (writer (slot-definition-writers slotd))
|
||||
(let* ((gf-object (fdefinition writer))
|
||||
found)
|
||||
;; primary method
|
||||
(when (setq found
|
||||
(find-method gf-object nil (list class-name) nil))
|
||||
(find-method gf-object nil (list 'T class-name) nil))
|
||||
(remove-method gf-object found))
|
||||
;; before method
|
||||
(when (setq found
|
||||
(find-method gf-object ':before (list class-name) nil))
|
||||
(find-method gf-object ':before (list 'T class-name) nil))
|
||||
(remove-method gf-object found))
|
||||
;; after method
|
||||
(when (setq found
|
||||
(find-method gf-object ':after (list class-name) nil))
|
||||
(find-method gf-object ':after (list 'T class-name) nil))
|
||||
(remove-method gf-object found))
|
||||
(when (null (generic-function-methods gf-object))
|
||||
(fmakunbound writer)))))))
|
||||
|
|
|
|||
|
|
@ -60,12 +60,12 @@
|
|||
(list 'quote (mapcar #'second slots))
|
||||
`(list ,@slots))))
|
||||
(let* ((slotd (first l))
|
||||
(initform (slotd-initform slotd)))
|
||||
(initform (getf slotd :initform nil)))
|
||||
(if (constantp initform)
|
||||
(setf (slotd-initform slotd) (si::maybe-unquote initform)
|
||||
(setf (getf slotd :initform nil) (si::maybe-unquote initform)
|
||||
slotd (list 'quote slotd))
|
||||
(setf slotd (mapcar #'(lambda (x) `',x) slotd)
|
||||
(slotd-initform slotd) (make-function-initform initform)
|
||||
(getf slotd :initform nil) (make-function-initform initform)
|
||||
slotd (list* 'list slotd)))
|
||||
(setf (first l) slotd)))
|
||||
(dolist (option args)
|
||||
|
|
|
|||
|
|
@ -9,6 +9,55 @@
|
|||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; slots
|
||||
|
||||
#|
|
||||
(defclass effective-slot-definition (slot-definition))
|
||||
|
||||
(defclass direct-slot-definition (slot-definition))
|
||||
|
||||
(defclass standard-slot-definition (slot-definition))
|
||||
|
||||
(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition))
|
||||
|
||||
(defclass standard-effective-slot-definition (standard-slot-definition direct-slot-definition))
|
||||
|#
|
||||
|
||||
(defun convert-one-class (class)
|
||||
(dolist (l (class-slots class))
|
||||
(let ((x (first l)))
|
||||
(when (consp x)
|
||||
(setf (first l)
|
||||
(apply #'make-instance 'standard-direct-slot-definition
|
||||
(slot-definition-to-list x))))))
|
||||
(dolist (l (class-slots class))
|
||||
(let ((x (first l)))
|
||||
(when (consp x)
|
||||
(setf (first l)
|
||||
(apply #'make-instance 'standard-effective-slot-definition
|
||||
(slot-definition-to-list x))))))
|
||||
(mapc #'convert-one-class (class-direct-subclasses class)))
|
||||
|
||||
(progn
|
||||
(eval `(defclass slot-definition ()
|
||||
,(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) ())
|
||||
#|
|
||||
(convert-one-class (find-class 'slot-definition))
|
||||
(convert-one-class (find-class 'standard-class))
|
||||
(convert-one-class (find-class 't))
|
||||
|#
|
||||
(make-instances-obsolete (find-class 't))
|
||||
(convert-one-class (find-class 't))
|
||||
#+nil
|
||||
(eval (print `(defclass slot-definition ()
|
||||
,(mapcar #'(lambda (x) (butlast x 2)) +slot-definition-slots+)))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Fixup
|
||||
|
||||
|
|
|
|||
|
|
@ -24,14 +24,14 @@
|
|||
(incf si::*inspect-level*)
|
||||
(dolist (slotd local-slotds)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slotd-name slotd))
|
||||
(if (slot-boundp instance (clos::slotd-name slotd))
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slotd-name slotd))
|
||||
(slot-value instance (clos::slotd-name slotd)))
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
(slot-value instance (clos::slot-definition-name slotd)))
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
(slot-value instance (clos::slotd-name slotd)))))
|
||||
(slot-value instance (clos::slot-definition-name slotd)))))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
(si::inspect-indent)
|
||||
|
|
@ -43,14 +43,14 @@
|
|||
(incf si::*inspect-level*)
|
||||
(dolist (slotd class-slotds)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slotd-name slotd))
|
||||
(if (slot-boundp instance (clos::slotd-name slotd))
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slotd-name slotd))
|
||||
(slot-value instance (clos::slotd-name slotd)))
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
(slot-value instance (clos::slot-definition-name slotd)))
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
(slot-value instance (clos::slotd-name slotd)))))
|
||||
(slot-value instance (clos::slot-definition-name slotd)))))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
(si::inspect-indent)
|
||||
|
|
@ -66,15 +66,15 @@
|
|||
(incf si::*inspect-level*)
|
||||
(dolist (slotd local-slotds)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slotd-name slotd))
|
||||
(if (slot-boundp instance (clos::slotd-name slotd))
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slotd-name slotd))
|
||||
; (slot-value instance (clos::slotd-name slotd))
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
; (slot-value instance (clos::slotd-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
|
|
@ -91,15 +91,15 @@
|
|||
(incf si::*inspect-level*)
|
||||
(dolist (slotd local-slotds)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slotd-name slotd))
|
||||
(if (slot-boundp instance (clos::slotd-name slotd))
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slotd-name slotd))
|
||||
; (slot-value instance (clos::slotd-name slotd))
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
; (slot-value instance (clos::slotd-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
|
|
@ -115,7 +115,7 @@
|
|||
(progn
|
||||
(format t "The names of the local slots are:~%")
|
||||
(dolist (slotd local-slotds)
|
||||
(format t " ~S~%" (clos::slotd-name slotd))))
|
||||
(format t " ~S~%" (clos::slot-definition-name slotd))))
|
||||
(progn
|
||||
(format t "It has no local slots.~%")))
|
||||
(terpri)
|
||||
|
|
@ -123,7 +123,7 @@
|
|||
(progn
|
||||
(format t "The names of the class slots are:~%")
|
||||
(dolist (slotd class-slotds)
|
||||
(format t " ~S~%" (clos::slotd-name slotd))))
|
||||
(format t " ~S~%" (clos::slot-definition-name slotd))))
|
||||
(progn
|
||||
(format t "It has no class slots.~%")))
|
||||
(terpri)))
|
||||
|
|
@ -136,7 +136,7 @@
|
|||
(progn
|
||||
(format t "The names of the (local) slots are:~%")
|
||||
(dolist (slotd local-slotds)
|
||||
(format t " ~S~%" (clos::slotd-name slotd))))
|
||||
(format t " ~S~%" (clos::slot-definition-name slotd))))
|
||||
(progn
|
||||
(format t "It has no (local) slots.~%")))
|
||||
(terpri)))
|
||||
|
|
@ -149,7 +149,7 @@
|
|||
(progn
|
||||
(format t "The names of the (local) slots are:~%")
|
||||
(dolist (slotd local-slotds)
|
||||
(format t " ~S~%" (clos::slotd-name slotd))))
|
||||
(format t " ~S~%" (clos::slot-definition-name slotd))))
|
||||
(progn
|
||||
(format t "It has no (local) slots.~%")))
|
||||
(terpri)))
|
||||
|
|
@ -162,24 +162,24 @@
|
|||
(read-preserving-whitespace *query-io*)
|
||||
(si::inspect-read-line))
|
||||
(append local-slotds class-slotds)
|
||||
:key #'clos::slotd-name
|
||||
:key #'clos::slot-definition-name
|
||||
:test #'eq))))
|
||||
(if slotd
|
||||
(progn
|
||||
(incf si::*inspect-level*)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slotd-name slotd))
|
||||
(if (slot-boundp instance (clos::slotd-name slotd))
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slotd-name slotd))
|
||||
(slot-value instance (clos::slotd-name slotd)))
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
(slot-value instance (clos::slot-definition-name slotd)))
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
(slot-value instance (clos::slotd-name slotd))))
|
||||
(slot-value instance (clos::slot-definition-name slotd))))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
(terpri)
|
||||
(format t "~S is not a slot of the instance." (slotd-name slotd))
|
||||
(format t "~S is not a slot of the instance." (slot-definition-name slotd))
|
||||
(terpri)
|
||||
(terpri)))))
|
||||
|
||||
|
|
@ -190,26 +190,26 @@
|
|||
(read-preserving-whitespace *query-io*)
|
||||
(si::inspect-read-line))
|
||||
local-slotds
|
||||
:key #'clos::slotd-name
|
||||
:key #'clos::slot-definition-name
|
||||
:test #'eq))))
|
||||
(if slotd
|
||||
(progn
|
||||
(incf si::*inspect-level*)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slotd-name slotd))
|
||||
(if (slot-boundp instance (clos::slotd-name slotd))
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slotd-name slotd))
|
||||
; (slot-value instance (clos::slotd-name slotd))
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
; (slot-value instance (clos::slotd-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
(terpri)
|
||||
(format t "~S is not a slot of the instance." (slotd-name slotd))
|
||||
(format t "~S is not a slot of the instance." (slot-definition-name slotd))
|
||||
(terpri)
|
||||
(terpri)))))
|
||||
|
||||
|
|
@ -220,26 +220,26 @@
|
|||
(read-preserving-whitespace *query-io*)
|
||||
(si::inspect-read-line))
|
||||
local-slotds
|
||||
:key #'clos::slotd-name
|
||||
:key #'clos::slot-definition-name
|
||||
:test #'eq))))
|
||||
(if slotd
|
||||
(progn
|
||||
(incf si::*inspect-level*)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slotd-name slotd))
|
||||
(if (slot-boundp instance (clos::slotd-name slotd))
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slotd-name slotd))
|
||||
; (slot-value instance (clos::slotd-name slotd))
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
; (slot-value instance (clos::slotd-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
(terpri)
|
||||
(format t "~S is not a slot of the instance." (slotd-name slotd))
|
||||
(format t "~S is not a slot of the instance." (slot-definition-name slotd))
|
||||
(terpri)
|
||||
(terpri)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -652,8 +652,8 @@
|
|||
(unless entry
|
||||
(error "Can't optimize instance access. Report this as a bug."))
|
||||
(setq slot (find slot-name (slot-value class 'SLOTS)
|
||||
:key #'slotd-name))
|
||||
(if (and slot (eq :INSTANCE (slotd-allocation slot)))
|
||||
:key #'slot-definition-name))
|
||||
(if (and slot (eq :INSTANCE (slot-definition-allocation slot)))
|
||||
(let* (slot-entry slot-index)
|
||||
(unless (cdr entry)
|
||||
;; there is just one index-table for each different class
|
||||
|
|
@ -670,15 +670,15 @@
|
|||
(cddr entry)))
|
||||
(if new
|
||||
`(si:instance-set ,instance ,slot-index ,new)
|
||||
`(the ,(slotd-type slot)
|
||||
`(the ,(slot-definition-type slot)
|
||||
(si:instance-ref-safe ,instance ,slot-index))))
|
||||
;; dont'optimize shared slots
|
||||
(if new
|
||||
`(standard-instance-set ,new ,instance ',slot-name)
|
||||
`(standard-instance-get ,instance ',slot-name)))))
|
||||
|
||||
;(defun get-slotd-type (class slot)
|
||||
; (slotd-type (find slot (slot-value class 'SLOTS) :key #'slotd-name)))
|
||||
;(defun get-slot-definition-type (class slot)
|
||||
; (slot-definition-type (find slot (slot-value class 'SLOTS) :key #'slot-definition-name)))
|
||||
|
||||
(defun signal-slot-unbound (instance slot-name)
|
||||
(declare (si::c-local))
|
||||
|
|
|
|||
|
|
@ -21,9 +21,9 @@
|
|||
((endp slots)
|
||||
(values `(allocate-instance ,class) (nreverse initialization)))
|
||||
(let* ((slot (first slots))
|
||||
(slot-name (slotd-name slot)))
|
||||
(slot-name (slot-definition-name slot)))
|
||||
(when (or (and (null slot-names)
|
||||
(eq (slotd-allocation slot) :instance))
|
||||
(eq (slot-definition-allocation slot) :instance))
|
||||
(member slot-name slot-names))
|
||||
(push (if (slot-boundp object slot-name)
|
||||
`(setf (slot-value ,object ',slot-name)
|
||||
|
|
@ -83,7 +83,7 @@
|
|||
((null scan))
|
||||
(declare (fixnum i))
|
||||
(setq sv (si:instance-ref obj i))
|
||||
(print (slotd-name (car scan)) stream) (princ ": " stream)
|
||||
(print (slot-definition-name (car scan)) stream) (princ ": " stream)
|
||||
(if (si:sl-boundp sv)
|
||||
(prin1 sv stream)
|
||||
(prin1 "Unbound" stream))))
|
||||
|
|
@ -99,8 +99,8 @@
|
|||
(sv))
|
||||
((null scan))
|
||||
(declare (fixnum i))
|
||||
(print (slotd-name (car scan)) stream) (princ ": " stream)
|
||||
(case (slotd-name (car scan))
|
||||
(print (slot-definition-name (car scan)) stream) (princ ": " stream)
|
||||
(case (slot-definition-name (car scan))
|
||||
((superiors inferiors)
|
||||
(princ "(" stream)
|
||||
(do* ((scan (si:instance-ref obj i) (cdr scan))
|
||||
|
|
|
|||
|
|
@ -17,23 +17,53 @@
|
|||
|
||||
(defvar *slot-initform-lambdas* nil)
|
||||
|
||||
(defstruct (slotd (:type list))
|
||||
name initargs initform accessors readers writers allocation type
|
||||
documentation)
|
||||
(defconstant +slot-definition-slots+
|
||||
'((name :initarg :name :initform nil :accessor slot-definition-name)
|
||||
(initform :initarg :initform :initform nil :accessor slot-definition-initform)
|
||||
(initfunction :initarg :initfunction :initform nil :accessor slot-definition-initfunction)
|
||||
(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)
|
||||
(documentation :initarg :documentation :initform nil :accessor slot-definition-documentation)
|
||||
))
|
||||
|
||||
#|
|
||||
(defstruct (slot-definition (:type list))
|
||||
name initform initfunction type allocation initargs readers writers documentation)
|
||||
|#
|
||||
|
||||
(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 canonical-slot-to-direct-slot (slotd)
|
||||
(if (find-class 'slot-definition nil)
|
||||
(apply #'make-instance
|
||||
(apply #'direct-slot-definition-class 'standard-direct-slot-definition slotd)
|
||||
slotd)
|
||||
(apply #'make-simple-slotd slotd)))
|
||||
|
||||
(let ((accessors (mapcar #'first (mapcar #'last +slot-definition-slots+))))
|
||||
(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) (slot-value x name))))
|
||||
(setf (fdefinition `(setf ,f))
|
||||
#'(lambda (v x) (if (consp x) (setf (nth position x) v) (setf (slot-value x name) v)))))))
|
||||
|
||||
(defun PARSE-SLOT (slot)
|
||||
(declare (si::c-local))
|
||||
(let*((name nil)
|
||||
(initargs nil)
|
||||
(initform '+INITFORM-UNSUPPLIED+) ; default
|
||||
(accessors ())
|
||||
(readers ())
|
||||
(writers ())
|
||||
(allocation ':INSTANCE)
|
||||
(type 'T) ; default
|
||||
(documentation nil)
|
||||
(slotd (make-slotd)))
|
||||
|
||||
(documentation nil))
|
||||
(cond ((symbolp slot) (setq name slot))
|
||||
((null (cdr slot)) (setq name (car slot)))
|
||||
(t
|
||||
|
|
@ -60,32 +90,23 @@
|
|||
(case option
|
||||
(:initarg (push value initargs))
|
||||
(:initform (setq initform value))
|
||||
(:accessor (push value accessors))
|
||||
(:accessor (push value readers) (push `(setf ,value) writers))
|
||||
(:reader (push value readers))
|
||||
(:writer (push value writers))
|
||||
(:allocation (setq allocation value))
|
||||
(:type (setq type value))
|
||||
(:documentation (push value documentation)))))))
|
||||
|
||||
(setf (slotd-name slotd) name
|
||||
(slotd-initargs slotd) initargs
|
||||
(slotd-initform slotd) initform
|
||||
(slotd-accessors slotd) accessors
|
||||
(slotd-readers slotd) readers
|
||||
(slotd-writers slotd) writers
|
||||
(slotd-allocation slotd) allocation
|
||||
(slotd-type slotd) type
|
||||
(slotd-documentation slotd) documentation)
|
||||
|
||||
slotd))
|
||||
(list :name name :initform initform :initfunction nil :initargs initargs
|
||||
:readers readers :writers writers :allocation allocation
|
||||
:documentation documentation)))
|
||||
|
||||
(defun PARSE-SLOTS (slots)
|
||||
(do ((scan slots (cdr scan))
|
||||
(collect))
|
||||
((null scan) (nreverse collect))
|
||||
(let* ((slotd (parse-slot (first scan)))
|
||||
(name (slotd-name slotd)))
|
||||
(when (find name collect :key #'slotd-name)
|
||||
(name (second slotd)))
|
||||
(when (find name collect :key #'second)
|
||||
(si::simple-program-error
|
||||
"A definition for the slot ~S appeared twice in a DEFCLASS form"
|
||||
name))
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@
|
|||
(let* ((class (class-of instance)))
|
||||
;; initialize-instance slots
|
||||
(dolist (slotd (class-slots class))
|
||||
(let* ((slot-initargs (slotd-initargs slotd))
|
||||
(slot-name (slotd-name slotd)))
|
||||
(let* ((slot-initargs (slot-definition-initargs slotd))
|
||||
(slot-name (slot-definition-name slotd)))
|
||||
(or
|
||||
;; Try to initialize the slot from one of the initargs.
|
||||
(do ((l initargs) initarg val)
|
||||
|
|
@ -69,7 +69,7 @@
|
|||
(or (eq slot-names 'T)
|
||||
(member slot-name slot-names))
|
||||
(not (slot-boundp instance slot-name)))
|
||||
(let ((initform (slotd-initform slotd)))
|
||||
(let ((initform (slot-definition-initform slotd)))
|
||||
(unless (eq initform '+INITFORM-UNSUPPLIED+)
|
||||
(when (functionp initform)
|
||||
(setq initform (funcall initform)))
|
||||
|
|
@ -82,7 +82,7 @@
|
|||
;;;
|
||||
|
||||
(defun count-instance-slots (class)
|
||||
(count :instance (class-slots class) :key #'slotd-allocation))
|
||||
(count :instance (class-slots class) :key #'slot-definition-allocation))
|
||||
|
||||
(defmethod allocate-instance ((class class) &key)
|
||||
;; FIXME! Inefficient! We should keep a list of dependent classes.
|
||||
|
|
@ -123,27 +123,37 @@
|
|||
(dolist (slotd (class-slots class))
|
||||
(let ((found nil)
|
||||
(defaults '())
|
||||
(slotd-initargs (slotd-initargs slotd)))
|
||||
(dolist (key slotd-initargs)
|
||||
(slot-definition-initargs (slot-definition-initargs slotd)))
|
||||
(dolist (key slot-definition-initargs)
|
||||
(unless (eql (si::search-keyword initargs key) 'si::failed)
|
||||
(setq found t)))
|
||||
(unless found
|
||||
(dolist (scan (class-default-initargs class))
|
||||
(let ((initarg (first scan))
|
||||
(value (third scan)))
|
||||
(when (member initarg slotd-initargs)
|
||||
(when (member initarg slot-definition-initargs)
|
||||
(setf initargs
|
||||
(list* initarg (if (functionp value) (funcall value) value)
|
||||
initargs))
|
||||
(return)))))))
|
||||
initargs)
|
||||
|
||||
(defmethod direct-slot-definition-class ((class T) &rest canonicalized-slot)
|
||||
(find-class 'standard-direct-slot-definition nil))
|
||||
|
||||
(defmethod effective-slot-definition-class ((class T) &rest canonicalized-slot)
|
||||
(find-class 'standard-effective-slot-definition nil))
|
||||
|
||||
(defmethod initialize-instance ((class class) &rest initargs
|
||||
&key direct-superclasses)
|
||||
&key direct-superclasses direct-slots)
|
||||
|
||||
;; this sets up all the slots of the class
|
||||
(call-next-method)
|
||||
|
||||
;; the list of direct slots is converted to direct-slot-definitions
|
||||
(setf (class-direct-slots class)
|
||||
(mapcar #'canonical-slot-to-direct-slot direct-slots))
|
||||
|
||||
;; set up inheritance checking that it makes sense
|
||||
(dolist (l (setf (class-direct-superclasses class)
|
||||
(check-direct-superclasses class direct-superclasses)))
|
||||
|
|
@ -242,34 +252,52 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;; whenever possible, in the same position as in C1.
|
||||
;;
|
||||
(do* ((all-slots (mapappend #'class-direct-slots (reverse (class-precedence-list class))))
|
||||
(all-names (nreverse (mapcar #'slotd-name all-slots)))
|
||||
(all-names (nreverse (mapcar #'slot-definition-name all-slots)))
|
||||
(output '())
|
||||
(scan all-names (cdr scan)))
|
||||
((endp scan) output)
|
||||
(let ((name (first scan)))
|
||||
(unless (find name (rest scan))
|
||||
(push (compute-effective-slot-definition
|
||||
class name (delete name (reverse all-slots) :key #'slotd-name
|
||||
class name (delete name (reverse all-slots) :key #'slot-definition-name
|
||||
:test-not #'eq))
|
||||
output)))))
|
||||
|
||||
(defun slot-definition-to-list (slotd)
|
||||
(list :name (slot-definition-name slotd)
|
||||
:initform (slot-definition-initform slotd)
|
||||
:initfunction (slot-definition-initfunction slotd)
|
||||
:type (slot-definition-type slotd)
|
||||
:allocation (slot-definition-allocation slotd)
|
||||
:initargs (slot-definition-initargs slotd)
|
||||
:readers (slot-definition-readers slotd)
|
||||
:writers (slot-definition-writers slotd)
|
||||
:documentation (slot-definition-documentation slotd)))
|
||||
|
||||
(defmethod compute-effective-slot-definition ((class class) name direct-slots)
|
||||
(flet ((combine-slotds (new-slotd old-slotd)
|
||||
(let* ((new-type (slotd-type new-slotd))
|
||||
(old-type (slotd-type old-slotd)))
|
||||
(setf (slotd-initargs new-slotd)
|
||||
(union (slotd-initargs new-slotd)
|
||||
(slotd-initargs old-slotd)))
|
||||
(when (eq (slotd-initform new-slotd) '+INITFORM-UNSUPPLIED+)
|
||||
(setf (slotd-initform new-slotd) (slotd-initform old-slotd)))
|
||||
(setf (slotd-type new-slotd)
|
||||
(flet ((direct-to-effective (old-slot)
|
||||
(if (consp old-slot)
|
||||
(copy-list old-slot)
|
||||
(let ((initargs (slot-definition-to-list old-slot)))
|
||||
(apply #'make-instance
|
||||
(apply #'effective-slot-definition-class class initargs)
|
||||
initargs))))
|
||||
(combine-slotds (new-slotd old-slotd)
|
||||
(let* ((new-type (slot-definition-type new-slotd))
|
||||
(old-type (slot-definition-type old-slotd)))
|
||||
(setf (slot-definition-initargs new-slotd)
|
||||
(union (slot-definition-initargs new-slotd)
|
||||
(slot-definition-initargs old-slotd)))
|
||||
(when (eq (slot-definition-initform new-slotd) '+INITFORM-UNSUPPLIED+)
|
||||
(setf (slot-definition-initform new-slotd) (slot-definition-initform old-slotd)))
|
||||
(setf (slot-definition-type new-slotd)
|
||||
;; FIXME! we should be more smart then this:
|
||||
(cond ((subtypep new-type old-type) new-type)
|
||||
((subtypep old-type new-type) old-type)
|
||||
(T `(and ,new-type ,old-type))))
|
||||
new-slotd)))
|
||||
(reduce #'combine-slotds (rest direct-slots)
|
||||
:initial-value (copy-list (first direct-slots)))))
|
||||
:initial-value (direct-to-effective (first direct-slots)))))
|
||||
|
||||
(defmethod compute-default-initargs ((class class))
|
||||
(let ((all-initargs (mapappend #'class-direct-default-initargs
|
||||
|
|
@ -331,12 +359,12 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(shared-index -1))
|
||||
(declare (fixnum local-index shared-index))
|
||||
(dolist (slot slots)
|
||||
(let* ((name (slotd-name slot))
|
||||
(allocation (slotd-allocation slot))
|
||||
(let* ((name (slot-definition-name slot))
|
||||
(allocation (slot-definition-allocation slot))
|
||||
location)
|
||||
(cond ((eq allocation :INSTANCE) ; local slot
|
||||
(setq location (incf local-index)))
|
||||
((find name direct-slots :key #'slotd-name) ; new shared slot
|
||||
((find name direct-slots :key #'slot-definition-name) ; new shared slot
|
||||
(setq location (cons class (incf shared-index))))
|
||||
(t ; inherited shared slot
|
||||
(dolist (c (class-precedence-list class))
|
||||
|
|
@ -368,12 +396,11 @@ because it contains a reference to the undefined class~% ~A"
|
|||
((endp slots))
|
||||
(declare (fixnum i))
|
||||
(let* ((slotd (first slots))
|
||||
(accessor (slotd-accessors slotd))
|
||||
(slot-name (slotd-name slotd))
|
||||
(slot-name (slot-definition-name slotd))
|
||||
(index i)
|
||||
reader setter)
|
||||
(declare (fixnum index))
|
||||
(if (eql (slotd-allocation slotd) :instance)
|
||||
(if (eql (slot-definition-allocation slotd) :instance)
|
||||
(setf reader #'(lambda (self)
|
||||
(let ((value (si:instance-ref self index)))
|
||||
(if (si:sl-boundp value)
|
||||
|
|
@ -386,13 +413,10 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(slot-value self slot-name))
|
||||
setter #'(lambda (value self)
|
||||
(setf (slot-value self slot-name) value))))
|
||||
(dolist (fname (append (slotd-accessors slotd) (slotd-readers slotd)))
|
||||
(dolist (fname (slot-definition-readers slotd))
|
||||
(install-method fname nil `(,standard-class) '(self) nil nil
|
||||
reader))
|
||||
(dolist (fname (slotd-accessors slotd))
|
||||
(install-method `(setf ,fname) nil `(nil ,standard-class) '(value self)
|
||||
nil nil setter))
|
||||
(dolist (fname (slotd-writers slotd))
|
||||
(dolist (fname (slot-definition-writers slotd))
|
||||
(install-method fname nil `(nil ,standard-class) '(value self)
|
||||
nil nil setter)))))
|
||||
|
||||
|
|
@ -454,8 +478,8 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;; print instance slots
|
||||
(format stream "~%it has the following instance slots")
|
||||
(dolist (slot slotds)
|
||||
(setq slotname (slotd-name slot))
|
||||
(case (slotd-allocation slot)
|
||||
(setq slotname (slot-definition-name slot))
|
||||
(case (slot-definition-allocation slot)
|
||||
(:INSTANCE
|
||||
(format stream "~%~A:~24,8T~A"
|
||||
slotname
|
||||
|
|
@ -467,8 +491,8 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;; print class slots
|
||||
(format stream "~%it has the following class slots")
|
||||
(dolist (slot slotds)
|
||||
(setq slotname (slotd-name slot))
|
||||
(unless (eq (slotd-allocation slot) :INSTANCE)
|
||||
(setq slotname (slot-definition-name slot))
|
||||
(unless (eq (slot-definition-allocation slot) :INSTANCE)
|
||||
(format stream "~%~A:~24,8T~A"
|
||||
slotname
|
||||
(if (slot-boundp obj slotname)
|
||||
|
|
@ -528,7 +552,7 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;; The initialization argument has been declared in some method
|
||||
((member name method-initargs))
|
||||
;; Check if the arguments is associated with a slot
|
||||
((find name slots :test #'member :key #'slotd-initargs))
|
||||
((find name slots :test #'member :key #'slot-definition-initargs))
|
||||
(t
|
||||
(setf unknown-key name)))))))
|
||||
|
||||
|
|
@ -592,8 +616,8 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(i 0 (1+ i)))
|
||||
((null scan))
|
||||
(declare (fixnum i))
|
||||
(print (slotd-name (car scan))) (princ ": ")
|
||||
(case (slotd-name (car scan))
|
||||
(print (slot-definition-name (car scan))) (princ ": ")
|
||||
(case (slot-definition-name (car scan))
|
||||
((SUPERIORS INFERIORS PRECEDENCE-LIST)
|
||||
(princ "(")
|
||||
(do* ((scan (si:instance-ref obj i) (cdr scan))
|
||||
|
|
|
|||
|
|
@ -869,12 +869,8 @@ by every function, which attempts to generate RENDER requests."
|
|||
|
||||
|
||||
;; $Log$
|
||||
;; Revision 1.10 2005-02-14 10:26:38 jjgarcia
|
||||
;; + Fixes in the code for backquoted vectors `#(,a ,b ...)
|
||||
;; + Fixes in the compiler code for CATCH and VALUES
|
||||
;; + Slight improvement in the readability of compiled CATCH
|
||||
;; + Implemented lisp hooks for cleaning on exit.
|
||||
;; + Improvements in the help messages from "configure"
|
||||
;; Revision 1.11 2005-02-25 16:17:39 jjgarcia
|
||||
;; Implemented SLOT-DEFINITION objects together with the associated protocols (Field position still missing).
|
||||
;;
|
||||
;; Revision 1.1 2004/06/10 07:59:31 jlr
|
||||
;; Portable CLX library imported
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue