X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=307e5204f81a6b17e48b3b8861e18a8e5fa879ab;hb=b19093fa94d6e1785abee99c35c9a610e8777671;hp=2168017ef465f6a091ff90dc1ab3ceeddd2619c6;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 2168017..307e520 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -1,10 +1,10 @@ ;;;; bootstrapping the meta-braid ;;;; -;;;; The code in this file takes the early definitions that have been saved -;;;; up and actually builds those class objects. This work is largely driven -;;;; off of those class definitions, but the fact that STANDARD-CLASS is the -;;;; class of all metaclasses in the braid is built into this code pretty -;;;; deeply. +;;;; The code in this file takes the early definitions that have been +;;;; saved up and actually builds those class objects. This work is +;;;; largely driven off of those class definitions, but the fact that +;;;; STANDARD-CLASS is the class of all metaclasses in the braid is +;;;; built into this code pretty deeply. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -44,7 +44,7 @@ (i 0 (1+ i))) ((>= i no-of-slots)) ;endp rem-slots)) (declare (list rem-slots) - (type sb-int:index i)) + (type index i)) (setf (aref slots i) (first rem-slots))) slots)) (t @@ -118,11 +118,6 @@ classes))) (defun !bootstrap-meta-braid () - (let* ((name 'class) - (predicate-name (make-type-predicate-name name))) - (setf (gdefinition predicate-name) - #'(lambda (x) (declare (ignore x)) t)) - (do-satisfies-deftype name predicate-name)) (let* ((*create-classes-from-internal-structure-definitions-p* nil) std-class-wrapper std-class standard-class-wrapper standard-class @@ -197,7 +192,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) @@ -264,9 +259,6 @@ (setq *standard-method-combination* smc)))) ;;; Initialize a class metaobject. -;;; -;;; 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 @@ -277,7 +269,7 @@ (!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? @@ -317,7 +309,8 @@ (make-class-predicate-name name))) (set-slot 'defstruct-form `(defstruct (structure-object (:constructor - ,constructor-sym)))) + ,constructor-sym) + (:copier nil)))) (set-slot 'defstruct-constructor constructor-sym) (set-slot 'from-defclass-p t) (set-slot 'plist nil) @@ -410,7 +403,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 @@ -473,7 +466,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*." @@ -551,7 +544,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 @@ -562,14 +555,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) @@ -577,7 +562,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 @@ -589,7 +574,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 @@ -612,9 +597,9 @@ (reverse (rest (class-precedence-list class))))) (sb-kernel:register-layout layout :invalidate nil) - ;; Subclasses of formerly forward-referenced-class may be unknown - ;; to CL:FIND-CLASS and also anonymous. This functionality moved - ;; here from (SETF FIND-CLASS). + ;; Subclasses of formerly forward-referenced-class may be + ;; unknown to CL:FIND-CLASS and also anonymous. This + ;; functionality moved here from (SETF FIND-CLASS). (let ((name (class-name class))) (setf (cl:find-class name) lclass ;; FIXME: It's nasty to use double colons. Perhaps the @@ -626,42 +611,35 @@ ;; messing with raw CLASS-%NAME) (sb-kernel::class-%name lclass) name))))) -(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) - - (sb-int:dohash (name x *find-class*) - (let* ((class (find-class-from-cell name x)) - (layout (class-wrapper class)) - (lclass (sb-kernel:layout-class layout)) - (lclass-pcl-class (sb-kernel:class-pcl-class lclass)) - (olclass (cl:find-class name nil))) - (if lclass-pcl-class - (assert (eq class lclass-pcl-class)) - (setf (sb-kernel:class-pcl-class lclass) class)) - - (update-lisp-class-layout class layout) - - (cond (olclass - (assert (eq lclass olclass))) - (t - (setf (cl:find-class name) lclass))))) - - (setq *boot-state* 'braid) +(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) + +(dohash (name x *find-class*) + (let* ((class (find-class-from-cell name x)) + (layout (class-wrapper class)) + (lclass (sb-kernel:layout-class layout)) + (lclass-pcl-class (sb-kernel:class-pcl-class lclass)) + (olclass (cl:find-class name nil))) + (if lclass-pcl-class + (aver (eq class lclass-pcl-class)) + (setf (sb-kernel:class-pcl-class lclass) class)) + + (update-lisp-class-layout class layout) + + (cond (olclass + (aver (eq lclass olclass))) + (t + (setf (cl:find-class name) lclass))))) - ) ; EVAL-WHEN +(setq *boot-state* 'braid) (defmethod no-applicable-method (generic-function &rest args) - ;; FIXME: probably could be ERROR instead of CERROR - (cerror "Retry call to ~S." - "There is no matching method for the generic function ~S~@ - when called with arguments ~S." - generic-function - args) - (apply generic-function args)) + (error "~@" + generic-function + args))