From 2abf77f6c4c559a3e5b7fc351a4743305381feb6 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 30 Dec 2000 01:30:20 +0000 Subject: [PATCH] 0.6.9.13: (The "version broken" problem above was because the change in POLICY type was not binary compatible, and I didn't bump the version number, and I was crashing in some private .sbclrc code compiled under the old system. Oops..) The POLICY-QUALITY type no longer includes NULL. renamed more PCL stuff for unintern after warm init --- src/code/list.lisp | 42 ++++++++-------- src/compiler/ir1tran.lisp | 2 +- src/compiler/policy.lisp | 30 +++++++---- src/compiler/proclaim.lisp | 2 +- src/pcl/boot.lisp | 17 ++++--- src/pcl/braid.lisp | 118 ++++++++++++++++++++++---------------------- src/pcl/defclass.lisp | 75 ++++++++++++++-------------- src/pcl/dfun.lisp | 12 ++--- src/pcl/macros.lisp | 2 +- version.lisp-expr | 2 +- 10 files changed, 159 insertions(+), 143 deletions(-) diff --git a/src/code/list.lisp b/src/code/list.lisp index cc13b1a..c3812dc 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -490,36 +490,36 @@ (defun complement (function) #!+sb-doc "Builds a new function that returns T whenever FUNCTION returns NIL and - NIL whenever FUNCTION returns T." - #'(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p) - &rest more-args) - (not (cond (more-args (apply function arg0 arg1 arg2 more-args)) - (arg2-p (funcall function arg0 arg1 arg2)) - (arg1-p (funcall function arg0 arg1)) - (arg0-p (funcall function arg0)) - (t (funcall function)))))) + NIL whenever FUNCTION returns non-NIL." + (lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p) + &rest more-args) + (not (cond (more-args (apply function arg0 arg1 arg2 more-args)) + (arg2-p (funcall function arg0 arg1 arg2)) + (arg1-p (funcall function arg0 arg1)) + (arg0-p (funcall function arg0)) + (t (funcall function)))))) (defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p) &rest more-values) #!+sb-doc - "Builds a function that always returns VALUE, and posisbly MORE-VALUES." + "Builds a function that always returns VALUE, and possibly MORE-VALUES." (cond (more-values (let ((list (list* value val1 val2 more-values))) - #'(lambda () - (declare (optimize-interface (speed 3) (safety 0))) - (values-list list)))) - (val2-p - #'(lambda () + (lambda () (declare (optimize-interface (speed 3) (safety 0))) - (values value val1 val2))) + (values-list list)))) + (val2-p + (lambda () + (declare (optimize-interface (speed 3) (safety 0))) + (values value val1 val2))) (val1-p - #'(lambda () - (declare (optimize-interface (speed 3) (safety 0))) - (values value val1))) + (lambda () + (declare (optimize-interface (speed 3) (safety 0))) + (values value val1))) (t - #'(lambda () - (declare (optimize-interface (speed 3) (safety 0))) - value)))) + (lambda () + (declare (optimize-interface (speed 3) (safety 0))) + value)))) ;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index c402944..508e896 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1282,7 +1282,7 @@ ;;; body, otherwise do one binding and recurse on the rest. ;;; ;;; If INTERFACE is true, then we convert bindings with the interface -;;; policy. For real &AUX bindings, and implicit aux bindings +;;; policy. For real &AUX bindings, and for implicit aux bindings ;;; introduced by keyword bindings, this is always true. It is only ;;; false when LET* directly calls this function. (defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface) diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 0d880cc..3cdcfa9 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -12,7 +12,7 @@ (in-package "SB!C") ;;; a value for an optimization declaration -(def!type policy-quality () '(or (rational 0 3) null)) +(def!type policy-quality () '(rational 0 3)) ;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent ;;; the state of optimization policy at any point in compilation. This @@ -88,14 +88,24 @@ #+sb-xc-host (!policy-cold-init-or-resanify) ;;; Is X the name of an optimization quality? -(defun policy-quality-p (x) +(defun policy-quality-name-p (x) (memq x *policy-basic-qualities*)) -;;; Look up a named optimization quality in POLICY. -(declaim (ftype (function (policy symbol) policy-quality))) +;;; Look up a named optimization quality in POLICY. This is only +;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED; +;;; it's an error if it's called for a quality which isn't defined. +;;; +;;; FIXME: After this is debugged, it should get a DEFKNOWN. +#+nil (declaim (ftype (function (policy symbol) policy-quality))) (defun policy-quality (policy quality-name) - (the policy-quality - (cdr (assoc quality-name policy)))) + (let ((acons (assoc quality-name policy))) + (unless acons + (error "Argh! no such optimization quality ~S in~% ~S" + quality-name policy)) + (let ((result (cdr acons))) + (unless (typep result '(rational 0 3)) + (error "Argh! bogus optimization quality ~S" acons)) + result))) ;;; Return a list of symbols naming the optimization qualities which ;;; appear in EXPR. @@ -104,7 +114,7 @@ (labels ((recurse (x) (if (listp x) (map nil #'recurse x) - (when (policy-quality-p x) + (when (policy-quality-name-p x) (pushnew x result))))) (recurse expr) result))) @@ -120,12 +130,14 @@ ;;; them by name, e.g. (> SPEED SPACE). (defmacro policy (node expr) (let* ((n-policy (gensym)) + (used-qualities (policy-qualities-used-by expr)) (binds (mapcar (lambda (name) `(,name (policy-quality ,n-policy ',name))) - (policy-qualities-used-by expr)))) - (/show "in POLICY" expr binds) + used-qualities))) + (/show "in compile-time POLICY" expr binds) `(let* ((,n-policy (lexenv-policy ,(if node `(node-lexenv ,node) '*lexenv*))) ,@binds) + ;;(/show "in run-time POLICY" ,@used-qualities) ,expr))) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index d835f98..8545d00 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -78,7 +78,7 @@ (values q-and-v-or-just-q 3) (destructuring-bind (quality raw-value) q-and-v-or-just-q (values quality raw-value))) - (cond ((not (policy-quality-p quality)) + (cond ((not (policy-quality-name-p quality)) (compiler-warning "ignoring unknown optimization quality ~ ~S in ~S" quality spec)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 9334e5e..2ddea34 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1426,7 +1426,7 @@ bootstrapping. (early-collect-inheritance 'standard-generic-function))) (defvar *sgf-method-class-index* - (bootstrap-slot-index 'standard-generic-function 'method-class)) + (!bootstrap-slot-index 'standard-generic-function 'method-class)) (defun early-gf-p (x) (and (fsc-instance-p x) @@ -1434,19 +1434,19 @@ bootstrapping. +slot-unbound+))) (defvar *sgf-methods-index* - (bootstrap-slot-index 'standard-generic-function 'methods)) + (!bootstrap-slot-index 'standard-generic-function 'methods)) (defmacro early-gf-methods (gf) `(instance-ref (get-slots ,gf) *sgf-methods-index*)) (defvar *sgf-arg-info-index* - (bootstrap-slot-index 'standard-generic-function 'arg-info)) + (!bootstrap-slot-index 'standard-generic-function 'arg-info)) (defmacro early-gf-arg-info (gf) `(instance-ref (get-slots ,gf) *sgf-arg-info-index*)) (defvar *sgf-dfun-state-index* - (bootstrap-slot-index 'standard-generic-function 'dfun-state)) + (!bootstrap-slot-index 'standard-generic-function 'dfun-state)) (defstruct (arg-info (:conc-name nil) @@ -1684,8 +1684,11 @@ bootstrapping. (error "The function of the funcallable-instance ~S~ has not been set." fin))))) (setf (gdefinition spec) fin) - (bootstrap-set-slot 'standard-generic-function fin 'name spec) - (bootstrap-set-slot 'standard-generic-function fin 'source *load-truename*) + (!bootstrap-set-slot 'standard-generic-function fin 'name spec) + (!bootstrap-set-slot 'standard-generic-function + fin + 'source + *load-truename*) (set-function-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) @@ -1722,7 +1725,7 @@ bootstrapping. (cons (cddr state))))) (defvar *sgf-name-index* - (bootstrap-slot-index 'standard-generic-function 'name)) + (!bootstrap-slot-index 'standard-generic-function 'name)) (defun early-gf-name (gf) (instance-ref (get-slots gf) *sgf-name-index*)) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index c99a787..000103f 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -117,7 +117,7 @@ (find-class ',class) ,class))) classes))) -(defun bootstrap-meta-braid () +(defun !bootstrap-meta-braid () (let* ((name 'class) (predicate-name (make-type-predicate-name name))) (setf (gdefinition predicate-name) @@ -216,47 +216,47 @@ (allocate-standard-instance wrapper))) (setq direct-slots - (bootstrap-make-slot-definitions + (!bootstrap-make-slot-definitions name class direct-slots standard-direct-slot-definition-wrapper nil)) (setq slots - (bootstrap-make-slot-definitions + (!bootstrap-make-slot-definitions name class slots standard-effective-slot-definition-wrapper t)) (case meta ((std-class standard-class funcallable-standard-class) - (bootstrap-initialize-class + (!bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper proto direct-slots slots direct-default-initargs default-initargs)) (built-in-class ; *the-class-t* - (bootstrap-initialize-class + (!bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper proto)) (slot-class ; *the-class-slot-object* - (bootstrap-initialize-class + (!bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper proto)) (structure-class ; *the-class-structure-object* - (bootstrap-initialize-class + (!bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper)))))))) (let* ((smc-class (find-class 'standard-method-combination)) - (smc-wrapper (bootstrap-get-slot 'standard-class - smc-class - 'wrapper)) + (smc-wrapper (!bootstrap-get-slot 'standard-class + smc-class + 'wrapper)) (smc (allocate-standard-instance smc-wrapper))) (flet ((set-slot (name value) - (bootstrap-set-slot 'standard-method-combination - smc - name - value))) + (!bootstrap-set-slot 'standard-method-combination + smc + name + value))) (set-slot 'source *load-truename*) (set-slot 'type 'standard) (set-slot 'documentation "The standard method combination.") @@ -267,14 +267,14 @@ ;;; ;;; FIXME: This and most stuff in this file is probably only needed at init ;;; time. -(defun bootstrap-initialize-class +(defun !bootstrap-initialize-class (metaclass-name class name class-eq-wrapper source direct-supers direct-subclasses cpl wrapper &optional proto direct-slots slots direct-default-initargs default-initargs) (flet ((classes (names) (mapcar #'find-class names)) (set-slot (slot-name value) - (bootstrap-set-slot metaclass-name class slot-name value))) + (!bootstrap-set-slot metaclass-name class slot-name value))) (set-slot 'name name) (set-slot 'source source) (set-slot 'type (if (eq class (find-class 't)) @@ -282,10 +282,10 @@ `(class ,class))) (set-slot 'class-eq-specializer (let ((spec (allocate-standard-instance class-eq-wrapper))) - (bootstrap-set-slot 'class-eq-specializer spec 'type - `(class-eq ,class)) - (bootstrap-set-slot 'class-eq-specializer spec 'object - class) + (!bootstrap-set-slot 'class-eq-specializer spec 'type + `(class-eq ,class)) + (!bootstrap-set-slot 'class-eq-specializer spec 'object + class) spec)) (set-slot 'class-precedence-list (classes cpl)) (set-slot 'can-precede-list (classes (cdr cpl))) @@ -321,15 +321,15 @@ (set-slot 'prototype (or proto (allocate-standard-instance wrapper)))) class)) -(defun bootstrap-make-slot-definitions (name class slots wrapper effective-p) +(defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p) (let ((index -1)) - (mapcar #'(lambda (slot) - (incf index) - (bootstrap-make-slot-definition - name class slot wrapper effective-p index)) + (mapcar (lambda (slot) + (incf index) + (!bootstrap-make-slot-definition + name class slot wrapper effective-p index)) slots))) -(defun bootstrap-make-slot-definition +(defun !bootstrap-make-slot-definition (name class slot wrapper effective-p index) (let* ((slotd-class-name (if effective-p 'standard-effective-slot-definition @@ -338,15 +338,15 @@ (slot-name (getf slot :name))) (flet ((get-val (name) (getf slot name)) (set-val (name val) - (bootstrap-set-slot slotd-class-name slotd name val))) - (set-val 'name slot-name) + (!bootstrap-set-slot slotd-class-name slotd name val))) + (set-val 'name slot-name) (set-val 'initform (get-val :initform)) (set-val 'initfunction (get-val :initfunction)) (set-val 'initargs (get-val :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 'type (or (get-val :type) t)) (set-val 'documentation (or (get-val :documentation) "")) (set-val 'class class) (when effective-p @@ -371,7 +371,7 @@ (setq *the-eslotd-funcallable-standard-class-slots* slotd)) slotd))) -(defun bootstrap-accessor-definitions (early-p) +(defun !bootstrap-accessor-definitions (early-p) (let ((*early-p* early-p)) (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) @@ -382,20 +382,20 @@ (let ((slot-name (getf slotd :name)) (readers (getf slotd :readers)) (writers (getf slotd :writers))) - (bootstrap-accessor-definitions1 + (!bootstrap-accessor-definitions1 name slot-name readers writers nil) - (bootstrap-accessor-definitions1 + (!bootstrap-accessor-definitions1 'slot-object slot-name (list (slot-reader-symbol slot-name)) (list (slot-writer-symbol slot-name)) (list (slot-boundp-symbol slot-name))))))))))) -(defun bootstrap-accessor-definition (class-name accessor-name slot-name type) +(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type) (multiple-value-bind (accessor-class make-method-function arglist specls doc) (ecase type (reader (values 'standard-reader-method @@ -429,31 +429,31 @@ doc slot-name)))))) -(defun bootstrap-accessor-definitions1 (class-name +(defun !bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps) (flet ((do-reader-definition (reader) - (bootstrap-accessor-definition class-name - reader - slot-name - 'reader)) + (!bootstrap-accessor-definition class-name + reader + slot-name + 'reader)) (do-writer-definition (writer) - (bootstrap-accessor-definition class-name - writer - slot-name - 'writer)) + (!bootstrap-accessor-definition class-name + writer + slot-name + 'writer)) (do-boundp-definition (boundp) - (bootstrap-accessor-definition class-name - boundp - slot-name - 'boundp))) + (!bootstrap-accessor-definition class-name + boundp + slot-name + 'boundp))) (dolist (reader readers) (do-reader-definition reader)) (dolist (writer writers) (do-writer-definition writer)) (dolist (boundp boundps) (do-boundp-definition boundp)))) -(defun bootstrap-class-predicates (early-p) +(defun !bootstrap-class-predicates (early-p) (let ((*early-p* early-p)) (dolist (definition *early-class-definitions*) (let* ((name (ecd-class-name definition)) @@ -461,7 +461,7 @@ (setf (find-class-predicate name) (make-class-predicate class (class-predicate-name class))))))) -(defun bootstrap-built-in-classes () +(defun !bootstrap-built-in-classes () ;; First make sure that all the supers listed in ;; *BUILT-IN-CLASS-LATTICE* are themselves defined by @@ -494,11 +494,11 @@ (set (get-built-in-wrapper-symbol name) wrapper) (setf (sb-kernel:class-pcl-class lclass) class) - (bootstrap-initialize-class 'built-in-class class - name class-eq-wrapper nil - supers subs - (cons name cpl) - wrapper prototype))))) + (!bootstrap-initialize-class 'built-in-class class + name class-eq-wrapper nil + supers subs + (cons name cpl) + wrapper prototype))))) (dolist (e *built-in-classes*) (let* ((name (car e)) @@ -625,12 +625,12 @@ (eval-when (:load-toplevel :execute) (clrhash *find-class*) - (bootstrap-meta-braid) - (bootstrap-accessor-definitions t) - (bootstrap-class-predicates t) - (bootstrap-accessor-definitions nil) - (bootstrap-class-predicates nil) - (bootstrap-built-in-classes) + (!bootstrap-meta-braid) + (!bootstrap-accessor-definitions t) + (!bootstrap-class-predicates t) + (!bootstrap-accessor-definitions nil) + (!bootstrap-class-predicates nil) + (!bootstrap-built-in-classes) (sb-int:dohash (name x *find-class*) (let* ((class (find-class-from-cell name x)) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 96aa2fa..99fcb3d 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -25,9 +25,9 @@ ;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. ;;; -;;; The original motiviation for this function was to deal with the bug in -;;; the Genera compiler that prevents lambda expressions in top-level forms -;;; other than DEFUN from being compiled. +;;; The original motiviation for this function was to deal with the +;;; bug in the Genera compiler that prevents lambda expressions in +;;; top-level forms other than DEFUN from being compiled. ;;; ;;; Now this function is used to grab other functionality as well. This ;;; includes: @@ -68,15 +68,15 @@ (collect-forms forms) (cons 'progn progn-form)))) -;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. -;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta- -;;; braid is set up, LOAD-DEFCLASS has a special definition which simply -;;; collects all class definitions up, when the metabraid is initialized it -;;; is done from those class definitions. +;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is +;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until +;;; the meta-braid is set up, LOAD-DEFCLASS has a special definition +;;; which simply collects all class definitions up, when the metabraid +;;; is initialized it is done from those class definitions. ;;; -;;; After the metabraid has been setup, and the protocol for defining classes -;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the -;;; file defclass.lisp +;;; After the metabraid has been setup, and the protocol for defining +;;; classes has been defined, the real definition of LOAD-DEFCLASS is +;;; installed by the file defclass.lisp (defmacro defclass (name direct-superclasses direct-slots &rest options) (declare (indentation 2 4 3 1)) (expand-defclass name direct-superclasses direct-slots options)) @@ -146,8 +146,8 @@ ',*accessors*)))))) (if defstruct-p (progn - (eval defclass-form) ; define the class now, so that - `(progn ; the defstruct can be compiled. + (eval defclass-form) ; Define the class now, so that.. + `(progn ; ..the defstruct can be compiled. ,(class-defstruct-form (find-class name)) ,defclass-form)) (progn @@ -326,49 +326,50 @@ (nconc default-initargs (reverse (pop others))))))) (reverse default-initargs))) -(defun bootstrap-slot-index (class-name slot-name) +(defun !bootstrap-slot-index (class-name slot-name) (or (position slot-name (early-class-slots class-name)) (error "~S not found" slot-name))) -;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change the -;;; values of slots during bootstrapping. During bootstrapping, there are only -;;; two kinds of objects whose slots we need to access, CLASSes and -;;; SLOT-DEFINITIONs. The first argument to these functions tells whether the -;;; object is a CLASS or a SLOT-DEFINITION. +;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and +;;; change the values of slots during bootstrapping. During +;;; bootstrapping, there are only two kinds of objects whose slots we +;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument +;;; to these functions tells whether the object is a CLASS or a +;;; SLOT-DEFINITION. ;;; -;;; Note that the way this works it stores the slot in the same place in -;;; memory that the full object system will expect to find it later. This -;;; is critical to the bootstrapping process, the whole changeover to the -;;; full object system is predicated on this. +;;; Note that the way this works it stores the slot in the same place +;;; in memory that the full object system will expect to find it +;;; later. This is critical to the bootstrapping process, the whole +;;; changeover to the full object system is predicated on this. ;;; -;;; One important point is that the layout of standard classes and standard -;;; slots must be computed the same way in this file as it is by the full -;;; object system later. -(defmacro bootstrap-get-slot (type object slot-name) - `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name))) -(defun bootstrap-set-slot (type object slot-name new-value) - (setf (bootstrap-get-slot type object slot-name) new-value)) +;;; One important point is that the layout of standard classes and +;;; standard slots must be computed the same way in this file as it is +;;; by the full object system later. +(defmacro !bootstrap-get-slot (type object slot-name) + `(instance-ref (get-slots ,object) (!bootstrap-slot-index ,type ,slot-name))) +(defun !bootstrap-set-slot (type object slot-name new-value) + (setf (!bootstrap-get-slot type object slot-name) new-value)) (defun early-class-name (class) - (bootstrap-get-slot 'class class 'name)) + (!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))) (defun early-class-slotds (class) - (bootstrap-get-slot 'slot-class class 'slots)) + (!bootstrap-get-slot 'slot-class class 'slots)) (defun early-slot-definition-name (slotd) - (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name)) + (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'name)) (defun early-slot-definition-location (slotd) - (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) + (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) (defun early-accessor-method-slot-name (method) - (bootstrap-get-slot 'standard-accessor-method method 'slot-name)) + (!bootstrap-get-slot 'standard-accessor-method method 'slot-name)) (unless (fboundp 'class-name-of) (setf (symbol-function 'class-name-of) @@ -376,7 +377,7 @@ ;;; FIXME: Can we then delete EARLY-CLASS-NAME-OF? (defun early-class-direct-subclasses (class) - (bootstrap-get-slot 'class class 'direct-subclasses)) + (!bootstrap-get-slot 'class class 'direct-subclasses)) (declaim (notinline load-defclass)) (defun load-defclass diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 0df70c6..e1c28ba 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -730,12 +730,12 @@ And so, we are saved. (ecase type (reader #'(sb-kernel:instance-lambda (instance) (let* ((class (class-of instance)) - (class-name (bootstrap-get-slot 'class class 'name))) - (bootstrap-get-slot class-name instance slot-name)))) + (class-name (!bootstrap-get-slot 'class class 'name))) + (!bootstrap-get-slot class-name instance slot-name)))) (writer #'(sb-kernel:instance-lambda (new-value instance) (let* ((class (class-of instance)) - (class-name (bootstrap-get-slot 'class class 'name))) - (bootstrap-set-slot class-name instance slot-name new-value))))))) + (class-name (!bootstrap-get-slot 'class class 'name))) + (!bootstrap-set-slot class-name instance slot-name new-value))))))) (defun initial-dfun (gf args) (dfun-miss (gf args wrappers invalidp nemf ntype nindex) @@ -1205,10 +1205,10 @@ And so, we are saved. (defun order-specializers (specl1 specl2 index compare-classes-function) (let ((type1 (if (eq *boot-state* 'complete) (specializer-type specl1) - (bootstrap-get-slot 'specializer specl1 'type))) + (!bootstrap-get-slot 'specializer specl1 'type))) (type2 (if (eq *boot-state* 'complete) (specializer-type specl2) - (bootstrap-get-slot 'specializer specl2 'type)))) + (!bootstrap-get-slot 'specializer specl2 'type)))) (cond ((eq specl1 specl2) nil) ((atom type1) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 9f89a8c..119ae16 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -59,7 +59,7 @@ (defmacro posq (item list) `(position ,item ,list :test #'eq)) (defmacro neq (x y) `(not (eq ,x ,y))) -;;; FIXME: Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and CONSTANTLY-0 +;;; FIXME: Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and CONSTANTLY-0, ;;; and boost them up to SB-INT. (defun true (&rest ignore) (declare (ignore ignore)) t) (defun false (&rest ignore) (declare (ignore ignore)) nil) diff --git a/version.lisp-expr b/version.lisp-expr index 83b89b7..c0cda32 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.9.12" +"0.6.9.13" -- 1.7.10.4