;;;; 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 (get-instance-hash-code)))
(no-of-slots (wrapper-no-of-instance-slots wrapper)))
(setf (std-instance-wrapper instance) wrapper)
(setf (std-instance-slots instance)
(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
(defun allocate-funcallable-instance (wrapper &optional
(slots-init nil slots-init-p))
- (let ((fin (allocate-funcallable-instance-1)))
+ (let ((fin (%make-pcl-funcallable-instance nil nil
+ (get-instance-hash-code))))
(set-funcallable-instance-function
fin
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S has not been set."
fin)))
;;;; 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
slot-class-wrapper slot-class
built-in-class-wrapper built-in-class
structure-class-wrapper structure-class
+ condition-class-wrapper condition-class
standard-direct-slot-definition-wrapper
standard-direct-slot-definition
standard-effective-slot-definition-wrapper
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
+ slot-class built-in-class structure-class condition-class std-class
standard-direct-slot-definition standard-effective-slot-definition
class-eq-specializer standard-generic-function)
;; First, make a class metaobject for each of the early classes. For
(funcallable-standard-class
funcallable-standard-class-wrapper)
(built-in-class built-in-class-wrapper)
- (structure-class structure-class-wrapper)))
+ (structure-class structure-class-wrapper)
+ (condition-class condition-class-wrapper)))
(class (or (find-class name nil)
(allocate-standard-instance wrapper))))
- (when (or (eq meta 'standard-class)
- (eq meta 'funcallable-standard-class))
- (inform-type-system-about-std-class name))
(setf (find-class name) class)))
(dolist (definition *early-class-definitions*)
(let ((name (ecd-class-name definition))
built-in-class-wrapper)
((eq class structure-class)
structure-class-wrapper)
+ ((eq class condition-class)
+ condition-class-wrapper)
((eq class class-eq-specializer)
class-eq-specializer-wrapper)
((eq class standard-generic-function)
(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)
(!bootstrap-initialize-class
meta
class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper))
+ (condition-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
name
value)))
- (set-slot 'source *load-truename*)
+ (set-slot 'source *load-pathname*)
(set-slot 'type 'standard)
(set-slot 'documentation "The standard method combination.")
(set-slot 'options ()))
(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
&optional
- proto direct-slots slots direct-default-initargs default-initargs)
+ (proto nil proto-p)
+ 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)))
(set-slot 'name name)
+ (set-slot 'finalized-p t)
(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?
,@(and default-initargs
`(default-initargs ,default-initargs))))
(when (memq metaclass-name '(standard-class funcallable-standard-class
- structure-class slot-class std-class))
+ structure-class condition-class
+ slot-class std-class))
(set-slot 'direct-slots direct-slots)
(set-slot 'slots slots)
(set-slot 'initialize-info nil))
- (if (eq metaclass-name 'structure-class)
- (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
- (set-slot 'predicate-name (or (cadr (assoc name
- *early-class-predicates*))
- (make-class-predicate-name name)))
- (set-slot 'defstruct-form
- `(defstruct (structure-object (:constructor
- ,constructor-sym))))
- (set-slot 'defstruct-constructor constructor-sym)
- (set-slot 'from-defclass-p t)
- (set-slot 'plist nil)
- (set-slot 'prototype (funcall constructor-sym)))
- (set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
+
+ ;; For all direct superclasses SUPER of CLASS, make sure CLASS is
+ ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
+ ;; matter here for the slot DIRECT-SUBCLASSES, since every class
+ ;; inherits the slot from class CLASS.
+ (dolist (super direct-supers)
+ (let* ((super (find-class super))
+ (subclasses (!bootstrap-get-slot metaclass-name super
+ 'direct-subclasses)))
+ (cond ((eq +slot-unbound+ subclasses)
+ (!bootstrap-set-slot metaclass-name super 'direct-subclasses
+ (list class)))
+ ((not (memq class subclasses))
+ (!bootstrap-set-slot metaclass-name super 'direct-subclasses
+ (cons class subclasses))))))
+
+ (case metaclass-name
+ (structure-class
+ (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
+ (set-slot 'predicate-name (or (cadr (assoc name
+ *early-class-predicates*))
+ (make-class-predicate-name name)))
+ (set-slot 'defstruct-form
+ `(defstruct (structure-object (:constructor
+ ,constructor-sym)
+ (:copier nil))))
+ (set-slot 'defstruct-constructor constructor-sym)
+ (set-slot 'from-defclass-p t)
+ (set-slot 'plist nil)
+ (set-slot 'prototype (funcall constructor-sym))))
+ (condition-class
+ (set-slot 'prototype (make-condition name)))
+ (t
+ (set-slot 'prototype
+ (if proto-p proto (allocate-standard-instance wrapper)))))
class))
(defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p)
(!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)))))))))))
+ (list (slot-reader-name slot-name))
+ (list (slot-writer-name slot-name))
+ (list (slot-boundp-name slot-name)))))))))))
(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
(multiple-value-bind (accessor-class make-method-function arglist specls doc)
(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
;; 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*."
(dolist (e *built-in-classes*)
(destructuring-bind (name supers subs cpl prototype) e
(let* ((class (find-class name))
- (lclass (cl:find-class name))
- (wrapper (sb-kernel:class-layout lclass)))
+ (lclass (find-classoid name))
+ (wrapper (classoid-layout lclass)))
(set (get-built-in-class-symbol name) class)
(set (get-built-in-wrapper-symbol name) wrapper)
- (setf (sb-kernel:class-pcl-class lclass) class)
+ (setf (classoid-pcl-class lclass) class)
(!bootstrap-initialize-class 'built-in-class class
name class-eq-wrapper nil
(make-class-predicate class (class-predicate-name class))))))
\f
(defmacro wrapper-of-macro (x)
- `(sb-kernel:layout-of ,x))
+ `(layout-of ,x))
(defun class-of (x)
(wrapper-class* (wrapper-of-macro x)))
(defun wrapper-of (x)
(wrapper-of-macro x))
-(defvar *find-structure-class* nil)
-
(defun eval-form (form)
- #'(lambda () (eval form)))
-
-(defun slot-initargs-from-structure-slotd (slotd)
- `(:name ,(structure-slotd-name slotd)
- :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd)
- :internal-reader-function ,(structure-slotd-reader-function slotd)
- :internal-writer-function ,(structure-slotd-writer-function slotd)
- :type ,(or (structure-slotd-type slotd) t)
- :initform ,(structure-slotd-init-form slotd)
- :initfunction ,(eval-form (structure-slotd-init-form slotd))))
-
-(defun find-structure-class (symbol)
- (if (structure-type-p symbol)
- (unless (eq *find-structure-class* symbol)
- (let ((*find-structure-class* symbol))
- (ensure-class symbol
- :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-sys:lisp-stream)
- '(structure-object stream))
- ((structure-type-included-type-name symbol)
- (list (structure-type-included-type-name
- symbol))))
- :direct-slots
- (mapcar #'slot-initargs-from-structure-slotd
- (structure-type-slot-description-list
- symbol)))))
- (error "~S is not a legal structure class name." symbol)))
+ (lambda () (eval form)))
+
+(defun ensure-non-standard-class (name &optional existing-class)
+ (flet
+ ((ensure (metaclass &optional (slots nil slotsp))
+ (let ((supers
+ (mapcar #'classoid-name (classoid-direct-superclasses
+ (find-classoid name)))))
+ (if slotsp
+ (ensure-class-using-class existing-class name
+ :metaclass metaclass :name name
+ :direct-superclasses supers
+ :direct-slots slots)
+ (ensure-class-using-class existing-class name
+ :metaclass metaclass :name name
+ :direct-superclasses supers))))
+ (slot-initargs-from-structure-slotd (slotd)
+ (let ((accessor (structure-slotd-accessor-symbol slotd)))
+ `(:name ,(structure-slotd-name slotd)
+ :defstruct-accessor-symbol ,accessor
+ ,@(when (fboundp accessor)
+ `(:internal-reader-function
+ ,(structure-slotd-reader-function slotd)
+ :internal-writer-function
+ ,(structure-slotd-writer-function name slotd)))
+ :type ,(or (structure-slotd-type slotd) t)
+ :initform ,(structure-slotd-init-form slotd)
+ :initfunction ,(eval-form (structure-slotd-init-form slotd)))))
+ (slot-initargs-from-condition-slot (slot)
+ `(:name ,(condition-slot-name slot)
+ :initargs ,(condition-slot-initargs slot)
+ :readers ,(condition-slot-readers slot)
+ :writers ,(condition-slot-writers slot)
+ ,@(when (condition-slot-initform-p slot)
+ (let ((form-or-fun (condition-slot-initform slot)))
+ (if (functionp form-or-fun)
+ `(:initfunction ,form-or-fun)
+ `(:initform ,form-or-fun
+ :initfunction ,(lambda () form-or-fun)))))
+ :allocation (condition-slot-allocation slot)
+ :documentation (condition-slot-documentation slot))))
+ (cond ((structure-type-p name)
+ (ensure 'structure-class
+ (mapcar #'slot-initargs-from-structure-slotd
+ (structure-type-slot-description-list name))))
+ ((condition-type-p name)
+ (ensure 'condition-class
+ (mapcar #'slot-initargs-from-condition-slot
+ (condition-classoid-slots (find-classoid name)))))
+ (t
+ (error "~@<~S is not the name of a class.~@:>" name)))))
+
+(defun maybe-reinitialize-structure-class (classoid)
+ (let ((class (classoid-pcl-class classoid)))
+ (when class
+ (ensure-non-standard-class (class-name class) class))))
+
+(pushnew 'maybe-reinitialize-structure-class sb-kernel::*defstruct-hooks*)
\f
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name))
(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)))
;;; Set the inherits from CPL, and register the layout. This actually
;;; installs the class in the Lisp type system.
(defun update-lisp-class-layout (class layout)
- (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: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).
+ (let ((lclass (layout-classoid layout)))
+ (unless (eq (classoid-layout lclass) layout)
+ (setf (layout-inherits layout)
+ (order-layout-inherits
+ (map 'simple-vector #'class-wrapper
+ (reverse (rest (class-precedence-list class))))))
+ (register-layout layout :invalidate t)
+
+ ;; 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
- ;; best way to fix this is not to export CLASS-%NAME
- ;; from SB-KERNEL, but instead to move the whole
- ;; UPDATE-LISP-CLASS-LAYOUT function to SB-KERNEL, and
- ;; export it. (since it's also nasty for us to be
- ;; reaching into %KERNEL implementation details my
- ;; 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)
-
- ) ; EVAL-WHEN
+ (setf (find-classoid name) lclass
+ (classoid-name lclass) name)))))
+
+(defun set-class-type-translation (class name)
+ (let ((classoid (find-classoid name nil)))
+ (etypecase classoid
+ (null)
+ (built-in-classoid
+ (let ((translation (built-in-classoid-translation classoid)))
+ (cond
+ (translation
+ (aver (ctype-p translation))
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) translation)))
+ (t
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid))))))
+ (classoid
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid))))))
+
+(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 (layout-classoid layout))
+ (lclass-pcl-class (classoid-pcl-class lclass))
+ (olclass (find-classoid name nil)))
+ (if lclass-pcl-class
+ (aver (eq class lclass-pcl-class))
+ (setf (classoid-pcl-class lclass) class))
+
+ (update-lisp-class-layout class layout)
+
+ (cond (olclass
+ (aver (eq lclass olclass)))
+ (t
+ (setf (find-classoid name) lclass)))
+
+ (set-class-type-translation class name)))
+
+(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))
+
+(defmethod no-next-method ((generic-function standard-generic-function)
+ (method standard-method) &rest args)
+ (error "~@<There is no next method for the generic function ~2I~_~S~
+ ~I~_when called from method ~2I~_~S~I~_with arguments ~2I~_~S.~:>"
+ generic-function
+ method
+ args))
+
+;;; An extension to the ANSI standard: in the presence of e.g. a
+;;; :BEFORE method, it would seem that going through
+;;; NO-APPLICABLE-METHOD is prohibited, as in fact there is an
+;;; applicable method. -- CSR, 2002-11-15
+(defmethod no-primary-method (generic-function &rest args)
+ (error "~@<There is no primary method for the generic function ~2I~_~S~
+ ~I~_when called with arguments ~2I~_~S.~:>"
+ generic-function
+ args))