X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=6b08ed17002cb110cd7d045f86dcf69aba27f013;hb=a3ab89c1db0dd9bfb911532ca134be16f16c4c1b;hp=307e5204f81a6b17e48b3b8861e18a8e5fa879ab;hpb=f2aa2d01b8d69f1c7bff18f86279d4f1018fe127;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 307e520..6b08ed1 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -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) @@ -63,8 +63,9 @@ (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 + (get-instance-hash-code)))) + (set-funcallable-instance-fun fin #'(sb-kernel:instance-lambda (&rest args) (declare (ignore args)) @@ -92,30 +93,24 @@ ;;;; 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* ((*create-classes-from-internal-structure-definitions-p* nil) @@ -131,7 +126,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 @@ -151,10 +146,7 @@ (built-in-class built-in-class-wrapper) (structure-class structure-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)) + (allocate-standard-instance wrapper)))) (setf (find-class name) class))) (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) @@ -252,7 +244,7 @@ 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 ())) @@ -302,6 +294,22 @@ (set-slot 'direct-slots direct-slots) (set-slot 'slots slots) (set-slot 'initialize-info nil)) + + ;; 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)))))) + (if (eq metaclass-name 'structure-class) (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) (set-slot 'predicate-name (or (cadr (assoc name @@ -388,9 +396,9 @@ (!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) @@ -517,7 +525,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) @@ -536,19 +544,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 @@ -565,12 +563,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))) @@ -593,9 +592,10 @@ (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) + (sb-kernel:order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest (class-precedence-list class)))))) + (sb-kernel:register-layout layout :invalidate t) ;; Subclasses of formerly forward-referenced-class may be ;; unknown to CL:FIND-CLASS and also anonymous. This @@ -643,3 +643,21 @@ ~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 "~@" + 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))