X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=de4c4b6cec9b8e5971a51afef713b12ab01bd774;hb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;hp=d030e5b109768d641fb9af66cfcf4a73093300e7;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index d030e5b..de4c4b6 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. @@ -33,7 +33,7 @@ (defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p)) - (let ((instance (%%allocate-instance--class)) + (let ((instance (%make-standard-instance nil)) (no-of-slots (wrapper-no-of-instance-slots wrapper))) (setf (std-instance-wrapper instance) wrapper) (setf (std-instance-slots instance) @@ -63,8 +63,8 @@ (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) - (let ((fin (allocate-funcallable-instance-1))) - (set-funcallable-instance-function + (let ((fin (%make-pcl-funcallable-instance nil nil))) + (set-funcallable-instance-fun fin #'(sb-kernel:instance-lambda (&rest args) (declare (ignore args)) @@ -92,37 +92,26 @@ ;;;; BOOTSTRAP-META-BRAID ;;;; ;;;; This function builds the base metabraid from the early class definitions. -;;;; -;;;; FIXME: This, like lotso the other stuff in PCL, is not needed in target -;;;; Lisp, only at bootstrap time. Perhaps we should do something kludgy like -;;;; putting a special character (#\$, perhaps) at the beginning of each -;;;; needed-only-at-bootstrap-time symbol and then UNINTERN them all once we're -;;;; done bootstrapping? -(defmacro initial-classes-and-wrappers (&rest classes) +(defmacro !initial-classes-and-wrappers (&rest classes) `(progn - ,@(mapcar #'(lambda (class) - (let ((wr (intern (format nil "~A-WRAPPER" class) - *pcl-package*))) - `(setf ,wr ,(if (eq class 'standard-generic-function) - '*sgf-wrapper* - `(boot-make-wrapper - (early-class-size ',class) - ',class)) - ,class (allocate-standard-instance - ,(if (eq class 'standard-generic-function) - 'funcallable-standard-class-wrapper - 'standard-class-wrapper)) - (wrapper-class ,wr) ,class - (find-class ',class) ,class))) - classes))) + ,@(mapcar (lambda (class) + (let ((wr (intern (format nil "~A-WRAPPER" class) + *pcl-package*))) + `(setf ,wr ,(if (eq class 'standard-generic-function) + '*sgf-wrapper* + `(boot-make-wrapper + (early-class-size ',class) + ',class)) + ,class (allocate-standard-instance + ,(if (eq class 'standard-generic-function) + 'funcallable-standard-class-wrapper + 'standard-class-wrapper)) + (wrapper-class ,wr) ,class + (find-class ',class) ,class))) + 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 @@ -136,7 +125,7 @@ standard-effective-slot-definition class-eq-specializer-wrapper class-eq-specializer standard-generic-function-wrapper standard-generic-function) - (initial-classes-and-wrappers + (!initial-classes-and-wrappers standard-class funcallable-standard-class slot-class built-in-class structure-class std-class standard-direct-slot-definition standard-effective-slot-definition @@ -264,9 +253,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 @@ -525,7 +511,7 @@ (defvar *find-structure-class* nil) (defun eval-form (form) - #'(lambda () (eval form))) + (lambda () (eval form))) (defun slot-initargs-from-structure-slotd (slotd) `(:name ,(structure-slotd-name slotd) @@ -544,19 +530,9 @@ :metaclass 'structure-class :name symbol :direct-superclasses - (cond ;; Handle our CMU-CL-ish structure-based - ;; conditions. - ((cl:subtypep symbol 'condition) - (mapcar #'cl:class-name - (sb-kernel:class-direct-superclasses - (cl:find-class symbol)))) - ;; a hack to add the STREAM class as a - ;; mixin to the LISP-STREAM class. - ((eq symbol 'sb-kernel:lisp-stream) - '(structure-object stream)) - ((structure-type-included-type-name symbol) - (list (structure-type-included-type-name - symbol)))) + (mapcar #'cl:class-name + (sb-kernel:class-direct-superclasses + (cl:find-class symbol))) :direct-slots (mapcar #'slot-initargs-from-structure-slotd (structure-type-slot-description-list @@ -573,12 +549,13 @@ (let* ((default-method-function #'constantly-nil) (default-method-initargs (list :function default-method-function)) - (default-method (make-a-method 'standard-method - () - (list 'object) - (list *the-class-t*) - default-method-initargs - "class predicate default method"))) + (default-method (make-a-method + 'standard-method + () + (list 'object) + (list *the-class-t*) + default-method-initargs + "class predicate default method"))) (setf (method-function-get default-method-function :constant-value) nil) (add-method gf default-method))) @@ -601,13 +578,14 @@ (let ((lclass (sb-kernel:layout-class layout))) (unless (eq (sb-kernel:class-layout lclass) layout) (setf (sb-kernel:layout-inherits layout) - (map 'vector #'class-wrapper - (reverse (rest (class-precedence-list class))))) + (sb-kernel:order-layout-inherits + (map 'simple-vector #'class-wrapper + (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 @@ -619,42 +597,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) - - (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))))) - - (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))