;;;; 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.
\f
(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)
(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))
;;;; 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
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
(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
(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)
: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
(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)))
(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
;; 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 "~@<There is no matching method for the generic function ~2I~_~S~
+ ~I~_when called with arguments ~2I~_~S.~:>"
+ generic-function
+ args))
projects / sbcl.git / blobdiff