(!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))
;;; 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)
*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
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))))
(!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)
(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))
(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))
(!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)))
;;; 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*)
\f
;;;; short method combinations
;;;; 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))
(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)))
"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
(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)))
((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))
(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
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))))
\f
;;;; 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))
(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))
(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
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
;; 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)
(method-class
:initarg :method-class
:accessor generic-function-method-class)
- (method-combination
+ (%method-combination
:initarg :method-combination
:accessor generic-function-method-combination)
(declarations
(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
: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) ())
(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)))
: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
:reader class-direct-subclasses)
(direct-methods
:initform (cons nil nil))
- (documentation
+ (%documentation
:initform nil
:initarg :documentation)
(finalized-p
;;; 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
;;; 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)
(early-class-direct-subclasses class))))))
(do-class (if (symbolp root)
(find-class root)
- root)))))
+ root)))
+ nil))
\f
(defvar *effective-method-cache* (make-hash-table :test 'eq))
;;; 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)))
(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))))
(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))))
\f
;;; 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)))
\f
;;; 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))
\f
;;; packages
(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)
(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
;;; 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))
\f
;;; Now that we have created the machinery for setting documentation, we can
;;; set the documentation for the machinery for setting documentation.
(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))
;;; 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))
(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))
(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"
; :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)))
||#
\f
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)
(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
(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
(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
(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)))))
(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)
&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)
(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))))
(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)))
(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))
;; 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))
(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)))
'(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))
'(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))
'(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 ()
;;; 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"
projects / sbcl.git / commitdiff