/[cmucl]/src/pcl/braid.lisp
ViewVC logotype

Contents of /src/pcl/braid.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.52 - (show annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.51: +15 -14 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26
27 (file-comment
28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/braid.lisp,v 1.52 2010/03/19 15:19:03 rtoy Rel $")
29
30 ;;;
31 ;;; Bootstrapping the meta-braid.
32 ;;;
33 ;;; The code in this file takes the early definitions that have been saved
34 ;;; up and actually builds those class objects. This work is largely driven
35 ;;; off of those class definitions, but the fact that STANDARD-CLASS is the
36 ;;; class of all metaclasses in the braid is built into this code pretty
37 ;;; deeply.
38 ;;;
39 ;;;
40
41 (in-package :pcl)
42 (intl:textdomain "cmucl")
43
44 (defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p))
45 (declare #.*optImize-speed*)
46 (let* ((no-of-slots (kernel:layout-length wrapper))
47 (instance (%%allocate-instance--class))
48 (slots (make-array no-of-slots)))
49 (declare (fixnum no-of-slots))
50 (if slots-init-p
51 (loop for i below no-of-slots
52 for init-value in slots-init do
53 (setf (%svref slots i) init-value))
54 (loop for i below no-of-slots do
55 (setf (%svref slots i) +slot-unbound+)))
56 (setf (std-instance-wrapper instance) wrapper)
57 (setf (std-instance-slots instance) slots)
58 instance))
59
60 (defmacro allocate-funcallable-instance-slots (wrapper &optional
61 slots-init-p slots-init)
62 `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper)))
63 ,(if slots-init-p
64 `(if ,slots-init-p
65 (make-array no-of-slots :initial-contents ,slots-init)
66 (make-array no-of-slots :initial-element +slot-unbound+))
67 `(make-array no-of-slots :initial-element +slot-unbound+))))
68
69 (defun allocate-funcallable-instance (wrapper &optional
70 (slots-init nil slots-init-p))
71 (let ((fin (allocate-funcallable-instance-1)))
72 (set-funcallable-instance-function
73 fin
74 #'(kernel:instance-lambda (&rest args)
75 (declare (ignore args))
76 (error _"~@<The function of the funcallable instance ~S ~
77 has not been set.~@:>"
78 fin)))
79 (setf (fsc-instance-wrapper fin) wrapper
80 (fsc-instance-slots fin) (allocate-funcallable-instance-slots
81 wrapper slots-init-p slots-init))
82 fin))
83
84
85 ;;;
86 ;;; bootstrap-meta-braid
87 ;;;
88 ;;; This function builds the base metabraid from the early class definitions.
89 ;;;
90 (defmacro initial-classes-and-wrappers (&rest classes)
91 `(progn
92 ,@(mapcar (lambda (class)
93 (let ((wr (symbolicate* *the-pcl-package* class '-wrapper)))
94 `(setf ,wr ,(if (eq class 'standard-generic-function)
95 '*sgf-wrapper*
96 `(boot-make-wrapper
97 (early-class-size ',class)
98 ',class))
99 ,class (allocate-standard-instance
100 ,(if (eq class 'standard-generic-function)
101 'funcallable-standard-class-wrapper
102 'standard-class-wrapper))
103 (wrapper-class ,wr) ,class
104 (find-class ',class) ,class)))
105 classes)))
106
107 (defun set-class-translation (class name)
108 (let ((kernel-class (kernel::find-class name nil)))
109 (etypecase kernel-class
110 (null)
111 (kernel::built-in-class
112 (let ((translation (kernel::built-in-class-translation kernel-class)))
113 (setf (info type translator class)
114 (if translation
115 (lambda (spec) (declare (ignore spec)) translation)
116 (lambda (spec) (declare (ignore spec)) kernel-class)))))
117 (kernel::class
118 (setf (info type translator class)
119 (lambda (spec) (declare (ignore spec)) kernel-class))))))
120
121 (defun bootstrap-meta-braid ()
122 (let* ((*create-classes-from-internal-structure-definitions-p* nil)
123 standard-class-wrapper standard-class
124 funcallable-standard-class-wrapper funcallable-standard-class
125 slot-class-wrapper slot-class
126 built-in-class-wrapper built-in-class
127 structure-class-wrapper structure-class
128 condition-class-wrapper condition-class
129 standard-direct-slot-definition-wrapper standard-direct-slot-definition
130 standard-effective-slot-definition-wrapper standard-effective-slot-definition
131 class-eq-specializer-wrapper class-eq-specializer
132 standard-generic-function-wrapper standard-generic-function)
133 (initial-classes-and-wrappers
134 standard-class funcallable-standard-class
135 slot-class built-in-class structure-class condition-class
136 standard-direct-slot-definition standard-effective-slot-definition
137 class-eq-specializer standard-generic-function)
138 ;;
139 ;; First, make a class metaobject for each of the early classes. For
140 ;; each metaobject we also set its wrapper. Except for the class T,
141 ;; the wrapper is always that of STANDARD-CLASS.
142 ;;
143 (dolist (definition *early-class-definitions*)
144 (let* ((name (ecd-class-name definition))
145 (meta (ecd-metaclass definition))
146 (wrapper (ecase meta
147 (slot-class slot-class-wrapper)
148 (standard-class standard-class-wrapper)
149 (funcallable-standard-class funcallable-standard-class-wrapper)
150 (built-in-class built-in-class-wrapper)
151 (structure-class structure-class-wrapper)
152 (condition-class condition-class-wrapper)))
153 (class (or (find-class name nil)
154 (allocate-standard-instance wrapper))))
155 (when (or (eq meta 'standard-class)
156 (eq meta 'funcallable-standard-class))
157 (inform-type-system-about-std-class name))
158 (setf (find-class name) class)))
159 ;;
160 ;;
161 ;;
162 (dolist (definition *early-class-definitions*)
163 (let ((name (ecd-class-name definition))
164 (meta (ecd-metaclass definition))
165 (source (ecd-source definition))
166 (direct-supers (ecd-superclass-names definition))
167 (direct-slots (ecd-canonical-slots definition))
168 (other-initargs (ecd-other-initargs definition)))
169 (let ((direct-default-initargs
170 (getf other-initargs :direct-default-initargs)))
171 (multiple-value-bind (slots cpl default-initargs direct-subclasses)
172 (early-collect-inheritance name)
173 (let* ((class (find-class name))
174 (wrapper (cond ((eq class slot-class)
175 slot-class-wrapper)
176 ((eq class standard-class)
177 standard-class-wrapper)
178 ((eq class funcallable-standard-class)
179 funcallable-standard-class-wrapper)
180 ((eq class standard-direct-slot-definition)
181 standard-direct-slot-definition-wrapper)
182 ((eq class standard-effective-slot-definition)
183 standard-effective-slot-definition-wrapper)
184 ((eq class built-in-class)
185 built-in-class-wrapper)
186 ((eq class structure-class)
187 structure-class-wrapper)
188 ((eq class condition-class)
189 condition-class-wrapper)
190 ((eq class class-eq-specializer)
191 class-eq-specializer-wrapper)
192 ((eq class standard-generic-function)
193 standard-generic-function-wrapper)
194 (t
195 (boot-make-wrapper (length slots) name))))
196 (proto nil))
197 (when (eq name t) (setq *the-wrapper-of-t* wrapper))
198 (set (symbolicate* *the-pcl-package* '*the-class- name '*)
199 class)
200 (dolist (slot slots)
201 (unless (eq (getf slot :allocation :instance) :instance)
202 (error _"~@<Slot allocation ~S is not supported ~
203 in bootstrap.~@:>"
204 (getf slot :allocation))))
205
206 (when (typep wrapper 'wrapper)
207 (setf (wrapper-instance-slots-layout wrapper)
208 (mapcar #'canonical-slot-name slots))
209 (setf (wrapper-class-slots wrapper)
210 ()))
211
212 (setq proto (if (eq meta 'funcallable-standard-class)
213 (allocate-funcallable-instance wrapper)
214 (allocate-standard-instance wrapper)))
215
216 (setq direct-slots
217 (bootstrap-make-slot-definitions
218 name class direct-slots
219 standard-direct-slot-definition-wrapper nil))
220 (setq slots
221 (bootstrap-make-slot-definitions
222 name class slots
223 standard-effective-slot-definition-wrapper t))
224
225 (case meta
226 ((standard-class funcallable-standard-class)
227 (bootstrap-initialize-class
228 meta
229 class name class-eq-specializer-wrapper source
230 direct-supers direct-subclasses cpl wrapper proto
231 direct-slots slots direct-default-initargs default-initargs))
232 (built-in-class ; *the-class-t*
233 (bootstrap-initialize-class
234 meta
235 class name class-eq-specializer-wrapper source
236 direct-supers direct-subclasses cpl wrapper proto))
237 (slot-class ; *the-class-slot-object*
238 (bootstrap-initialize-class
239 meta
240 class name class-eq-specializer-wrapper source
241 direct-supers direct-subclasses cpl wrapper proto))
242 (structure-class ; *the-class-structure-object*
243 (bootstrap-initialize-class
244 meta
245 class name class-eq-specializer-wrapper source
246 direct-supers direct-subclasses cpl wrapper))
247 (condition-class
248 (bootstrap-initialize-class
249 meta
250 class name class-eq-specializer-wrapper source
251 direct-supers direct-subclasses cpl wrapper))))))))
252
253 (let* ((smc-class (find-class 'standard-method-combination))
254 (smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper))
255 (smc (allocate-standard-instance smc-wrapper)))
256 (flet ((set-slot (name value)
257 (bootstrap-set-slot 'standard-method-combination smc name value)))
258 (set-slot 'source *load-pathname*)
259 (set-slot 'type 'standard)
260 (set-slot 'documentation _N"The standard method combination.")
261 (set-slot 'options ()))
262 (setq *standard-method-combination* smc))))
263
264 ;;;
265 ;;; Initialize a class metaobject.
266 ;;;
267 (defun bootstrap-initialize-class
268 (metaclass-name class name
269 class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
270 &optional (proto nil proto-p)
271 direct-slots slots direct-default-initargs default-initargs)
272 (flet ((classes (names)
273 (mapcar #'find-class names))
274 (set-slot (slot-name value)
275 (bootstrap-set-slot metaclass-name class slot-name value)))
276 (set-slot 'name name)
277 (set-slot 'finalized-p t)
278 (set-slot 'source source)
279 (set-slot 'type (if (eq class (find-class t))
280 t
281 `(class ,class)))
282 (set-slot 'class-eq-specializer
283 (let ((spec (allocate-standard-instance class-eq-wrapper)))
284 (bootstrap-set-slot 'class-eq-specializer spec 'type
285 `(class-eq ,class))
286 (bootstrap-set-slot 'class-eq-specializer spec 'object
287 class)
288 spec))
289 (set-slot 'class-precedence-list (classes cpl))
290 (set-slot 'cpl-available-p t)
291 (set-slot 'can-precede-list (classes (cdr cpl)))
292 (set-slot 'incompatible-superclass-list nil)
293 (set-slot 'direct-superclasses (classes direct-supers))
294 (set-slot 'direct-subclasses (classes direct-subclasses))
295 (set-slot 'direct-methods (cons nil nil))
296 (set-slot 'wrapper wrapper)
297 (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
298 (make-class-predicate-name name)))
299 (set-slot 'plist
300 `(,@(and direct-default-initargs
301 `(direct-default-initargs ,direct-default-initargs))
302 ,@(and default-initargs
303 `(default-initargs ,default-initargs))))
304 (when (memq metaclass-name '(standard-class funcallable-standard-class
305 structure-class slot-class condition-class))
306 (set-slot 'direct-slots direct-slots)
307 (set-slot 'slots slots))
308 ;;
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 (setf (bootstrap-get-slot metaclass-name super 'direct-subclasses)
319 (list class)))
320 ((not (memq class subclasses))
321 (setf (bootstrap-get-slot metaclass-name super 'direct-subclasses)
322 (cons class subclasses))))))
323 ;;
324 (case metaclass-name
325 (structure-class
326 (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
327 (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
328 (make-class-predicate-name name)))
329 (set-slot 'defstruct-form
330 `(defstruct (structure-object (:constructor ,constructor-sym))))
331 (set-slot 'defstruct-constructor constructor-sym)
332 (set-slot 'from-defclass-p t)
333 (set-slot 'plist nil)
334 (set-slot 'prototype (funcall constructor-sym))))
335 (condition-class
336 (set-slot 'prototype (make-condition name)))
337 (t
338 (set-slot 'prototype
339 (if proto-p proto (allocate-standard-instance wrapper)))))
340 class))
341
342 (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
343 (loop for index from 0 and slot in slots collect
344 (bootstrap-make-slot-definition name class slot wrapper
345 effective-p index)))
346
347 (defun bootstrap-make-slot-definition (name class slot wrapper effective-p index)
348 (let* ((slotd-class-name (if effective-p
349 'standard-effective-slot-definition
350 'standard-direct-slot-definition))
351 (slotd (allocate-standard-instance wrapper))
352 (slot-name (getf slot :name)))
353 (flet ((get-val (name) (getf slot name))
354 (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val)))
355 (set-val 'name slot-name)
356 (set-val 'initform (get-val :initform))
357 (set-val 'initfunction (get-val :initfunction))
358 (set-val 'initargs (get-val :initargs))
359 (set-val 'readers (get-val :readers))
360 (set-val 'writers (get-val :writers))
361 (set-val 'allocation :instance)
362 (set-val 'type (or (get-val :type) t))
363 (set-val 'documentation (or (get-val :documentation) ""))
364 (set-val 'class class)
365 (when effective-p
366 (set-val 'location index)
367 (let ((fsc-p nil))
368 (set-val 'reader-function (make-optimized-std-reader-method-function
369 fsc-p slot-name index))
370 (set-val 'writer-function (make-optimized-std-writer-method-function
371 fsc-p slot-name index))
372 (set-val 'boundp-function (make-optimized-std-boundp-method-function
373 fsc-p slot-name index)))
374 (set-val 'accessor-flags 7)
375 (setf (gethash class (slot-name->class-table slot-name)) slotd))
376 (when (and (eq name 'standard-class)
377 (eq slot-name 'slots) effective-p)
378 (setq *the-eslotd-standard-class-slots* slotd))
379 (when (and (eq name 'funcallable-standard-class)
380 (eq slot-name 'slots) effective-p)
381 (setq *the-eslotd-funcallable-standard-class-slots* slotd))
382 slotd)))
383
384 (defun bootstrap-accessor-definitions (early-p)
385 (let ((*early-p* early-p))
386 (dolist (definition *early-class-definitions*)
387 (let ((name (ecd-class-name definition))
388 (meta (ecd-metaclass definition)))
389 (unless (eq meta 'built-in-class)
390 (let ((direct-slots (ecd-canonical-slots definition)))
391 (dolist (slotd direct-slots)
392 (let ((slot-name (getf slotd :name))
393 (readers (getf slotd :readers))
394 (writers (getf slotd :writers)))
395 (bootstrap-accessor-definitions1 name slot-name readers writers nil)
396 (bootstrap-accessor-definitions1
397 'slot-object
398 slot-name
399 (list (slot-reader-name slot-name))
400 (list (slot-writer-name slot-name))
401 (list (slot-boundp-name slot-name)))))))))))
402
403 (defun bootstrap-accessor-definition (class-name accessor-name slot-name type)
404 (multiple-value-bind (accessor-class make-method-function arglist specls doc)
405 (ecase type
406 (reader (values 'standard-reader-method #'make-std-reader-method-function
407 (list class-name) (list class-name)
408 "automatically generated reader method"))
409 (writer (values 'standard-writer-method #'make-std-writer-method-function
410 (list 'new-value class-name) (list t class-name)
411 "automatically generated writer method"))
412 (boundp (values 'standard-boundp-method #'make-std-boundp-method-function
413 (list class-name) (list class-name)
414 "automatically generated boundp method")))
415 (let ((gf (ensure-generic-function accessor-name)))
416 (if (find specls (early-gf-methods gf)
417 :key #'early-method-specializers
418 :test #'equal)
419 (unless (assoc accessor-name *generic-function-fixups*
420 :test #'equal)
421 (update-dfun gf))
422 (add-method gf
423 (make-a-method accessor-class
424 ()
425 arglist specls
426 (funcall make-method-function
427 class-name slot-name)
428 doc
429 slot-name))))))
430
431 (defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps)
432 (flet ((do-reader-definition (reader)
433 (bootstrap-accessor-definition class-name reader slot-name 'reader))
434 (do-writer-definition (writer)
435 (bootstrap-accessor-definition class-name writer slot-name 'writer))
436 (do-boundp-definition (boundp)
437 (bootstrap-accessor-definition class-name boundp slot-name 'boundp)))
438 (dolist (reader readers) (do-reader-definition reader))
439 (dolist (writer writers) (do-writer-definition writer))
440 (dolist (boundp boundps) (do-boundp-definition boundp))))
441
442 (defun bootstrap-class-predicates (early-p)
443 (let ((*early-p* early-p))
444 (dolist (definition *early-class-definitions*)
445 (let* ((name (ecd-class-name definition))
446 (class (find-class name)))
447 (setf (find-class-predicate name)
448 (make-class-predicate class (class-predicate-name class)))))))
449
450 (defun bootstrap-built-in-classes ()
451 ;;
452 ;; First make sure that all the supers listed in *built-in-class-lattice*
453 ;; are themselves defined by *built-in-class-lattice*. This is just to
454 ;; check for typos and other sorts of brainos.
455 (dolist (e *built-in-classes*)
456 (dolist (super (cadr e))
457 (unless (or (eq super t)
458 (assq super *built-in-classes*))
459 (error _"In *built-in-classes*: ~S has ~S as a superclass,~%~
460 but ~S is not itself a class in *built-in-classes*."
461 (car e) super super))))
462 ;;
463 ;; In the first pass, we create a skeletal object to be bound to the
464 ;; class name.
465 (let* ((built-in-class (find-class 'built-in-class))
466 (built-in-class-wrapper (class-wrapper built-in-class)))
467 (dolist (e *built-in-classes*)
468 (let ((class (allocate-standard-instance built-in-class-wrapper)))
469 (setf (find-class (car e)) class))))
470 ;;
471 ;; In the second pass, we initialize the class objects.
472 (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer))))
473 (dolist (e *built-in-classes*)
474 (destructuring-bind (name supers subs prototype) e
475 (let* ((class (find-class name))
476 (lclass (kernel::find-class name))
477 (wrapper (kernel:%class-layout lclass)))
478 (set (get-built-in-class-symbol name) class)
479 (set (get-built-in-wrapper-symbol name) wrapper)
480 (setf (kernel:%class-pcl-class lclass) class)
481 (let* ((kernel-class (kernel::find-class name))
482 (cpl (kernel:std-compute-class-precedence-list kernel-class))
483 (cpl-class-names (mapcar #'kernel:%class-name cpl)))
484 (bootstrap-initialize-class 'built-in-class class
485 name class-eq-wrapper nil
486 supers subs cpl-class-names
487 wrapper prototype))))))
488 ;;
489 (dolist (e *built-in-classes*)
490 (let* ((name (car e))
491 (class (find-class name)))
492 (setf (find-class-predicate name)
493 (make-class-predicate class (class-predicate-name class))))))
494
495
496 ;;;
497 ;;;
498 ;;;
499
500 (defmacro wrapper-of-macro (x)
501 `(kernel:layout-of ,x))
502
503 (defun class-of (x)
504 (wrapper-class* (wrapper-of-macro x)))
505
506 (declaim (inline wrapper-of))
507 (defun wrapper-of (x)
508 (wrapper-of-macro x))
509
510 (defun eval-form (form)
511 (lambda () (eval form)))
512
513 ;;;
514 ;;; Make a non-STANDARD-CLASS for the thing with name NAME. The thing
515 ;;; may currently either be a structure or a condition, in which
516 ;;; case we construct either a STRUCTURE-CLASS or a CONDITION-CLASS
517 ;;; for the corresponding KERNEL::CLASS.
518 ;;;
519 (defun ensure-non-standard-class (name &optional existing-class)
520 (flet ((ensure (metaclass slots)
521 (let* ((class (kernel::find-class name))
522 (kernel-supers (kernel:%class-direct-superclasses class))
523 (supers (mapcar #'kernel:%class-name kernel-supers)))
524 (without-package-locks
525 (ensure-class-using-class
526 existing-class name :metaclass metaclass :name name
527 :direct-superclasses supers
528 :direct-slots slots))))
529 (slot-initargs-from-structure-slotd (slotd)
530 (let ((accessor (structure-slotd-accessor-symbol slotd)))
531 `(:name ,(structure-slotd-name slotd)
532 :defstruct-accessor-symbol ,accessor
533 ,@(when (fboundp accessor)
534 `(:internal-reader-function
535 ,(structure-slotd-reader-function slotd)
536 :internal-writer-function
537 ,(structure-slotd-writer-function name slotd)))
538 :type ,(or (structure-slotd-type slotd) t)
539 :initform ,(structure-slotd-init-form slotd)
540 :initfunction ,(eval-form (structure-slotd-init-form slotd)))))
541 (slot-initargs-from-condition-slotd (slot)
542 `(:name ,(conditions::condition-slot-name slot)
543 :initargs ,(conditions::condition-slot-initargs slot)
544 :readers ,(conditions::condition-slot-readers slot)
545 :writers ,(conditions::condition-slot-writers slot)
546 ,@(when (conditions::condition-slot-initform-p slot)
547 (let ((form-or-fn (conditions::condition-slot-initform slot)))
548 (if (functionp form-or-fn)
549 `(:initfunction ,form-or-fn)
550 `(:initform ,form-or-fn
551 :initfunction ,(lambda () form-or-fn)))))
552 :allocation ,(conditions::condition-slot-allocation slot)
553 :documentation ,(conditions::condition-slot-documentation slot))))
554 (cond ((structure-type-p name)
555 (ensure 'structure-class
556 (mapcar #'slot-initargs-from-structure-slotd
557 (structure-type-slot-description-list name))))
558 ((condition-type-p name)
559 (let ((class (kernel::find-class name)))
560 (ensure 'condition-class
561 (mapcar #'slot-initargs-from-condition-slotd
562 (conditions::condition-class-slots class)))))
563 (t
564 (error _"~@<~S is not the name of a class.~@:>" name)))))
565
566 (defun reinitialize-structure-class (kernel-class)
567 (let ((class (kernel:%class-pcl-class kernel-class)))
568 (when class
569 (ensure-non-standard-class (class-name class) class))))
570
571 (when (boundp 'kernel::*defstruct-hooks*)
572 (pushnew 'reinitialize-structure-class
573 kernel::*defstruct-hooks*))
574
575
576 (defun method-function-returning-nil (args next-methods)
577 (declare (ignore args next-methods))
578 nil)
579
580 (defun method-function-returning-t (args next-methods)
581 (declare (ignore args next-methods))
582 t)
583
584 (defun make-class-predicate (class name)
585 (let* ((gf (without-package-locks (ensure-generic-function name)))
586 (mlist (if (eq *boot-state* 'complete)
587 (generic-function-methods gf)
588 (early-gf-methods gf))))
589 (unless mlist
590 (unless (eq class *the-class-t*)
591 (let* ((default-method-function #'method-function-returning-nil)
592 (default-method-initargs (list :function
593 default-method-function))
594 (default-method (make-a-method 'standard-method
595 ()
596 (list 'object)
597 (list *the-class-t*)
598 default-method-initargs
599 "class predicate default method")))
600 (setf (method-function-get default-method-function :constant-value) nil)
601 (add-method gf default-method)))
602 (let* ((class-method-function #'method-function-returning-t)
603 (class-method-initargs (list :function
604 class-method-function))
605 (class-method (make-a-method 'standard-method
606 ()
607 (list 'object)
608 (list class)
609 class-method-initargs
610 "class predicate class method")))
611 (setf (method-function-get class-method-function :constant-value) t)
612 (add-method gf class-method)))
613 gf))
614
615
616 ;;; Set inherits from CPL and register layout. This actually installs the
617 ;;; class in the lisp type system.
618 ;;;
619 (defun update-lisp-class-layout (class layout)
620 (let ((kernel-class (kernel:layout-class layout)))
621 (unless (eq (kernel:%class-layout kernel-class) layout)
622 (let ((cpl (class-precedence-list class)))
623 (setf (kernel:layout-inherits layout)
624 (kernel:order-layout-inherits
625 (map 'simple-vector #'class-wrapper
626 (reverse (rest cpl))))))
627 (kernel:register-layout layout :invalidate t)
628 ;;
629 ;; Subclasses of formerly forward-referenced-class may be unknown
630 ;; to lisp:find-class and also anonymous. This functionality moved
631 ;; here from (setf find-class).
632 (let ((name (class-name class)))
633 (setf (kernel::find-class name) kernel-class
634 (kernel:%class-name kernel-class) name)))))
635
636 #-loadable-pcl
637 (eval-when (:load-toplevel :execute)
638 (/show "Bootstrapping PCL")
639 (clrhash *find-class*)
640 (/show " meta braid")
641 (bootstrap-meta-braid)
642 (/show " accessor definitions 1")
643 (bootstrap-accessor-definitions t)
644 (/show " class predicates 1")
645 (bootstrap-class-predicates t)
646 (/show " accessor definitions 2")
647 (bootstrap-accessor-definitions nil)
648 (/show " class predicates 2")
649 (bootstrap-class-predicates nil)
650 (/show " built-in classes")
651 (bootstrap-built-in-classes)
652
653 (/show " class layouts")
654 (do-hash (name x *find-class*)
655 (let* ((class (find-class-from-cell name x))
656 (layout (class-wrapper class))
657 (lclass (kernel:layout-class layout))
658 (lclass-pcl-class (kernel:%class-pcl-class lclass))
659 (olclass (kernel::find-class name nil)))
660 (if lclass-pcl-class
661 (assert (eq class lclass-pcl-class))
662 (setf (kernel:%class-pcl-class lclass) class))
663
664 (update-lisp-class-layout class layout)
665
666 (if olclass
667 (assert (eq lclass olclass))
668 (setf (kernel::find-class name) lclass))
669
670 (set-class-translation class name)))
671
672 (/show "Boot state BRAID reached")
673 (setq *boot-state* 'braid))
674
675 (define-condition no-applicable-method-error (type-error)
676 ((function :reader no-applicable-method-function :initarg :function)
677 (arguments :reader no-applicable-method-arguments :initarg :arguments))
678 (:report (lambda (condition stream)
679 (format stream _"~@<No matching method for the generic function ~
680 ~S, when called with arguments ~S.~@:>"
681 (no-applicable-method-function condition)
682 (no-applicable-method-arguments condition)))))
683
684 (defmethod no-applicable-method (generic-function &rest args)
685 (cerror _"Retry call to ~S."
686 'no-applicable-method-error
687 :function generic-function
688 :arguments args)
689 (apply generic-function args))
690
691 (define-condition no-next-method-error (type-error)
692 ((method :reader no-next-method-method :initarg :method)
693 (arguments :reader no-next-method-arguments :initarg :arguments))
694 (:report (lambda (condition stream)
695 (format stream
696 _"~@<In method ~S: No next method for arguments ~S.~@:>"
697 (no-next-method-method condition)
698 (no-next-method-arguments condition)))))
699
700 (defmethod no-next-method ((generic-function standard-generic-function)
701 (method standard-method)
702 &rest args)
703 (cerror _"Try again." 'no-next-method-error :method method :arguments args)
704 (apply generic-function args))
705
706 (define-condition no-primary-method-error (no-applicable-method-error)
707 ()
708 (:report (lambda (condition stream)
709 (format stream _"~@<Generic function ~S: ~
710 No primary method given arguments ~S~@:>"
711 (no-applicable-method-function condition)
712 (no-applicable-method-arguments condition)))))
713
714 (defmethod no-primary-method ((generic-function standard-generic-function)
715 &rest args)
716 (cerror _"Try again." 'no-primary-method-error
717 :function generic-function :arguments args)
718 (apply generic-function args))
719
720 (defun %no-primary-method (gf args)
721 (apply #'no-primary-method gf args))
722
723 (defun %invalid-qualifiers (gf combin args methods)
724 (invalid-qualifiers gf combin args methods))
725
726 (defmethod invalid-qualifiers ((gf generic-function) combin args methods)
727 (if (null (cdr methods))
728 (error _"~@<In a call to ~s with arguments ~:s: ~
729 The method ~s has invalid qualifiers for method ~
730 combination ~s.~@:>"
731 gf args (car methods) combin)
732 (error _"~@<In a call to ~s with arguments ~:s: ~
733 The methods ~{~s~^, ~} have invalid qualifiers for ~
734 method combination ~s.~@:>"
735 gf args methods combin)))

  ViewVC Help
Powered by ViewVC 1.1.5