From 39d35ffa386ddb7112e5ba447ffa59047b1c68d7 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Fri, 25 Feb 2005 16:16:57 +0000 Subject: [PATCH] Implemented SLOT-DEFINITION objects together with the associated protocols (Field position still missing). --- src/CHANGELOG | 7 +++ src/c/all_symbols.d | 7 ++- src/c/symbols_list.h | 15 +++++++ src/clos/boot.lsp | 21 ++++----- src/clos/builtin.lsp | 4 +- src/clos/change.lsp | 86 ++++++++++++------------------------ src/clos/defclass.lsp | 6 +-- src/clos/fixup.lsp | 49 +++++++++++++++++++++ src/clos/inspect.lsp | 90 ++++++++++++++++++------------------- src/clos/method.lsp | 10 ++--- src/clos/print.lsp | 10 ++--- src/clos/slot.lsp | 65 +++++++++++++++++---------- src/clos/standard.lsp | 100 ++++++++++++++++++++++++++---------------- src/clx/xrender.lisp | 8 +--- 14 files changed, 284 insertions(+), 194 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 14d7b19e9..536c5f723 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -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" diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 67af414f9..112c26aa3 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -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; diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index b0a5ee39a..371d7bb8e 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}}; diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index b1df1cdcd..ba533a86a 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -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)) ;;; diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp index 5eeca5d87..181dabf85 100644 --- a/src/clos/builtin.lsp +++ b/src/clos/builtin.lsp @@ -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) diff --git a/src/clos/change.lsp b/src/clos/change.lsp index 3d1ed09de..068de93a2 100644 --- a/src/clos/change.lsp +++ b/src/clos/change.lsp @@ -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))))))) diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index 59beb1e33..300b254c7 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -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) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 25366f265..046af55d5 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -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 diff --git a/src/clos/inspect.lsp b/src/clos/inspect.lsp index 91bab5637..b61bb5360 100644 --- a/src/clos/inspect.lsp +++ b/src/clos/inspect.lsp @@ -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))))) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 3f015a1a3..bcff55e63 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -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)) diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 19125d166..56ac930f6 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -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)) diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index 8705ee314..9e81aea83 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -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)) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index ec0aeab12..dfd08bd07 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -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)) diff --git a/src/clx/xrender.lisp b/src/clx/xrender.lisp index c37a2c2f6..f6b853fb5 100644 --- a/src/clx/xrender.lisp +++ b/src/clx/xrender.lisp @@ -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