X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=9e65da9e73fd24a075b72c047a03c73c03990e53;hb=a53deb94a224bc903d00a5075acf562488cab06a;hp=c99a787063ba3fcda851a6337244016e86abcce2;hpb=f392742d2781f42b3bb15b637e5008e10fbbe092;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index c99a787..9e65da9 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 (get-instance-hash-code))) (no-of-slots (wrapper-no-of-instance-slots wrapper))) (setf (std-instance-wrapper instance) wrapper) (setf (std-instance-slots instance) @@ -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 @@ -63,10 +63,11 @@ (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))) @@ -92,37 +93,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))) - -(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)) + ,@(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* ((*create-classes-from-internal-structure-definitions-p* nil) std-class-wrapper std-class standard-class-wrapper standard-class @@ -130,15 +120,16 @@ 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 @@ -154,12 +145,10 @@ (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)) @@ -190,6 +179,8 @@ 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) @@ -197,13 +188,14 @@ (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) (dolist (slot slots) (unless (eq (getf slot :allocation :instance) :instance) - (error "Slot allocation ~S is not supported in bootstrap."))) + (error "Slot allocation ~S is not supported in bootstrap." + (getf slot :allocation)))) (when (typep wrapper 'wrapper) (setf (wrapper-instance-slots-layout wrapper) @@ -216,76 +208,84 @@ (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)) + (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-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))) - (set-slot 'source *load-truename*) + (!bootstrap-set-slot 'standard-method-combination + smc + name + value))) + (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 +(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))) + (!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? + ;; (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))) @@ -296,40 +296,63 @@ (set-slot 'wrapper wrapper) (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) (make-class-predicate-name name))) + (set-slot 'documentation nil) (set-slot 'plist `(,@(and direct-default-initargs `(direct-default-initargs ,direct-default-initargs)) ,@(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)))) + (set-slot 'slots slots)) + + ;; 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) +(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 +361,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 +394,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 +405,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))))))))))) + (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) +(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,14 +429,15 @@ (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 (list class-name) (list class-name) "automatically generated boundp method"))) - (let ((gf (ensure-generic-function accessor-name))) + (let ((gf (ensure-generic-function accessor-name + :lambda-list arglist))) (if (find specls (early-gf-methods gf) :key #'early-method-specializers :test 'equal) @@ -429,31 +453,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 +485,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 +493,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*." @@ -488,17 +512,17 @@ (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 - 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)) @@ -507,7 +531,7 @@ (make-class-predicate class (class-predicate-name class)))))) (defmacro wrapper-of-macro (x) - `(sb-kernel:layout-of ,x)) + `(layout-of ,x)) (defun class-of (x) (wrapper-class* (wrapper-of-macro x))) @@ -517,75 +541,87 @@ (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*) -(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)) + (let* ((gf (ensure-generic-function name :lambda-list '(object))) (mlist (if (eq *boot-state* 'complete) (generic-function-methods gf) (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 - () - (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* ((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 @@ -601,63 +637,105 @@ ;;; 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 "~@" + generic-function + args)) + +(defmethod no-next-method ((generic-function standard-generic-function) + (method standard-method) &rest args) + (error "~@" + 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 "~@" + generic-function + args)) + +(defmethod invalid-qualifiers ((gf generic-function) + combin + method) + (let ((qualifiers (method-qualifiers method))) + (let ((why (cond + ((cdr qualifiers) "has too many qualifiers") + (t (aver (not (member (car qualifiers) + '(:around :before :after)))) + "has an invalid qualifier")))) + (invalid-method-error + method + "The method ~S on ~S ~A.~%~ + Standard method combination requires all methods to have one~%~ + of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~ + have no qualifier at all." + method gf why))))