From 942e45e3bb73fd55786e4a0ab4590324063c0c89 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 13 Feb 2006 15:59:16 +0000 Subject: [PATCH] 0.9.9.27: Fix most use of slot-names colliding with external symbols / symbols accessible from CL-USER ... prefix most such slots by %; ... rename METHOD-COMBINATION-TYPE to -TYPE-NAME (as in AMOP FIND-METHOD-COMBINATION) ... only the TYPE slot in SPECIALIZER left to go, which is more complicated because in fact it's not a TYPE at all; more like a specifier (or maybe a typeoid) --- src/pcl/boot.lisp | 8 ++--- src/pcl/braid.lisp | 14 ++++---- src/pcl/defclass.lisp | 2 +- src/pcl/defcombin.lisp | 69 ++++++++++++++++++------------------- src/pcl/defs.lisp | 73 +++++++++++++++------------------------- src/pcl/dfun.lisp | 5 +-- src/pcl/documentation.lisp | 36 ++++++++++---------- src/pcl/generic-functions.lisp | 2 +- src/pcl/methods.lisp | 25 +++++++------- src/pcl/print-object.lisp | 6 ++-- src/pcl/std-class.lisp | 18 +++++----- src/pcl/time.lisp | 8 ++--- version.lisp-expr | 2 +- 13 files changed, 126 insertions(+), 142 deletions(-) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 38c5c93..46f45e0 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1779,8 +1779,8 @@ bootstrapping. (!bootstrap-slot-index 'standard-method 'specializers)) (defvar *sm-fast-function-index* (!bootstrap-slot-index 'standard-method 'fast-function)) -(defvar *sm-function-index* - (!bootstrap-slot-index 'standard-method 'function)) +(defvar *sm-%function-index* + (!bootstrap-slot-index 'standard-method '%function)) (defvar *sm-plist-index* (!bootstrap-slot-index 'standard-method 'plist)) @@ -1788,7 +1788,7 @@ bootstrapping. ;;; class and deal with it as appropriate. In fact we probably don't ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on ;;; the standard reader method for METHOD-SPECIALIZERS. Probably. -(dolist (s '(specializers fast-function function plist)) +(dolist (s '(specializers fast-function %function plist)) (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s))) (!bootstrap-slot-index 'standard-reader-method s) (!bootstrap-slot-index 'standard-writer-method s) @@ -1822,7 +1822,7 @@ bootstrapping. *the-class-standard-boundp-method*)) (class (class-of method))) (if (member class standard-method-classes) - (clos-slots-ref (get-slots method) *sm-function-index*) + (clos-slots-ref (get-slots method) *sm-%function-index*) (method-function method)))) (defun safe-method-qualifiers (method) (let ((standard-method-classes diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 4cf786b..6bed8f4 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -248,8 +248,8 @@ name value))) (set-slot 'source nil) - (set-slot 'type 'standard) - (set-slot 'documentation "The standard method combination.") + (set-slot 'type-name 'standard) + (set-slot '%documentation "The standard method combination.") (set-slot 'options ())) (setq *standard-method-combination* smc)))) @@ -280,7 +280,7 @@ (!bootstrap-set-slot 'class-eq-specializer spec 'object class) spec)) - (set-slot 'class-precedence-list (classes cpl)) + (set-slot '%class-precedence-list (classes cpl)) (set-slot 'cpl-available-p t) (set-slot 'can-precede-list (classes (cdr cpl))) (set-slot 'incompatible-superclass-list nil) @@ -288,7 +288,7 @@ (set-slot 'direct-subclasses (classes direct-subclasses)) (set-slot 'direct-methods (cons nil nil)) (set-slot 'wrapper wrapper) - (set-slot 'documentation nil) + (set-slot '%documentation nil) (set-slot 'plist `(,@(and direct-default-initargs `(direct-default-initargs ,direct-default-initargs)) @@ -358,9 +358,9 @@ (set-val 'readers (get-val :readers)) (set-val 'writers (get-val :writers)) (set-val 'allocation :instance) - (set-val 'type (or (get-val :type) t)) - (set-val 'documentation (or (get-val :documentation) "")) - (set-val 'class class) + (set-val '%type (or (get-val :type) t)) + (set-val '%documentation (or (get-val :documentation) "")) + (set-val '%class class) (when effective-p (set-val 'location index) (let ((fsc-p nil)) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 6a2bc19..045d847 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -436,7 +436,7 @@ (!bootstrap-get-slot 'class class 'name)) (defun early-class-precedence-list (class) - (!bootstrap-get-slot 'pcl-class class 'class-precedence-list)) + (!bootstrap-get-slot 'pcl-class class '%class-precedence-list)) (defun early-class-name-of (instance) (early-class-name (class-of instance))) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index c649f24..eac8820 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -42,11 +42,11 @@ ;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping ;;; reasons. (defmethod find-method-combination ((generic-function generic-function) - (type (eql 'standard)) + (type-name (eql 'standard)) options) (when options (method-combination-error - "The method combination type STANDARD accepts no options.")) + "STANDARD method combination accepts no options.")) *standard-method-combination*) ;;;; short method combinations @@ -57,21 +57,21 @@ ;;;; and runs the same rule. (defun expand-short-defcombin (whole) - (let* ((type (cadr whole)) + (let* ((type-name (cadr whole)) (documentation (getf (cddr whole) :documentation)) (identity-with-one-arg (getf (cddr whole) :identity-with-one-argument nil)) (operator - (getf (cddr whole) :operator type))) + (getf (cddr whole) :operator type-name))) `(load-short-defcombin - ',type ',operator ',identity-with-one-arg ',documentation + ',type-name ',operator ',identity-with-one-arg ',documentation (sb-c:source-location)))) -(defun load-short-defcombin (type operator ioa doc source-location) +(defun load-short-defcombin (type-name operator ioa doc source-location) (let* ((specializers (list (find-class 'generic-function) - (intern-eql-specializer type) + (intern-eql-specializer type-name) *the-class-t*)) (old-method (get-method #'find-method-combination () specializers nil)) @@ -80,23 +80,23 @@ (make-instance 'standard-method :qualifiers () :specializers specializers - :lambda-list '(generic-function type options) + :lambda-list '(generic-function type-name options) :function (lambda (args nms &rest cm-args) (declare (ignore nms cm-args)) (apply - (lambda (gf type options) + (lambda (gf type-name options) (declare (ignore gf)) (short-combine-methods - type options operator ioa new-method doc)) + type-name options operator ioa new-method doc)) args)) :definition-source source-location)) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) - (setf (random-documentation type 'method-combination) doc) - type)) + (setf (random-documentation type-name 'method-combination) doc) + type-name)) -(defun short-combine-methods (type options operator ioa method doc) +(defun short-combine-methods (type-name options operator ioa method doc) (cond ((null options) (setq options '(:most-specific-first))) ((equal options '(:most-specific-first))) ((equal options '(:most-specific-last))) @@ -105,9 +105,9 @@ "Illegal options to a short method combination type.~%~ The method combination type ~S accepts one option which~%~ must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." - type))) + type-name))) (make-instance 'short-method-combination - :type type + :type-name type-name :options options :operator operator :identity-with-one-argument ioa @@ -117,7 +117,7 @@ (defmethod compute-effective-method ((generic-function generic-function) (combin short-method-combination) applicable-methods) - (let ((type (method-combination-type combin)) + (let ((type-name (method-combination-type-name combin)) (operator (short-combination-operator combin)) (ioa (short-combination-identity-with-one-argument combin)) (order (car (method-combination-options combin))) @@ -132,7 +132,7 @@ ((cdr qualifiers) (invalid generic-function combin m)) ((eq (car qualifiers) :around) (push m around)) - ((eq (car qualifiers) type) + ((eq (car qualifiers) type-name) (push m primary)) (t (invalid generic-function combin m)))))) (setq around (nreverse around)) @@ -183,11 +183,11 @@ (combin short-method-combination) method) (let ((qualifiers (method-qualifiers method)) - (type (method-combination-type combin))) + (type-name (method-combination-type-name combin))) (let ((why (cond ((null qualifiers) "has no qualifiers") ((cdr qualifiers) "has too many qualifiers") - (t (aver (and (neq (car qualifiers) type) + (t (aver (and (neq (car qualifiers) type-name) (neq (car qualifiers) :around))) "has an invalid qualifier")))) (invalid-method-error @@ -197,12 +197,12 @@ short form of DEFINE-METHOD-COMBINATION and so requires~%~ all methods have either the single qualifier ~S or the~%~ single qualifier :AROUND." - method gf why type type)))) + method gf why type-name type-name)))) ;;;; long method combinations (defun expand-long-defcombin (form) - (let ((type (cadr form)) + (let ((type-name (cadr form)) (lambda-list (caddr form)) (method-group-specifiers (cadddr form)) (body (cddddr form)) @@ -214,17 +214,18 @@ (setq gf-var (cadr (pop body)))) (multiple-value-bind (documentation function) (make-long-method-combination-function - type lambda-list method-group-specifiers args-option gf-var + type-name lambda-list method-group-specifiers args-option gf-var body) - `(load-long-defcombin ',type ',documentation #',function + `(load-long-defcombin ',type-name ',documentation #',function ',args-option (sb-c:source-location))))) (defvar *long-method-combination-functions* (make-hash-table :test 'eq)) -(defun load-long-defcombin (type doc function args-lambda-list source-location) +(defun load-long-defcombin + (type-name doc function args-lambda-list source-location) (let* ((specializers (list (find-class 'generic-function) - (intern-eql-specializer type) + (intern-eql-specializer type-name) *the-class-t*)) (old-method (get-method #'find-method-combination () specializers nil)) @@ -232,37 +233,37 @@ (make-instance 'standard-method :qualifiers () :specializers specializers - :lambda-list '(generic-function type options) + :lambda-list '(generic-function type-name options) :function (lambda (args nms &rest cm-args) (declare (ignore nms cm-args)) (apply - (lambda (generic-function type options) + (lambda (generic-function type-name options) (declare (ignore generic-function)) (make-instance 'long-method-combination - :type type + :type-name type-name :options options :args-lambda-list args-lambda-list :documentation doc)) args)) :definition-source source-location))) - (setf (gethash type *long-method-combination-functions*) function) + (setf (gethash type-name *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) - (setf (random-documentation type 'method-combination) doc) - type)) + (setf (random-documentation type-name 'method-combination) doc) + type-name)) (defmethod compute-effective-method ((generic-function generic-function) (combin long-method-combination) applicable-methods) - (funcall (gethash (method-combination-type combin) + (funcall (gethash (method-combination-type-name combin) *long-method-combination-functions*) generic-function combin applicable-methods)) (defun make-long-method-combination-function - (type ll method-group-specifiers args-option gf-var body) - (declare (ignore type)) + (type-name ll method-group-specifiers args-option gf-var body) + (declare (ignore type-name)) (multiple-value-bind (real-body declarations documentation) (parse-body body) (let ((wrapped-body diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 8ecbb74..61f7cb7 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -316,9 +316,7 @@ definition-source-mixin metaobject funcallable-standard-object) - ((documentation - :initform nil - :initarg :documentation) + ((%documentation :initform nil :initarg :documentation) ;; We need to make a distinction between the methods initially set ;; up by :METHOD options to DEFGENERIC and the ones set up later by ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on @@ -330,9 +328,8 @@ ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp ;; tends to leave the generic function in a state consistent with ;; the most-recently-loaded state of a.lisp and b.lisp.) - (initial-methods - :initform () - :accessor generic-function-initial-methods)) + (initial-methods :initform () + :accessor generic-function-initial-methods)) (:metaclass funcallable-standard-class)) (defclass standard-generic-function (generic-function) @@ -347,7 +344,7 @@ (method-class :initarg :method-class :accessor generic-function-method-class) - (method-combination + (%method-combination :initarg :method-combination :accessor generic-function-method-combination) (declarations @@ -371,13 +368,14 @@ (defclass method (metaobject) ()) (defclass standard-method (definition-source-mixin plist-mixin method) - ((generic-function + ((%generic-function :initform nil :accessor method-generic-function) -;;; (qualifiers -;;; :initform () -;;; :initarg :qualifiers -;;; :reader method-qualifiers) + #+nil ; implemented by PLIST + (qualifiers + :initform () + :initarg :qualifiers + :reader method-qualifiers) (specializers :initform () :initarg :specializers @@ -386,24 +384,18 @@ :initform () :initarg :lambda-list :reader method-lambda-list) - (function - :initform nil - :initarg :function) ;no writer + (%function :initform nil :initarg :function) (fast-function :initform nil :initarg :fast-function ;no writer :reader method-fast-function) - (documentation - :initform nil - :initarg :documentation))) + (%documentation :initform nil :initarg :documentation))) (defclass standard-accessor-method (standard-method) - ((slot-name :initform nil - :initarg :slot-name + ((slot-name :initform nil :initarg :slot-name :reader accessor-method-slot-name) - (slot-definition :initform nil - :initarg :slot-definition - :reader accessor-method-slot-definition))) + (%slot-definition :initform nil :initarg :slot-definition + :reader accessor-method-slot-definition))) (defclass standard-reader-method (standard-accessor-method) ()) (defclass standard-writer-method (standard-accessor-method) ()) @@ -411,16 +403,13 @@ (defclass standard-boundp-method (standard-accessor-method) ()) (defclass method-combination (metaobject) - ((documentation - :reader method-combination-documentation - :initform nil - :initarg :documentation))) + ((%documentation :initform nil :initarg :documentation))) (defclass standard-method-combination (definition-source-mixin method-combination) - ((type - :reader method-combination-type - :initarg :type) + ((type-name + :reader method-combination-type-name + :initarg :type-name) (options :reader method-combination-options :initarg :options))) @@ -466,19 +455,13 @@ :initform nil :initarg :initargs :accessor slot-definition-initargs) - (type - :initform t - :initarg :type - :accessor slot-definition-type) - (documentation - :initform nil - :initarg :documentation - ;; FIXME: should we export this, as an extension? - :accessor %slot-definition-documentation) - (class - :initform nil - :initarg :class - :accessor slot-definition-class))) + (%type :initform t :initarg :type :accessor slot-definition-type) + (%documentation + :initform nil :initarg :documentation + ;; KLUDGE: we need a reader for bootstrapping purposes, in + ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS. + :reader %slot-definition-documentation) + (%class :initform nil :initarg :class :accessor slot-definition-class))) (defclass standard-slot-definition (slot-definition) ((allocation @@ -603,7 +586,7 @@ :reader class-direct-subclasses) (direct-methods :initform (cons nil nil)) - (documentation + (%documentation :initform nil :initarg :documentation) (finalized-p @@ -623,7 +606,7 @@ ;;; The class PCL-CLASS is an implementation-specific common ;;; superclass of all specified subclasses of the class CLASS. (defclass pcl-class (class) - ((class-precedence-list + ((%class-precedence-list :reader class-precedence-list) ;; KLUDGE: see note in CPL-OR-NIL (cpl-available-p diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 92e1018..251a5fa 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1224,7 +1224,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; function GF which reads/writes instances of class CLASS. ;;; TYPE is one of the symbols READER or WRITER. (defun find-standard-class-accessor-method (gf class type) - (let ((cpl (standard-slot-value/class class 'class-precedence-list)) + (let ((cpl (standard-slot-value/class class '%class-precedence-list)) (found-specializer *the-class-t*) (found-method nil)) (dolist (method (standard-slot-value/gf gf 'methods) found-method) @@ -1655,7 +1655,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (early-class-direct-subclasses class)))))) (do-class (if (symbolp root) (find-class root) - root))))) + root))) + nil)) (defvar *effective-method-cache* (make-hash-table :test 'eq)) diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index 08ef197..2f1d52b 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -14,12 +14,12 @@ ;;; functions, macros, and special forms (defmethod documentation ((x function) (doc-type (eql 't))) (if (typep x 'generic-function) - (slot-value x 'documentation) + (slot-value x '%documentation) (%fun-doc x))) (defmethod documentation ((x function) (doc-type (eql 'function))) (if (typep x 'generic-function) - (slot-value x 'documentation) + (slot-value x '%documentation) (%fun-doc x))) (defmethod documentation ((x list) (doc-type (eql 'function))) @@ -43,7 +43,7 @@ (defmethod (setf documentation) (new-value (x function) (doc-type (eql 't))) (if (typep x 'generic-function) - (setf (slot-value x 'documentation) new-value) + (setf (slot-value x '%documentation) new-value) (let ((name (%fun-name x))) (when (and name (typep name '(or symbol cons))) (setf (info :function :documentation name) new-value)))) @@ -52,7 +52,7 @@ (defmethod (setf documentation) (new-value (x function) (doc-type (eql 'function))) (if (typep x 'generic-function) - (setf (slot-value x 'documentation) new-value) + (setf (slot-value x '%documentation) new-value) (let ((name (%fun-name x))) (when (and name (typep name '(or symbol cons))) (setf (info :function :documentation name) new-value)))) @@ -79,22 +79,22 @@ ;;; method combinations (defmethod documentation ((x method-combination) (doc-type (eql 't))) - (slot-value x 'documentation)) + (slot-value x '%documentation)) (defmethod documentation ((x method-combination) (doc-type (eql 'method-combination))) - (slot-value x 'documentation)) + (slot-value x '%documentation)) (defmethod documentation ((x symbol) (doc-type (eql 'method-combination))) (random-documentation x 'method-combination)) (defmethod (setf documentation) (new-value (x method-combination) (doc-type (eql 't))) - (setf (slot-value x 'documentation) new-value)) + (setf (slot-value x '%documentation) new-value)) (defmethod (setf documentation) (new-value (x method-combination) (doc-type (eql 'method-combination))) - (setf (slot-value x 'documentation) new-value)) + (setf (slot-value x '%documentation) new-value)) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'method-combination))) @@ -102,11 +102,11 @@ ;;; methods (defmethod documentation ((x standard-method) (doc-type (eql 't))) - (slot-value x 'documentation)) + (slot-value x '%documentation)) (defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't))) - (setf (slot-value x 'documentation) new-value)) + (setf (slot-value x '%documentation) new-value)) ;;; packages @@ -132,16 +132,16 @@ (values (info :type :documentation (class-name x)))) (defmethod documentation ((x standard-class) (doc-type (eql 't))) - (slot-value x 'documentation)) + (slot-value x '%documentation)) (defmethod documentation ((x standard-class) (doc-type (eql 'type))) - (slot-value x 'documentation)) + (slot-value x '%documentation)) (defmethod documentation ((x symbol) (doc-type (eql 'type))) (or (values (info :type :documentation x)) (let ((class (find-class x nil))) (when class - (slot-value class 'documentation))))) + (slot-value class '%documentation))))) (defmethod documentation ((x symbol) (doc-type (eql 'structure))) (cond ((eq (info :type :kind x) :instance) @@ -164,19 +164,19 @@ (defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't))) - (setf (slot-value x 'documentation) new-value)) + (setf (slot-value x '%documentation) new-value)) (defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type))) - (setf (slot-value x 'documentation) new-value)) + (setf (slot-value x '%documentation) new-value)) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) (if (or (structure-type-p x) (condition-type-p x)) (setf (info :type :documentation x) new-value) (let ((class (find-class x nil))) (if class - (setf (slot-value class 'documentation) new-value) + (setf (slot-value class '%documentation) new-value) (setf (info :type :documentation x) new-value))))) (defmethod (setf documentation) (new-value @@ -219,12 +219,12 @@ ;;; extra-standard methods, for getting at slot documentation (defmethod documentation ((slotd standard-slot-definition) (doc-type (eql 't))) (declare (ignore doc-type)) - (slot-value slotd 'documentation)) + (slot-value slotd '%documentation)) (defmethod (setf documentation) (new-value (slotd standard-slot-definition) (doc-type (eql 't))) (declare (ignore doc-type)) - (setf (slot-value slotd 'documentation) new-value)) + (setf (slot-value slotd '%documentation) new-value)) ;;; Now that we have created the machinery for setting documentation, we can ;;; set the documentation for the machinery for setting documentation. diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 5692ff4..73462f1 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -104,7 +104,7 @@ (defgeneric method-combination-options (standard-method-combination)) -(defgeneric method-combination-type (standard-method-combination)) +(defgeneric method-combination-type-name (standard-method-combination)) (defgeneric method-fast-function (standard-method)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 879f26e..3fb6cd2 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -33,11 +33,11 @@ ;;; METHOD-FUNCTION ?? (defmethod method-function ((method standard-method)) - (or (slot-value method 'function) + (or (slot-value method '%function) (let ((fmf (slot-value method 'fast-function))) (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this. (error "~S doesn't seem to have a METHOD-FUNCTION." method)) - (setf (slot-value method 'function) + (setf (slot-value method '%function) (method-function-from-fast-function fmf))))) (defmethod accessor-method-class ((method standard-accessor-method)) @@ -182,21 +182,20 @@ (setf (plist-value method 'qualifiers) qualifiers) #+ignore (setf (slot-value method 'closure-generator) - (method-function-closure-generator (slot-value method 'function)))) + (method-function-closure-generator (slot-value method '%function)))) (defmethod shared-initialize :after ((method standard-accessor-method) slot-names &key) (declare (ignore slot-names)) - (with-slots (slot-name slot-definition) - method - (unless slot-definition + (with-slots (slot-name %slot-definition) method + (unless %slot-definition (let ((class (accessor-method-class method))) (when (slot-class-p class) - (setq slot-definition (find slot-name (class-direct-slots class) + (setq %slot-definition (find slot-name (class-direct-slots class) :key #'slot-definition-name))))) - (when (and slot-definition (null slot-name)) - (setq slot-name (slot-definition-name slot-definition))))) + (when (and %slot-definition (null slot-name)) + (setq slot-name (slot-definition-name %slot-definition))))) (defmethod method-qualifiers ((method standard-method)) (plist-value method 'qualifiers)) @@ -248,7 +247,7 @@ (initarg-error :method-combination method-combination "a method combination object"))) - ((slot-boundp generic-function 'method-combination)) + ((slot-boundp generic-function '%method-combination)) (t (initarg-error :method-combination "not supplied" @@ -276,9 +275,9 @@ ; :argument-precedence-order ; 'argument-precedence-order) ; (add-initarg declarations :declarations 'declarations) -; (add-initarg documentation :documentation 'documentation) +; (add-initarg documentation :documentation '%documentation) ; (add-initarg method-class :method-class 'method-class) -; (add-initarg method-combination :method-combination 'method-combination) +; (add-initarg method-combination :method-combination '%method-combination) (apply #'call-next-method generic-function initargs))) ||# @@ -553,7 +552,7 @@ in method ~S:~2I~_~S.~@:>" method qualifiers))) ((short-method-combination-p mc) - (let ((mc-name (method-combination-type mc))) + (let ((mc-name (method-combination-type-name mc))) (when (or (null qualifiers) (cdr qualifiers) (and (neq (car qualifiers) :around) diff --git a/src/pcl/print-object.lisp b/src/pcl/print-object.lisp index ed8be04..c1cde7e 100644 --- a/src/pcl/print-object.lisp +++ b/src/pcl/print-object.lisp @@ -67,7 +67,7 @@ (defmethod print-object ((method standard-method) stream) (print-unreadable-object (method stream :type t :identity t) - (if (slot-boundp method 'generic-function) + (if (slot-boundp method '%generic-function) (let ((generic-function (method-generic-function method))) (format stream "~S ~{~S ~}~:S" (and generic-function @@ -80,7 +80,7 @@ (defmethod print-object ((method standard-accessor-method) stream) (print-unreadable-object (method stream :type t :identity t) - (if (slot-boundp method 'generic-function) + (if (slot-boundp method '%generic-function) (let ((generic-function (method-generic-function method))) (format stream "~S, slot:~S, ~:S" (and generic-function @@ -93,7 +93,7 @@ (print-unreadable-object (mc stream :type t :identity t) (format stream "~S ~S" - (slot-value-or-default mc 'type) + (slot-value-or-default mc 'type-name) (slot-value-or-default mc 'options)))) (defun named-object-print-function (instance stream diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index f7ee4f1..d003364 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -72,7 +72,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class))) + (class (slot-value slotd '%class))) (let ((table (or (gethash name *name->class->slotd-table*) (setf (gethash name *name->class->slotd-table*) (make-hash-table :test 'eq :size 5))))) @@ -102,7 +102,7 @@ (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class)) + (class (slot-value slotd '%class)) (old-slotd (find-slot-definition class name)) (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) (multiple-value-bind (function std-p) @@ -519,7 +519,7 @@ &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) - (with-slots (wrapper class-precedence-list cpl-available-p + (with-slots (wrapper %class-precedence-list cpl-available-p prototype (direct-supers direct-superclasses)) class (setf (slot-value class 'direct-slots) @@ -529,7 +529,7 @@ (setf (classoid-pcl-class classoid) class) (setq direct-supers direct-superclasses) (setq wrapper (classoid-layout classoid)) - (setq class-precedence-list (compute-class-precedence-list class)) + (setq %class-precedence-list (compute-class-precedence-list class)) (setq cpl-available-p t) (add-direct-subclasses class direct-superclasses) (setf (slot-value class 'slots) (compute-slots class)))) @@ -589,7 +589,7 @@ (compute-effective-slot-definition class (slot-definition-name dslotd) (list dslotd))) (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (reverse (slot-value class '%class-precedence-list)))) (defmethod compute-slots :around ((class condition-class)) (let ((eslotds (call-next-method))) @@ -708,7 +708,7 @@ (setf (slot-value class 'defstruct-constructor) (make-defstruct-allocation-function class))) (add-direct-subclasses class direct-superclasses) - (setf (slot-value class 'class-precedence-list) + (setf (slot-value class '%class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'cpl-available-p) t) (setf (slot-value class 'slots) (compute-slots class)) @@ -848,11 +848,11 @@ ;; comment from the old CMU CL sources: ;; Need to have the cpl setup before update-lisp-class-layout ;; is called on CMU CL. - (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class '%class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t) (force-cache-flushes class)) (progn - (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class '%class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t))) (update-class-can-precede-p cpl)) @@ -1044,7 +1044,7 @@ (slot-definition-name dslotd) (list dslotd))) (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (reverse (slot-value class '%class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method))) diff --git a/src/pcl/time.lisp b/src/pcl/time.lisp index 6cd2be2..b7a4e95 100644 --- a/src/pcl/time.lisp +++ b/src/pcl/time.lisp @@ -22,7 +22,7 @@ '(time-slot-value m 'plist 10000)) *tests*) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" - '(time-slot-value m 'generic-function 10000)) + '(time-slot-value m '%generic-function 10000)) *tests*) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (structure)" '(time-slot-value str 'slot 10000)) @@ -34,7 +34,7 @@ '(time-slot-value-function m 10000)) *tests*) (defun time-slot-value-function (object n) - (time (dotimes-fixnum (i n) (slot-value object 'function)))) + (time (dotimes-fixnum (i n) (slot-value object '%function)))) (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)" '(time-slot-value-slot str 10000)) @@ -129,14 +129,14 @@ '(pprint (expand-all-macros (expand-defmethod-internal 'meth-standard-slot-value nil '((object standard-method)) - '((lambda () (slot-value object 'function))) + '((lambda () (slot-value object '%function))) nil)))) *tests*) (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)." '(disassemble (meth-standard-slot-value m))) *tests*) (defmethod meth-standard-slot-value ((object standard-method)) - (lambda () (slot-value object 'function))) + (lambda () (slot-value object '%function))) ||# (defun run-tests () diff --git a/version.lisp-expr b/version.lisp-expr index ab39446..77fb146 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.9.26" +"0.9.9.27" -- 1.7.10.4