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-standard-funcallable-instance-slots
56 (wrapper &optional 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 (define-condition unset-funcallable-instance-function
65 (reference-condition simple-error
)
68 :references
(list '(:amop
:generic-function allocate-instance
)
69 '(:amop
:function set-funcallable-instance-function
))))
71 (defun allocate-standard-funcallable-instance
72 (wrapper &optional
(slots-init nil slots-init-p
))
73 (let ((fin (%make-standard-funcallable-instance
74 nil nil
(get-instance-hash-code))))
75 (set-funcallable-instance-function
77 #'(lambda (&rest args
)
78 (declare (ignore args
))
79 (error 'unset-funcallable-instance-function
80 :format-control
"~@<The function of funcallable instance ~
81 ~S has not been set.~@:>"
82 :format-arguments
(list fin
))))
83 (setf (fsc-instance-wrapper fin
) wrapper
84 (fsc-instance-slots fin
)
85 (allocate-standard-funcallable-instance-slots
86 wrapper slots-init-p slots-init
))
89 (defun classify-slotds (slotds)
90 (let (instance-slots class-slots custom-slots bootp
)
91 (dolist (slotd slotds
)
92 (let ((alloc (cond ((consp slotd
) ; bootstrap
96 (slot-definition-allocation slotd
)))))
99 (push slotd instance-slots
))
101 (push slotd class-slots
))
103 (push slotd custom-slots
)))))
105 (nreverse instance-slots
)
107 (sort instance-slots
#'< :key
#'slot-definition-location
)))
111 ;;;; BOOTSTRAP-META-BRAID
113 ;;;; This function builds the base metabraid from the early class definitions.
115 (defmacro !initial-classes-and-wrappers
(&rest classes
)
117 ,@(mapcar (lambda (class)
118 (let ((wr (format-symbol *pcl-package
* "~A-WRAPPER" class
)))
119 `(setf ,wr
,(if (eq class
'standard-generic-function
)
122 (early-class-size ',class
)
124 ,class
(allocate-standard-instance
125 ,(if (eq class
'standard-generic-function
)
126 'funcallable-standard-class-wrapper
127 'standard-class-wrapper
))
128 (wrapper-class ,wr
) ,class
129 (find-class ',class
) ,class
)))
132 (defun !bootstrap-meta-braid
()
133 (let* ((*create-classes-from-internal-structure-definitions-p
* nil
)
134 standard-class-wrapper standard-class
135 funcallable-standard-class-wrapper funcallable-standard-class
136 slot-class-wrapper slot-class
137 built-in-class-wrapper built-in-class
138 structure-class-wrapper structure-class
139 condition-class-wrapper condition-class
140 standard-direct-slot-definition-wrapper
141 standard-direct-slot-definition
142 standard-effective-slot-definition-wrapper
143 standard-effective-slot-definition
144 class-eq-specializer-wrapper class-eq-specializer
145 standard-generic-function-wrapper standard-generic-function
)
146 (!initial-classes-and-wrappers
147 standard-class funcallable-standard-class
148 slot-class built-in-class structure-class condition-class
149 standard-direct-slot-definition standard-effective-slot-definition
150 class-eq-specializer standard-generic-function
)
151 ;; First, make a class metaobject for each of the early classes. For
152 ;; each metaobject we also set its wrapper. Except for the class T,
153 ;; the wrapper is always that of STANDARD-CLASS.
154 (dolist (definition *early-class-definitions
*)
155 (let* ((name (ecd-class-name definition
))
156 (meta (ecd-metaclass definition
))
158 (slot-class slot-class-wrapper
)
159 (standard-class standard-class-wrapper
)
160 (funcallable-standard-class
161 funcallable-standard-class-wrapper
)
162 (built-in-class built-in-class-wrapper
)
163 (structure-class structure-class-wrapper
)
164 (condition-class condition-class-wrapper
)))
165 (class (or (find-class name nil
)
166 (allocate-standard-instance wrapper
))))
167 (setf (find-class name
) class
)))
168 (dolist (definition *early-class-definitions
*)
169 (let ((name (ecd-class-name definition
))
170 (meta (ecd-metaclass definition
))
171 (source (ecd-source-location definition
))
172 (direct-supers (ecd-superclass-names definition
))
173 (direct-slots (ecd-canonical-slots definition
))
174 (other-initargs (ecd-other-initargs definition
)))
175 (let ((direct-default-initargs
176 (getf other-initargs
:direct-default-initargs
)))
177 (multiple-value-bind (slots cpl default-initargs direct-subclasses
)
178 (early-collect-inheritance name
)
179 (let* ((class (find-class name
))
180 (wrapper (cond ((eq class slot-class
)
182 ((eq class standard-class
)
183 standard-class-wrapper
)
184 ((eq class funcallable-standard-class
)
185 funcallable-standard-class-wrapper
)
186 ((eq class standard-direct-slot-definition
)
187 standard-direct-slot-definition-wrapper
)
189 standard-effective-slot-definition
)
190 standard-effective-slot-definition-wrapper
)
191 ((eq class built-in-class
)
192 built-in-class-wrapper
)
193 ((eq class structure-class
)
194 structure-class-wrapper
)
195 ((eq class condition-class
)
196 condition-class-wrapper
)
197 ((eq class class-eq-specializer
)
198 class-eq-specializer-wrapper
)
199 ((eq class standard-generic-function
)
200 standard-generic-function-wrapper
)
202 (!boot-make-wrapper
(length slots
) name
))))
204 (when (eq name t
) (setq *the-wrapper-of-t
* wrapper
))
205 (set (make-class-symbol name
) class
)
207 (unless (eq (getf slot
:allocation
:instance
) :instance
)
208 (error "Slot allocation ~S is not supported in bootstrap."
209 (getf slot
:allocation
))))
211 (when (wrapper-p wrapper
)
212 (setf (wrapper-slots wrapper
) slots
))
214 (setq proto
(if (eq meta
'funcallable-standard-class
)
215 (allocate-standard-funcallable-instance wrapper
)
216 (allocate-standard-instance wrapper
)))
219 (!bootstrap-make-slot-definitions
220 name class direct-slots
221 standard-direct-slot-definition-wrapper nil
))
223 (!bootstrap-make-slot-definitions
225 standard-effective-slot-definition-wrapper t
))
227 (setf (layout-slot-table wrapper
) (make-slot-table class slots t
))
228 (when (wrapper-p wrapper
)
229 (setf (wrapper-slots wrapper
) slots
))
232 ((standard-class funcallable-standard-class
)
233 (!bootstrap-initialize-class
235 class name class-eq-specializer-wrapper source
236 direct-supers direct-subclasses cpl wrapper proto
237 direct-slots slots direct-default-initargs default-initargs
))
238 (built-in-class ; *the-class-t*
239 (!bootstrap-initialize-class
241 class name class-eq-specializer-wrapper source
242 direct-supers direct-subclasses cpl wrapper proto
))
243 (slot-class ; *the-class-slot-object*
244 (!bootstrap-initialize-class
246 class name class-eq-specializer-wrapper source
247 direct-supers direct-subclasses cpl wrapper proto
))
248 (structure-class ; *the-class-structure-object*
249 (!bootstrap-initialize-class
251 class name class-eq-specializer-wrapper source
252 direct-supers direct-subclasses cpl wrapper
))
254 (!bootstrap-initialize-class
256 class name class-eq-specializer-wrapper source
257 direct-supers direct-subclasses cpl wrapper
))))))))
259 (setq **standard-method-classes
**
260 (mapcar (lambda (name)
261 (symbol-value (make-class-symbol name
)))
262 *standard-method-class-names
*))
264 (let* ((smc-class (find-class 'standard-method-combination
))
265 (smc-wrapper (!bootstrap-get-slot
'standard-class
268 (smc (allocate-standard-instance smc-wrapper
)))
269 (flet ((set-slot (name value
)
270 (!bootstrap-set-slot
'standard-method-combination
274 (set-slot 'source nil
)
275 (set-slot 'type-name
'standard
)
276 (set-slot '%documentation
"The standard method combination.")
277 (set-slot 'options
()))
278 (setq *standard-method-combination
* smc
))))
280 ;;; Initialize a class metaobject.
281 (defun !bootstrap-initialize-class
282 (metaclass-name class name
283 class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
286 direct-slots slots direct-default-initargs default-initargs
)
287 (flet ((classes (names) (mapcar #'find-class names
))
288 (set-slot (slot-name value
)
289 (!bootstrap-set-slot metaclass-name class slot-name value
)))
290 (set-slot 'name name
)
291 (set-slot 'finalized-p t
)
292 (set-slot 'source source
)
293 (set-slot 'safe-p nil
)
294 (set-slot '%type
(if (eq class
(find-class t
))
296 ;; FIXME: Could this just be CLASS instead
297 ;; of `(CLASS ,CLASS)? If not, why not?
298 ;; (See also similar expression in
299 ;; SHARED-INITIALIZE :BEFORE (CLASS).)
301 (set-slot 'class-eq-specializer
302 (let ((spec (allocate-standard-instance class-eq-wrapper
)))
303 (!bootstrap-set-slot
'class-eq-specializer spec
'%type
305 (!bootstrap-set-slot
'class-eq-specializer spec
'object
308 (set-slot '%class-precedence-list
(classes cpl
))
309 (set-slot 'cpl-available-p t
)
310 (set-slot 'can-precede-list
(classes (cdr cpl
)))
311 (set-slot 'incompatible-superclass-list nil
)
312 (set-slot 'direct-superclasses
(classes direct-supers
))
313 (set-slot 'direct-subclasses
(classes direct-subclasses
))
314 (set-slot 'direct-methods
(cons nil nil
))
315 (set-slot 'wrapper wrapper
)
316 (set-slot '%documentation nil
)
318 `(,@(and direct-default-initargs
319 `(direct-default-initargs ,direct-default-initargs
))
320 ,@(and default-initargs
321 `(default-initargs ,default-initargs
))))
322 (when (memq metaclass-name
'(standard-class funcallable-standard-class
323 structure-class condition-class
325 (set-slot 'direct-slots direct-slots
)
326 (set-slot 'slots slots
)
327 (setf (layout-slot-table wrapper
)
328 (make-slot-table class slots
329 (member metaclass-name
330 '(standard-class funcallable-standard-class
))))
331 (when (wrapper-p wrapper
)
332 (setf (wrapper-slots wrapper
) slots
)))
334 ;; For all direct superclasses SUPER of CLASS, make sure CLASS is
335 ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
336 ;; matter here for the slot DIRECT-SUBCLASSES, since every class
337 ;; inherits the slot from class CLASS.
338 (dolist (super direct-supers
)
339 (let* ((super (find-class super
))
340 (subclasses (!bootstrap-get-slot metaclass-name super
341 'direct-subclasses
)))
342 (cond ((eq +slot-unbound
+ subclasses
)
343 (!bootstrap-set-slot metaclass-name super
'direct-subclasses
345 ((not (memq class subclasses
))
346 (!bootstrap-set-slot metaclass-name super
'direct-subclasses
347 (cons class subclasses
))))))
351 (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|
))
352 (set-slot 'defstruct-form
353 `(defstruct (structure-object (:constructor
356 (set-slot 'defstruct-constructor constructor-sym
)
357 (set-slot 'from-defclass-p t
)
358 (set-slot 'plist nil
)
359 (set-slot 'prototype
(funcall constructor-sym
))))
361 (set-slot 'prototype
(make-condition name
)))
364 (if proto-p proto
(allocate-standard-instance wrapper
)))))
367 (defun !bootstrap-make-slot-definitions
(name class slots wrapper effective-p
)
369 (mapcar (lambda (slot)
371 (!bootstrap-make-slot-definition
372 name class slot wrapper effective-p index
))
375 (defun !bootstrap-make-slot-definition
376 (name class slot wrapper effective-p index
)
377 (let* ((slotd-class-name (if effective-p
378 'standard-effective-slot-definition
379 'standard-direct-slot-definition
))
380 (slotd (allocate-standard-instance wrapper
))
381 (slot-name (getf slot
:name
)))
382 (flet ((get-val (name) (getf slot name
))
384 (!bootstrap-set-slot slotd-class-name slotd name val
)))
385 (set-val 'name slot-name
)
386 (set-val 'initform
(get-val :initform
))
387 (set-val 'initfunction
(get-val :initfunction
))
388 (set-val 'initargs
(get-val :initargs
))
390 (set-val 'readers
(get-val :readers
))
391 (set-val 'writers
(get-val :writers
)))
392 (set-val 'allocation
:instance
)
393 (set-val '%type
(or (get-val :type
) t
))
394 (set-val '%documentation
(or (get-val :documentation
) ""))
395 (set-val '%class class
)
397 (set-val 'location index
)
398 (set-val 'accessor-flags
7)
403 (make-optimized-std-reader-method-function nil nil slot-name index
)
405 (make-optimized-std-writer-method-function nil nil slot-name index
)
407 (make-optimized-std-boundp-method-function nil nil slot-name index
))))
408 (when (and (eq name
'standard-class
)
409 (eq slot-name
'slots
) effective-p
)
410 (setq *the-eslotd-standard-class-slots
* slotd
))
411 (when (and (eq name
'funcallable-standard-class
)
412 (eq slot-name
'slots
) effective-p
)
413 (setq *the-eslotd-funcallable-standard-class-slots
* slotd
))
416 (defun !bootstrap-accessor-definitions
(early-p)
417 (let ((*early-p
* early-p
))
418 (dolist (definition *early-class-definitions
*)
419 (let ((name (ecd-class-name definition
))
420 (meta (ecd-metaclass definition
)))
421 (unless (eq meta
'built-in-class
)
422 (let ((direct-slots (ecd-canonical-slots definition
)))
423 (dolist (slotd direct-slots
)
424 (let ((slot-name (getf slotd
:name
))
425 (readers (getf slotd
:readers
))
426 (writers (getf slotd
:writers
)))
427 (!bootstrap-accessor-definitions1
433 (ecd-source-location definition
))))))))))
435 (defun !bootstrap-accessor-definition
(class-name accessor-name slot-name type source-location
)
436 (multiple-value-bind (accessor-class make-method-function arglist specls doc
)
438 (reader (values 'standard-reader-method
439 #'make-std-reader-method-function
442 "automatically generated reader method"))
443 (writer (values 'standard-writer-method
444 #'make-std-writer-method-function
445 (list 'new-value class-name
)
447 "automatically generated writer method"))
448 (boundp (values 'standard-boundp-method
449 #'make-std-boundp-method-function
452 "automatically generated boundp method")))
453 (let ((gf (ensure-generic-function accessor-name
:lambda-list arglist
)))
454 (if (find specls
(early-gf-methods gf
)
455 :key
#'early-method-specializers
457 (unless (assoc accessor-name
*!generic-function-fixups
*
461 (make-a-method accessor-class
464 (funcall make-method-function
465 class-name slot-name
)
468 :object-class class-name
469 :method-class-function
(constantly (find-class accessor-class
))
470 :definition-source source-location
))))))
472 (defun !bootstrap-accessor-definitions1
(class-name
478 (flet ((do-reader-definition (reader)
479 (!bootstrap-accessor-definition class-name
484 (do-writer-definition (writer)
485 (!bootstrap-accessor-definition class-name
490 (do-boundp-definition (boundp)
491 (!bootstrap-accessor-definition class-name
496 (dolist (reader readers
) (do-reader-definition reader
))
497 (dolist (writer writers
) (do-writer-definition writer
))
498 (dolist (boundp boundps
) (do-boundp-definition boundp
))))
500 ;;; FIXME: find a better name.
501 (defun !bootstrap-class-predicates
(early-p)
502 (let ((*early-p
* early-p
))
503 (dolist (ecp *early-class-predicates
*)
504 (let ((class-name (car ecp
))
505 (predicate-name (cadr ecp
)))
506 (make-class-predicate (find-class class-name
) predicate-name
)))))
508 (defun !bootstrap-built-in-classes
()
510 ;; First make sure that all the supers listed in
511 ;; *BUILT-IN-CLASS-LATTICE* are themselves defined by
512 ;; *BUILT-IN-CLASS-LATTICE*. This is just to check for typos and
513 ;; other sorts of brainos.
514 (dolist (e *built-in-classes
*)
515 (dolist (super (cadr e
))
516 (unless (or (eq super t
)
517 (assq super
*built-in-classes
*))
518 (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~
519 but ~S is not itself a class in *BUILT-IN-CLASSES*."
520 (car e
) super super
))))
522 ;; In the first pass, we create a skeletal object to be bound to the
524 (let* ((built-in-class (find-class 'built-in-class
))
525 (built-in-class-wrapper (class-wrapper built-in-class
)))
526 (dolist (e *built-in-classes
*)
527 (let ((class (allocate-standard-instance built-in-class-wrapper
)))
528 (setf (find-class (car e
)) class
))))
530 ;; In the second pass, we initialize the class objects.
531 (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer
))))
532 (dolist (e *built-in-classes
*)
533 (destructuring-bind (name supers subs cpl prototype
) e
534 (let* ((class (find-class name
))
535 (lclass (find-classoid name
))
536 (wrapper (classoid-layout lclass
)))
537 (set (get-built-in-class-symbol name
) class
)
538 (set (get-built-in-wrapper-symbol name
) wrapper
)
539 (setf (classoid-pcl-class lclass
) class
)
541 (!bootstrap-initialize-class
'built-in-class class
542 name class-eq-wrapper nil
545 wrapper prototype
))))))
547 #-sb-fluid
(declaim (inline wrapper-of
))
548 (defun wrapper-of (x)
552 (wrapper-class* (wrapper-of x
)))
554 (defun eval-form (form)
555 (lambda () (eval form
)))
557 (defun ensure-non-standard-class (name classoid
&optional existing-class
)
559 ((ensure (metaclass &optional
(slots nil slotsp
))
560 (let ((supers (mapcar #'classoid-name
(classoid-direct-superclasses classoid
))))
562 (ensure-class-using-class existing-class name
563 :metaclass metaclass
:name name
564 :direct-superclasses supers
566 (ensure-class-using-class existing-class name
567 :metaclass metaclass
:name name
568 :direct-superclasses supers
))))
569 (slot-initargs-from-structure-slotd (slotd)
570 (let ((accessor (structure-slotd-accessor-symbol slotd
)))
571 `(:name
,(structure-slotd-name slotd
)
572 :defstruct-accessor-symbol
,accessor
573 :internal-reader-function
,(structure-slotd-reader-function slotd
)
574 :internal-writer-function
,(structure-slotd-writer-function name slotd
)
575 :type
,(or (structure-slotd-type slotd
) t
)
576 :initform
,(structure-slotd-init-form slotd
)
577 :initfunction
,(eval-form (structure-slotd-init-form slotd
)))))
578 (slot-initargs-from-condition-slot (slot)
579 `(:name
,(condition-slot-name slot
)
580 :initargs
,(condition-slot-initargs slot
)
581 :readers
,(condition-slot-readers slot
)
582 :writers
,(condition-slot-writers slot
)
583 ,@(when (condition-slot-initform-p slot
)
584 (let ((initform (condition-slot-initform slot
))
585 (initfun (condition-slot-initfunction slot
)))
586 `(:initform
',initform
:initfunction
,initfun
)))
587 :allocation
,(condition-slot-allocation slot
)
588 :documentation
,(condition-slot-documentation slot
))))
589 (cond ((structure-type-p name
)
590 (ensure 'structure-class
591 (mapcar #'slot-initargs-from-structure-slotd
592 (structure-type-slot-description-list name
))))
593 ((condition-type-p name
)
594 (ensure 'condition-class
595 (mapcar #'slot-initargs-from-condition-slot
596 (condition-classoid-slots classoid
))))
598 (error "~@<~S is not the name of a class.~@:>" name
)))))
600 (defun ensure-deffoo-class (classoid)
601 (let ((class (classoid-pcl-class classoid
)))
603 (ensure-non-standard-class (class-name class
) classoid class
))
604 ((eq 'complete
**boot-state
**)
605 (ensure-non-standard-class (classoid-name classoid
) classoid
)))))
607 (pushnew 'ensure-deffoo-class sb-kernel
::*defstruct-hooks
*)
608 (pushnew 'ensure-deffoo-class sb-kernel
::*define-condition-hooks
*)
610 ;;; FIXME: only needed during bootstrap
611 (defun make-class-predicate (class name
)
612 (let* ((gf (ensure-generic-function name
:lambda-list
'(object)))
613 (mlist (if (eq **boot-state
** 'complete
)
614 (early-gf-methods gf
)
615 (generic-function-methods gf
))))
617 (unless (eq class
*the-class-t
*)
618 (let* ((default-method-function #'constantly-nil
)
619 (default-method-initargs (list :function default-method-function
620 'plist
'(:constant-value nil
)))
621 (default-method (make-a-method
626 default-method-initargs
627 "class predicate default method")))
628 (add-method gf default-method
)))
629 (let* ((class-method-function #'constantly-t
)
630 (class-method-initargs (list :function class-method-function
631 'plist
'(:constant-value t
)))
632 (class-method (make-a-method 'standard-method
636 class-method-initargs
637 "class predicate class method")))
638 (add-method gf class-method
)))
641 ;;; Set the inherits from CPL, and register the layout. This actually
642 ;;; installs the class in the Lisp type system.
643 (defun %update-lisp-class-layout
(class layout
)
644 ;; Protected by *world-lock* in callers.
645 (let ((classoid (layout-classoid layout
))
646 (olayout (class-wrapper class
)))
647 (unless (eq (classoid-layout classoid
) layout
)
648 (setf (layout-inherits layout
)
649 (order-layout-inherits
650 (map 'simple-vector
#'class-wrapper
651 (reverse (rest (class-precedence-list class
))))))
652 (register-layout layout
:invalidate t
)
654 ;; FIXME: I don't think this should be necessary, but without it
655 ;; we are unable to compile (TYPEP foo '<class-name>) in the
656 ;; same file as the class is defined. If we had environments,
657 ;; then I think the classsoid whould only be associated with the
658 ;; name in that environment... Alternatively, fix the compiler
659 ;; so that TYPEP foo '<class-name> is slow but compileable.
660 (let ((name (class-name class
)))
661 (when (and name
(symbolp name
) (eq name
(classoid-name classoid
)))
662 (setf (find-classoid name
) classoid
))))))
664 (defun %set-class-type-translation
(class classoid
)
665 (when (not (typep classoid
'classoid
))
666 (setq classoid
(find-classoid classoid nil
)))
670 (let ((translation (built-in-classoid-translation classoid
)))
673 (aver (ctype-p translation
))
674 (setf (info :type
:translator class
)
675 (lambda (spec) (declare (ignore spec
)) translation
)))
677 (setf (info :type
:translator class
)
678 (lambda (spec) (declare (ignore spec
)) classoid
))))))
680 (setf (info :type
:translator class
)
681 (lambda (spec) (declare (ignore spec
)) classoid
)))))
683 (!bootstrap-meta-braid
)
684 (!bootstrap-accessor-definitions t
)
685 (!bootstrap-class-predicates t
)
686 (!bootstrap-accessor-definitions nil
)
687 (!bootstrap-class-predicates nil
)
688 (!bootstrap-built-in-classes
)
690 (dohash ((name x
) sb-kernel
::*classoid-cells
*)
691 (when (classoid-cell-pcl-class x
)
692 (let* ((class (find-class-from-cell name x
))
693 (layout (class-wrapper class
))
694 (lclass (layout-classoid layout
))
695 (lclass-pcl-class (classoid-pcl-class lclass
))
696 (olclass (find-classoid name nil
)))
698 (aver (eq class lclass-pcl-class
))
699 (setf (classoid-pcl-class lclass
) class
))
701 (%update-lisp-class-layout class layout
)
704 (aver (eq lclass olclass
)))
706 (setf (find-classoid name
) lclass
)))
708 (%set-class-type-translation class name
))))
710 (setq **boot-state
** 'braid
)
712 (defmethod no-applicable-method (generic-function &rest args
)
713 (error "~@<There is no applicable method for the generic function ~2I~_~S~
714 ~I~_when called with arguments ~2I~_~S.~:>"
718 (defmethod no-next-method ((generic-function standard-generic-function
)
719 (method standard-method
) &rest args
)
720 (error "~@<There is no next method for the generic function ~2I~_~S~
721 ~I~_when called from method ~2I~_~S~I~_with arguments ~2I~_~S.~:>"
726 ;;; An extension to the ANSI standard: in the presence of e.g. a
727 ;;; :BEFORE method, it would seem that going through
728 ;;; NO-APPLICABLE-METHOD is prohibited, as in fact there is an
729 ;;; applicable method. -- CSR, 2002-11-15
730 (define-condition no-primary-method
(reference-condition error
)
731 ((generic-function :initarg
:generic-function
:reader no-primary-method-generic-function
)
732 (args :initarg
:args
:reader no-primary-method-args
))
735 (format s
"~@<There is no primary method for the generic function ~2I~_~S~
736 ~I~_when called with arguments ~2I~_~S.~:>"
737 (no-primary-method-generic-function c
)
738 (no-primary-method-args c
))))
739 (:default-initargs
:references
(list '(:ansi-cl
:section
(7 6 6 2)))))
740 (defmethod no-primary-method (generic-function &rest args
)
741 (error 'no-primary-method
:generic-function generic-function
:args args
))
743 (defmethod invalid-qualifiers ((gf generic-function
)
746 (let ((qualifiers (method-qualifiers method
)))
748 ((cdr qualifiers
) "has too many qualifiers")
749 (t (aver (not (member (car qualifiers
)
750 '(:around
:before
:after
))))
751 "has an invalid qualifier"))))
752 (invalid-method-error
754 "The method ~S on ~S ~A.~%~
755 Standard method combination requires all methods to have one~%~
756 of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
757 have no qualifier at all."