X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=79dd636d03ba98f00fa5fcbc6be2c015ac2f08ff;hb=d5aafdd8ab6387e12bac187048ed322bc96fb79a;hp=bc7efc040ca7410e5c2071de069460760f167739;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index bc7efc0..79dd636 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -49,7 +49,7 @@ slots)) (t (make-array no-of-slots - :initial-element sb-pcl::*slot-unbound*)))) + :initial-element +slot-unbound+)))) instance)) (defmacro allocate-funcallable-instance-slots (wrapper &optional @@ -58,8 +58,8 @@ ,(if slots-init-p `(if ,slots-init-p (make-array no-of-slots :initial-contents ,slots-init) - (make-array no-of-slots :initial-element *slot-unbound*)) - `(make-array no-of-slots :initial-element *slot-unbound*)))) + (make-array no-of-slots :initial-element +slot-unbound+)) + `(make-array no-of-slots :initial-element +slot-unbound+)))) (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) @@ -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) @@ -197,7 +197,7 @@ (t (boot-make-wrapper (length slots) name)))) (proto nil)) - (when (eq name 't) (setq *the-wrapper-of-t* wrapper)) + (when (eq name t) (setq *the-wrapper-of-t* wrapper)) (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) *pcl-package*) class) @@ -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.") @@ -265,27 +265,31 @@ ;;; Initialize a class metaobject. ;;; -;;; FIXME: This and most stuff in this file is probably only needed at init -;;; time. -(defun bootstrap-initialize-class +;;; FIXME: This and most stuff in this file is probably only needed at +;;; init time. +(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)) + (set-slot 'type (if (eq class (find-class t)) t + ;; FIXME: Could this just be CLASS instead + ;; of `(CLASS ,CLASS)? If not, why not? + ;; (See also similar expression in + ;; SHARED-INITIALIZE :BEFORE (CLASS).) `(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 +325,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 +342,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 +375,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 +386,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 @@ -406,7 +410,7 @@ (writer (values 'standard-writer-method #'make-std-writer-method-function (list 'new-value class-name) - (list 't class-name) + (list t class-name) "automatically generated writer method")) (boundp (values 'standard-boundp-method #'make-std-boundp-method-function @@ -417,7 +421,7 @@ (if (find specls (early-gf-methods gf) :key #'early-method-specializers :test 'equal) - (unless (assoc accessor-name *generic-function-fixups* + (unless (assoc accessor-name *!generic-function-fixups* :test #'equal) (update-dfun gf)) (add-method gf @@ -429,31 +433,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 +465,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 @@ -469,7 +473,7 @@ ;; other sorts of brainos. (dolist (e *built-in-classes*) (dolist (super (cadr e)) - (unless (or (eq super 't) + (unless (or (eq super t) (assq super *built-in-classes*)) (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~ but ~S is not itself a class in *BUILT-IN-CLASSES*." @@ -494,11 +498,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)) @@ -547,7 +551,7 @@ (cl:find-class symbol)))) ;; a hack to add the STREAM class as a ;; mixin to the LISP-STREAM class. - ((eq symbol 'sb-sys:lisp-stream) + ((eq symbol 'sb-kernel:lisp-stream) '(structure-object stream)) ((structure-type-included-type-name symbol) (list (structure-type-included-type-name @@ -558,14 +562,6 @@ symbol))))) (error "~S is not a legal structure class name." symbol))) -(defun method-function-returning-nil (args next-methods) - (declare (ignore args next-methods)) - nil) - -(defun method-function-returning-t (args next-methods) - (declare (ignore args next-methods)) - t) - (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name)) (mlist (if (eq *boot-state* 'complete) @@ -573,7 +569,7 @@ (early-gf-methods gf)))) (unless mlist (unless (eq class *the-class-t*) - (let* ((default-method-function #'method-function-returning-nil) + (let* ((default-method-function #'constantly-nil) (default-method-initargs (list :function default-method-function)) (default-method (make-a-method 'standard-method @@ -585,7 +581,7 @@ (setf (method-function-get default-method-function :constant-value) nil) (add-method gf default-method))) - (let* ((class-method-function #'method-function-returning-t) + (let* ((class-method-function #'constantly-t) (class-method-initargs (list :function class-method-function)) (class-method (make-a-method 'standard-method @@ -625,12 +621,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))