1 ;;;; bootstrapping the meta-braid
3 ;;;; The code in this file takes the early definitions that have been
4 ;;;; saved up and actually builds those class objects. This work is
5 ;;;; largely driven off of those class definitions, but the fact that
6 ;;;; STANDARD-CLASS is the class of all metaclasses in the braid is
7 ;;;; built into this code pretty deeply.
9 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; more information.
12 ;;;; This software is derived from software originally released by Xerox
13 ;;;; Corporation. Copyright and release statements follow. Later modifications
14 ;;;; to the software are in the public domain and are provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
18 ;;;; copyright information from original PCL sources:
20 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
21 ;;;; All rights reserved.
23 ;;;; Use and copying of this software and preparation of derivative works based
24 ;;;; upon this software are permitted. Any distribution of this software or
25 ;;;; derivative works must comply with all applicable United States export
28 ;;;; This software is made available AS IS, and Xerox Corporation makes no
29 ;;;; warranty about the software, its performance or its conformity to any
34 (defun allocate-standard-instance (wrapper
35 &optional
(slots-init nil slots-init-p
))
36 (let ((instance (%make-standard-instance nil
(get-instance-hash-code)))
37 (no-of-slots (wrapper-no-of-instance-slots wrapper
)))
38 (setf (std-instance-wrapper instance
) wrapper
)
39 (setf (std-instance-slots instance
)
41 ;; Inline the slots vector allocation and initialization.
42 (let ((slots (make-array no-of-slots
:initial-element
0)))
43 (do ((rem-slots slots-init
(rest rem-slots
))
45 ((>= i no-of-slots
)) ;endp rem-slots))
46 (declare (list rem-slots
)
48 (setf (aref slots i
) (first rem-slots
)))
51 (make-array no-of-slots
52 :initial-element
+slot-unbound
+))))
55 (defmacro allocate-funcallable-instance-slots
(wrapper &optional
56 slots-init-p slots-init
)
57 `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper
)))
60 (make-array no-of-slots
:initial-contents
,slots-init
)
61 (make-array no-of-slots
:initial-element
+slot-unbound
+))
62 `(make-array no-of-slots
:initial-element
+slot-unbound
+))))
64 (defun allocate-funcallable-instance (wrapper &optional
65 (slots-init nil slots-init-p
))
66 (let ((fin (%make-pcl-funcallable-instance nil nil
67 (get-instance-hash-code))))
68 (set-funcallable-instance-function
70 #'(instance-lambda (&rest args
)
71 (declare (ignore args
))
72 (error "The function of the funcallable-instance ~S has not been set."
74 (setf (fsc-instance-wrapper fin
) wrapper
75 (fsc-instance-slots fin
) (allocate-funcallable-instance-slots
76 wrapper slots-init-p slots-init
))
79 (defun allocate-structure-instance (wrapper &optional
80 (slots-init nil slots-init-p
))
81 (let* ((class (wrapper-class wrapper
))
82 (constructor (class-defstruct-constructor class
)))
84 (let ((instance (funcall constructor
))
85 (slots (class-slots class
)))
88 (setf (slot-value-using-class class instance slot
)
91 (error "can't allocate an instance of class ~S" (class-name class
)))))
93 ;;;; BOOTSTRAP-META-BRAID
95 ;;;; This function builds the base metabraid from the early class definitions.
97 (defmacro !initial-classes-and-wrappers
(&rest classes
)
99 ,@(mapcar (lambda (class)
100 (let ((wr (format-symbol *pcl-package
* "~A-WRAPPER" class
)))
101 `(setf ,wr
,(if (eq class
'standard-generic-function
)
104 (early-class-size ',class
)
106 ,class
(allocate-standard-instance
107 ,(if (eq class
'standard-generic-function
)
108 'funcallable-standard-class-wrapper
109 'standard-class-wrapper
))
110 (wrapper-class ,wr
) ,class
111 (find-class ',class
) ,class
)))
114 (defun !bootstrap-meta-braid
()
115 (let* ((*create-classes-from-internal-structure-definitions-p
* nil
)
116 std-class-wrapper std-class
117 standard-class-wrapper standard-class
118 funcallable-standard-class-wrapper funcallable-standard-class
119 slot-class-wrapper slot-class
120 built-in-class-wrapper built-in-class
121 structure-class-wrapper structure-class
122 condition-class-wrapper condition-class
123 standard-direct-slot-definition-wrapper
124 standard-direct-slot-definition
125 standard-effective-slot-definition-wrapper
126 standard-effective-slot-definition
127 class-eq-specializer-wrapper class-eq-specializer
128 standard-generic-function-wrapper standard-generic-function
)
129 (!initial-classes-and-wrappers
130 standard-class funcallable-standard-class
131 slot-class built-in-class structure-class condition-class std-class
132 standard-direct-slot-definition standard-effective-slot-definition
133 class-eq-specializer standard-generic-function
)
134 ;; First, make a class metaobject for each of the early classes. For
135 ;; each metaobject we also set its wrapper. Except for the class T,
136 ;; the wrapper is always that of STANDARD-CLASS.
137 (dolist (definition *early-class-definitions
*)
138 (let* ((name (ecd-class-name definition
))
139 (meta (ecd-metaclass definition
))
141 (slot-class slot-class-wrapper
)
142 (std-class std-class-wrapper
)
143 (standard-class standard-class-wrapper
)
144 (funcallable-standard-class
145 funcallable-standard-class-wrapper
)
146 (built-in-class built-in-class-wrapper
)
147 (structure-class structure-class-wrapper
)
148 (condition-class condition-class-wrapper
)))
149 (class (or (find-class name nil
)
150 (allocate-standard-instance wrapper
))))
151 (setf (find-class name
) class
)))
152 (dolist (definition *early-class-definitions
*)
153 (let ((name (ecd-class-name definition
))
154 (meta (ecd-metaclass definition
))
155 (source (ecd-source definition
))
156 (direct-supers (ecd-superclass-names definition
))
157 (direct-slots (ecd-canonical-slots definition
))
158 (other-initargs (ecd-other-initargs definition
)))
159 (let ((direct-default-initargs
160 (getf other-initargs
:direct-default-initargs
)))
161 (multiple-value-bind (slots cpl default-initargs direct-subclasses
)
162 (early-collect-inheritance name
)
163 (let* ((class (find-class name
))
164 (wrapper (cond ((eq class slot-class
)
166 ((eq class std-class
)
168 ((eq class standard-class
)
169 standard-class-wrapper
)
170 ((eq class funcallable-standard-class
)
171 funcallable-standard-class-wrapper
)
172 ((eq class standard-direct-slot-definition
)
173 standard-direct-slot-definition-wrapper
)
175 standard-effective-slot-definition
)
176 standard-effective-slot-definition-wrapper
)
177 ((eq class built-in-class
)
178 built-in-class-wrapper
)
179 ((eq class structure-class
)
180 structure-class-wrapper
)
181 ((eq class condition-class
)
182 condition-class-wrapper
)
183 ((eq class class-eq-specializer
)
184 class-eq-specializer-wrapper
)
185 ((eq class standard-generic-function
)
186 standard-generic-function-wrapper
)
188 (boot-make-wrapper (length slots
) name
))))
190 (when (eq name t
) (setq *the-wrapper-of-t
* wrapper
))
191 (set (make-class-symbol name
) class
)
193 (unless (eq (getf slot
:allocation
:instance
) :instance
)
194 (error "Slot allocation ~S is not supported in bootstrap."
195 (getf slot
:allocation
))))
197 (when (typep wrapper
'wrapper
)
198 (setf (wrapper-instance-slots-layout wrapper
)
199 (mapcar #'canonical-slot-name slots
))
200 (setf (wrapper-class-slots wrapper
)
203 (setq proto
(if (eq meta
'funcallable-standard-class
)
204 (allocate-funcallable-instance wrapper
)
205 (allocate-standard-instance wrapper
)))
208 (!bootstrap-make-slot-definitions
209 name class direct-slots
210 standard-direct-slot-definition-wrapper nil
))
212 (!bootstrap-make-slot-definitions
214 standard-effective-slot-definition-wrapper t
))
217 ((std-class standard-class funcallable-standard-class
)
218 (!bootstrap-initialize-class
220 class name class-eq-specializer-wrapper source
221 direct-supers direct-subclasses cpl wrapper proto
222 direct-slots slots direct-default-initargs default-initargs
))
223 (built-in-class ; *the-class-t*
224 (!bootstrap-initialize-class
226 class name class-eq-specializer-wrapper source
227 direct-supers direct-subclasses cpl wrapper proto
))
228 (slot-class ; *the-class-slot-object*
229 (!bootstrap-initialize-class
231 class name class-eq-specializer-wrapper source
232 direct-supers direct-subclasses cpl wrapper proto
))
233 (structure-class ; *the-class-structure-object*
234 (!bootstrap-initialize-class
236 class name class-eq-specializer-wrapper source
237 direct-supers direct-subclasses cpl wrapper
))
239 (!bootstrap-initialize-class
241 class name class-eq-specializer-wrapper source
242 direct-supers direct-subclasses cpl wrapper
))))))))
244 (let* ((smc-class (find-class 'standard-method-combination
))
245 (smc-wrapper (!bootstrap-get-slot
'standard-class
248 (smc (allocate-standard-instance smc-wrapper
)))
249 (flet ((set-slot (name value
)
250 (!bootstrap-set-slot
'standard-method-combination
254 (set-slot 'source
*load-pathname
*)
255 (set-slot 'type
'standard
)
256 (set-slot 'documentation
"The standard method combination.")
257 (set-slot 'options
()))
258 (setq *standard-method-combination
* smc
))))
260 ;;; Initialize a class metaobject.
261 (defun !bootstrap-initialize-class
262 (metaclass-name class name
263 class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
266 direct-slots slots direct-default-initargs default-initargs
)
267 (flet ((classes (names) (mapcar #'find-class names
))
268 (set-slot (slot-name value
)
269 (!bootstrap-set-slot metaclass-name class slot-name value
)))
270 (set-slot 'name name
)
271 (set-slot 'finalized-p t
)
272 (set-slot 'source source
)
273 (set-slot 'type
(if (eq class
(find-class t
))
275 ;; FIXME: Could this just be CLASS instead
276 ;; of `(CLASS ,CLASS)? If not, why not?
277 ;; (See also similar expression in
278 ;; SHARED-INITIALIZE :BEFORE (CLASS).)
280 (set-slot 'class-eq-specializer
281 (let ((spec (allocate-standard-instance class-eq-wrapper
)))
282 (!bootstrap-set-slot
'class-eq-specializer spec
'type
284 (!bootstrap-set-slot
'class-eq-specializer spec
'object
287 (set-slot 'class-precedence-list
(classes cpl
))
288 (set-slot 'cpl-available-p t
)
289 (set-slot 'can-precede-list
(classes (cdr cpl
)))
290 (set-slot 'incompatible-superclass-list nil
)
291 (set-slot 'direct-superclasses
(classes direct-supers
))
292 (set-slot 'direct-subclasses
(classes direct-subclasses
))
293 (set-slot 'direct-methods
(cons nil nil
))
294 (set-slot 'wrapper wrapper
)
295 (set-slot 'predicate-name
(or (cadr (assoc name
*early-class-predicates
*))
296 (make-class-predicate-name name
)))
297 (set-slot 'documentation nil
)
299 `(,@(and direct-default-initargs
300 `(direct-default-initargs ,direct-default-initargs
))
301 ,@(and default-initargs
302 `(default-initargs ,default-initargs
))))
303 (when (memq metaclass-name
'(standard-class funcallable-standard-class
304 structure-class condition-class
305 slot-class std-class
))
306 (set-slot 'direct-slots direct-slots
)
307 (set-slot 'slots slots
))
309 ;; For all direct superclasses SUPER of CLASS, make sure CLASS is
310 ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
311 ;; matter here for the slot DIRECT-SUBCLASSES, since every class
312 ;; inherits the slot from class CLASS.
313 (dolist (super direct-supers
)
314 (let* ((super (find-class super
))
315 (subclasses (!bootstrap-get-slot metaclass-name super
316 'direct-subclasses
)))
317 (cond ((eq +slot-unbound
+ subclasses
)
318 (!bootstrap-set-slot metaclass-name super
'direct-subclasses
320 ((not (memq class subclasses
))
321 (!bootstrap-set-slot metaclass-name super
'direct-subclasses
322 (cons class subclasses
))))))
326 (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|
))
327 (set-slot 'predicate-name
(or (cadr (assoc name
328 *early-class-predicates
*))
329 (make-class-predicate-name name
)))
330 (set-slot 'defstruct-form
331 `(defstruct (structure-object (:constructor
334 (set-slot 'defstruct-constructor constructor-sym
)
335 (set-slot 'from-defclass-p t
)
336 (set-slot 'plist nil
)
337 (set-slot 'prototype
(funcall constructor-sym
))))
339 (set-slot 'prototype
(make-condition name
)))
342 (if proto-p proto
(allocate-standard-instance wrapper
)))))
345 (defun !bootstrap-make-slot-definitions
(name class slots wrapper effective-p
)
347 (mapcar (lambda (slot)
349 (!bootstrap-make-slot-definition
350 name class slot wrapper effective-p index
))
353 (defun !bootstrap-make-slot-definition
354 (name class slot wrapper effective-p index
)
355 (let* ((slotd-class-name (if effective-p
356 'standard-effective-slot-definition
357 'standard-direct-slot-definition
))
358 (slotd (allocate-standard-instance wrapper
))
359 (slot-name (getf slot
:name
)))
360 (flet ((get-val (name) (getf slot name
))
362 (!bootstrap-set-slot slotd-class-name slotd name val
)))
363 (set-val 'name slot-name
)
364 (set-val 'initform
(get-val :initform
))
365 (set-val 'initfunction
(get-val :initfunction
))
366 (set-val 'initargs
(get-val :initargs
))
367 (set-val 'readers
(get-val :readers
))
368 (set-val 'writers
(get-val :writers
))
369 (set-val 'allocation
:instance
)
370 (set-val 'type
(or (get-val :type
) t
))
371 (set-val 'documentation
(or (get-val :documentation
) ""))
372 (set-val 'class class
)
374 (set-val 'location index
)
376 (set-val 'reader-function
(make-optimized-std-reader-method-function
377 fsc-p nil slot-name index
))
378 (set-val 'writer-function
(make-optimized-std-writer-method-function
379 fsc-p nil slot-name index
))
380 (set-val 'boundp-function
(make-optimized-std-boundp-method-function
381 fsc-p nil slot-name index
)))
382 (set-val 'accessor-flags
7)
383 (let ((table (or (gethash slot-name
*name-
>class-
>slotd-table
*)
384 (setf (gethash slot-name
*name-
>class-
>slotd-table
*)
385 (make-hash-table :test
'eq
:size
5)))))
386 (setf (gethash class table
) slotd
)))
387 (when (and (eq name
'standard-class
)
388 (eq slot-name
'slots
) effective-p
)
389 (setq *the-eslotd-standard-class-slots
* slotd
))
390 (when (and (eq name
'funcallable-standard-class
)
391 (eq slot-name
'slots
) effective-p
)
392 (setq *the-eslotd-funcallable-standard-class-slots
* slotd
))
395 (defun !bootstrap-accessor-definitions
(early-p)
396 (let ((*early-p
* early-p
))
397 (dolist (definition *early-class-definitions
*)
398 (let ((name (ecd-class-name definition
))
399 (meta (ecd-metaclass definition
)))
400 (unless (eq meta
'built-in-class
)
401 (let ((direct-slots (ecd-canonical-slots definition
)))
402 (dolist (slotd direct-slots
)
403 (let ((slot-name (getf slotd
:name
))
404 (readers (getf slotd
:readers
))
405 (writers (getf slotd
:writers
)))
406 (!bootstrap-accessor-definitions1
412 (!bootstrap-accessor-definitions1
415 (list (slot-reader-name slot-name
))
416 (list (slot-writer-name slot-name
))
417 (list (slot-boundp-name slot-name
)))))))))))
419 (defun !bootstrap-accessor-definition
(class-name accessor-name slot-name type
)
420 (multiple-value-bind (accessor-class make-method-function arglist specls doc
)
422 (reader (values 'standard-reader-method
423 #'make-std-reader-method-function
426 "automatically generated reader method"))
427 (writer (values 'standard-writer-method
428 #'make-std-writer-method-function
429 (list 'new-value class-name
)
431 "automatically generated writer method"))
432 (boundp (values 'standard-boundp-method
433 #'make-std-boundp-method-function
436 "automatically generated boundp method")))
437 (let ((gf (ensure-generic-function accessor-name
438 :lambda-list arglist
)))
439 (if (find specls
(early-gf-methods gf
)
440 :key
#'early-method-specializers
442 (unless (assoc accessor-name
*!generic-function-fixups
*
446 (make-a-method accessor-class
449 (funcall make-method-function
450 class-name slot-name
)
454 (defun !bootstrap-accessor-definitions1
(class-name
459 (flet ((do-reader-definition (reader)
460 (!bootstrap-accessor-definition class-name
464 (do-writer-definition (writer)
465 (!bootstrap-accessor-definition class-name
469 (do-boundp-definition (boundp)
470 (!bootstrap-accessor-definition class-name
474 (dolist (reader readers
) (do-reader-definition reader
))
475 (dolist (writer writers
) (do-writer-definition writer
))
476 (dolist (boundp boundps
) (do-boundp-definition boundp
))))
478 (defun !bootstrap-class-predicates
(early-p)
479 (let ((*early-p
* early-p
))
480 (dolist (definition *early-class-definitions
*)
481 (let* ((name (ecd-class-name definition
))
482 (class (find-class name
)))
483 (setf (find-class-predicate name
)
484 (make-class-predicate class
(class-predicate-name class
)))))))
486 (defun !bootstrap-built-in-classes
()
488 ;; First make sure that all the supers listed in
489 ;; *BUILT-IN-CLASS-LATTICE* are themselves defined by
490 ;; *BUILT-IN-CLASS-LATTICE*. This is just to check for typos and
491 ;; other sorts of brainos.
492 (dolist (e *built-in-classes
*)
493 (dolist (super (cadr e
))
494 (unless (or (eq super t
)
495 (assq super
*built-in-classes
*))
496 (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~
497 but ~S is not itself a class in *BUILT-IN-CLASSES*."
498 (car e
) super super
))))
500 ;; In the first pass, we create a skeletal object to be bound to the
502 (let* ((built-in-class (find-class 'built-in-class
))
503 (built-in-class-wrapper (class-wrapper built-in-class
)))
504 (dolist (e *built-in-classes
*)
505 (let ((class (allocate-standard-instance built-in-class-wrapper
)))
506 (setf (find-class (car e
)) class
))))
508 ;; In the second pass, we initialize the class objects.
509 (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer
))))
510 (dolist (e *built-in-classes
*)
511 (destructuring-bind (name supers subs cpl prototype
) e
512 (let* ((class (find-class name
))
513 (lclass (find-classoid name
))
514 (wrapper (classoid-layout lclass
)))
515 (set (get-built-in-class-symbol name
) class
)
516 (set (get-built-in-wrapper-symbol name
) wrapper
)
517 (setf (classoid-pcl-class lclass
) class
)
519 (!bootstrap-initialize-class
'built-in-class class
520 name class-eq-wrapper nil
523 wrapper prototype
)))))
525 (dolist (e *built-in-classes
*)
526 (let* ((name (car e
))
527 (class (find-class name
)))
528 (setf (find-class-predicate name
)
529 (make-class-predicate class
(class-predicate-name class
))))))
531 (defmacro wrapper-of-macro
(x)
535 (wrapper-class* (wrapper-of-macro x
)))
537 ;;; FIXME: We probably don't need both WRAPPER-OF and WRAPPER-OF-MACRO.
538 #-sb-fluid
(declaim (inline wrapper-of
))
539 (defun wrapper-of (x)
540 (wrapper-of-macro x
))
542 (defun eval-form (form)
543 (lambda () (eval form
)))
545 (defun ensure-non-standard-class (name &optional existing-class
)
547 ((ensure (metaclass &optional
(slots nil slotsp
))
549 (mapcar #'classoid-name
(classoid-direct-superclasses
550 (find-classoid name
)))))
552 (ensure-class-using-class existing-class name
553 :metaclass metaclass
:name name
554 :direct-superclasses supers
556 (ensure-class-using-class existing-class name
557 :metaclass metaclass
:name name
558 :direct-superclasses supers
))))
559 (slot-initargs-from-structure-slotd (slotd)
560 (let ((accessor (structure-slotd-accessor-symbol slotd
)))
561 `(:name
,(structure-slotd-name slotd
)
562 :defstruct-accessor-symbol
,accessor
563 ,@(when (fboundp accessor
)
564 `(:internal-reader-function
565 ,(structure-slotd-reader-function slotd
)
566 :internal-writer-function
567 ,(structure-slotd-writer-function name slotd
)))
568 :type
,(or (structure-slotd-type slotd
) t
)
569 :initform
,(structure-slotd-init-form slotd
)
570 :initfunction
,(eval-form (structure-slotd-init-form slotd
)))))
571 (slot-initargs-from-condition-slot (slot)
572 `(:name
,(condition-slot-name slot
)
573 :initargs
,(condition-slot-initargs slot
)
574 :readers
,(condition-slot-readers slot
)
575 :writers
,(condition-slot-writers slot
)
576 ,@(when (condition-slot-initform-p slot
)
577 (let ((form-or-fun (condition-slot-initform slot
)))
578 (if (functionp form-or-fun
)
579 `(:initfunction
,form-or-fun
)
580 `(:initform
,form-or-fun
581 :initfunction
,(lambda () form-or-fun
)))))
582 :allocation
,(condition-slot-allocation slot
)
583 :documentation
,(condition-slot-documentation slot
))))
584 (cond ((structure-type-p name
)
585 (ensure 'structure-class
586 (mapcar #'slot-initargs-from-structure-slotd
587 (structure-type-slot-description-list name
))))
588 ((condition-type-p name
)
589 (ensure 'condition-class
590 (mapcar #'slot-initargs-from-condition-slot
591 (condition-classoid-slots (find-classoid name
)))))
593 (error "~@<~S is not the name of a class.~@:>" name
)))))
595 (defun ensure-defstruct-class (classoid)
596 (let ((class (classoid-pcl-class classoid
)))
598 (ensure-non-standard-class (class-name class
) class
))
599 ((eq 'complete
*boot-state
*)
600 (ensure-non-standard-class (classoid-name classoid
))))))
602 (pushnew 'ensure-defstruct-class sb-kernel
::*defstruct-hooks
*)
604 (defun make-class-predicate (class name
)
605 (let* ((gf (ensure-generic-function name
:lambda-list
'(object)))
606 (mlist (if (eq *boot-state
* 'complete
)
607 (generic-function-methods gf
)
608 (early-gf-methods gf
))))
610 (unless (eq class
*the-class-t
*)
611 (let* ((default-method-function #'constantly-nil
)
612 (default-method-initargs (list :function
613 default-method-function
))
614 (default-method (make-a-method
619 default-method-initargs
620 "class predicate default method")))
621 (setf (method-function-get default-method-function
:constant-value
)
623 (add-method gf default-method
)))
624 (let* ((class-method-function #'constantly-t
)
625 (class-method-initargs (list :function
626 class-method-function
))
627 (class-method (make-a-method 'standard-method
631 class-method-initargs
632 "class predicate class method")))
633 (setf (method-function-get class-method-function
:constant-value
) t
)
634 (add-method gf class-method
)))
637 ;;; Set the inherits from CPL, and register the layout. This actually
638 ;;; installs the class in the Lisp type system.
639 (defun update-lisp-class-layout (class layout
)
640 (let ((lclass (layout-classoid layout
)))
641 (unless (eq (classoid-layout lclass
) layout
)
642 (setf (layout-inherits layout
)
643 (order-layout-inherits
644 (map 'simple-vector
#'class-wrapper
645 (reverse (rest (class-precedence-list class
))))))
646 (register-layout layout
:invalidate t
)
648 ;; Subclasses of formerly forward-referenced-class may be
649 ;; unknown to CL:FIND-CLASS and also anonymous. This
650 ;; functionality moved here from (SETF FIND-CLASS).
651 (let ((name (class-name class
)))
652 (setf (find-classoid name
) lclass
653 (classoid-name lclass
) name
)))))
655 (defun set-class-type-translation (class name
)
656 (let ((classoid (find-classoid name nil
)))
660 (let ((translation (built-in-classoid-translation classoid
)))
663 (aver (ctype-p translation
))
664 (setf (info :type
:translator class
)
665 (lambda (spec) (declare (ignore spec
)) translation
)))
667 (setf (info :type
:translator class
)
668 (lambda (spec) (declare (ignore spec
)) classoid
))))))
670 (setf (info :type
:translator class
)
671 (lambda (spec) (declare (ignore spec
)) classoid
))))))
673 (clrhash *find-class
*)
674 (!bootstrap-meta-braid
)
675 (!bootstrap-accessor-definitions t
)
676 (!bootstrap-class-predicates t
)
677 (!bootstrap-accessor-definitions nil
)
678 (!bootstrap-class-predicates nil
)
679 (!bootstrap-built-in-classes
)
681 (dohash (name x
*find-class
*)
682 (let* ((class (find-class-from-cell name x
))
683 (layout (class-wrapper class
))
684 (lclass (layout-classoid layout
))
685 (lclass-pcl-class (classoid-pcl-class lclass
))
686 (olclass (find-classoid name nil
)))
688 (aver (eq class lclass-pcl-class
))
689 (setf (classoid-pcl-class lclass
) class
))
691 (update-lisp-class-layout class layout
)
694 (aver (eq lclass olclass
)))
696 (setf (find-classoid name
) lclass
)))
698 (set-class-type-translation class name
)))
700 (setq *boot-state
* 'braid
)
702 (defmethod no-applicable-method (generic-function &rest args
)
703 (error "~@<There is no applicable method for the generic function ~2I~_~S~
704 ~I~_when called with arguments ~2I~_~S.~:>"
708 (defmethod no-next-method ((generic-function standard-generic-function
)
709 (method standard-method
) &rest args
)
710 (error "~@<There is no next method for the generic function ~2I~_~S~
711 ~I~_when called from method ~2I~_~S~I~_with arguments ~2I~_~S.~:>"
716 ;;; An extension to the ANSI standard: in the presence of e.g. a
717 ;;; :BEFORE method, it would seem that going through
718 ;;; NO-APPLICABLE-METHOD is prohibited, as in fact there is an
719 ;;; applicable method. -- CSR, 2002-11-15
720 (defmethod no-primary-method (generic-function &rest args
)
721 (error "~@<There is no primary method for the generic function ~2I~_~S~
722 ~I~_when called with arguments ~2I~_~S.~:>"
726 (defmethod invalid-qualifiers ((gf generic-function
)
729 (let ((qualifiers (method-qualifiers method
)))
731 ((cdr qualifiers
) "has too many qualifiers")
732 (t (aver (not (member (car qualifiers
)
733 '(:around
:before
:after
))))
734 "has an invalid qualifier"))))
735 (invalid-method-error
737 "The method ~S on ~S ~A.~%~
738 Standard method combination requires all methods to have one~%~
739 of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
740 have no qualifier at all."