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 |
|
;;; Bootstrapping the meta-braid. |
28 |
|
;;; |
29 |
|
;;; The code in this file takes the early definitions that have been saved |
30 |
|
;;; up and actually builds those class objects. This work is largely driven |
31 |
|
;;; off of those class definitions, but the fact that STANDARD-CLASS is the |
32 |
|
;;; class of all metaclasses in the braid is built into this code pretty |
33 |
|
;;; deeply. |
34 |
|
;;; |
35 |
|
;;; |
36 |
|
|
37 |
|
(in-package :pcl) |
38 |
|
|
39 |
|
(defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p)) |
40 |
|
#-new-kcl-wrapper (declare (special *slot-unbound*)) |
41 |
|
#-new-kcl-wrapper |
42 |
|
(let ((instance (%%allocate-instance--class))) |
43 |
|
(setf (std-instance-wrapper instance) wrapper) |
44 |
|
(setf (std-instance-slots instance) |
45 |
|
(if slots-init-p |
46 |
|
(copy-slots slots-init) |
47 |
|
(make-array (wrapper-no-of-instance-slots wrapper) |
48 |
|
:initial-element *slot-unbound*))) |
49 |
|
instance) |
50 |
|
#+new-kcl-wrapper |
51 |
|
(apply #'si:make-structure wrapper |
52 |
|
(if slots-init-p |
53 |
|
slots-init |
54 |
|
(let ((no-of-slots (si::s-data-length wrapper))) |
55 |
|
(if (< no-of-slots (fill-pointer *init-vector*)) |
56 |
|
(aref *init-vector* no-of-slots) |
57 |
|
(get-init-list no-of-slots)))))) |
58 |
|
|
59 |
|
(defmacro allocate-funcallable-instance-slots (wrapper &optional |
60 |
|
slots-init-p slots-init) |
61 |
|
#-new-kcl-wrapper |
62 |
|
`(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper))) |
63 |
|
,(if slots-init-p |
64 |
|
`(if ,slots-init-p |
65 |
|
(copy-slots ,slots-init) |
66 |
|
(make-array no-of-slots :initial-element *slot-unbound*)) |
67 |
|
`(make-array no-of-slots :initial-element *slot-unbound*))) |
68 |
|
#+new-kcl-wrapper |
69 |
|
(if slots-init-p |
70 |
|
`(if ,slots-init-p |
71 |
|
(allocate-standard-instance ,wrapper ,slots-init) |
72 |
|
(allocate-standard-instance ,wrapper)) |
73 |
|
`(allocate-standard-instance ,wrapper))) |
74 |
|
|
75 |
|
(defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) |
76 |
|
(let ((fin (allocate-funcallable-instance-1))) |
77 |
|
(set-funcallable-instance-function |
78 |
|
fin |
79 |
|
(fin-lambda-fn (&rest args) |
80 |
|
(declare (ignore args)) |
81 |
|
(error "The function of the funcallable-instance ~S has not been set" fin))) |
82 |
|
(setf (fsc-instance-wrapper fin) wrapper |
83 |
|
(fsc-instance-slots fin) (allocate-funcallable-instance-slots |
84 |
|
wrapper slots-init-p slots-init)) |
85 |
|
fin)) |
86 |
|
|
87 |
|
(defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p)) |
88 |
|
#-new-kcl-wrapper |
89 |
|
(let* ((class (wrapper-class wrapper)) |
90 |
|
(constructor (class-defstruct-constructor class))) |
91 |
|
(if constructor |
92 |
|
(let ((instance (funcall constructor)) |
93 |
|
(slots (class-slots class))) |
94 |
|
(when slots-init-p |
95 |
|
(dotimes (i (length slots-init)) |
96 |
|
(let ((slot (pop slots))) |
97 |
|
(setf (slot-value-using-class class instance slot) |
98 |
|
(svref slots-init i))))) |
99 |
|
instance) |
100 |
|
(error "Can't allocate an instance of class ~S" (class-name class)))) |
101 |
|
#+new-kcl-wrapper |
102 |
|
(if slots-init-p |
103 |
|
(allocate-standard-instance wrapper slots-init) |
104 |
|
(allocate-standard-instance wrapper))) |
105 |
|
|
106 |
|
;;; |
107 |
|
;;; bootstrap-meta-braid |
108 |
|
;;; |
109 |
|
;;; This function builds the base metabraid from the early class definitions. |
110 |
|
;;; |
111 |
|
(defmacro initial-classes-and-wrappers (&rest classes) |
112 |
|
`(progn |
113 |
|
,@(mapcar #'(lambda (class) |
114 |
|
(let ((wr (intern (format nil "~A-WRAPPER" class) |
115 |
|
*the-pcl-package*))) |
116 |
|
`(setf ,wr ,(if (eq class 'standard-generic-function) |
117 |
|
'*sgf-wrapper* |
118 |
|
#-cmu17 |
119 |
|
`(make-wrapper (early-class-size ',class)) |
120 |
|
#+cmu17 |
121 |
|
`(boot-make-wrapper |
122 |
|
(early-class-size ',class) |
123 |
|
',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 |
|
#+new-kcl-wrapper (si::s-data-name ,wr) |
130 |
|
#+new-kcl-wrapper ',class |
131 |
|
(find-class ',class) ,class))) |
132 |
|
classes))) |
133 |
|
|
134 |
|
(defun bootstrap-meta-braid () |
135 |
|
(let* ((name 'class) |
136 |
|
(predicate-name (make-type-predicate-name name))) |
137 |
|
(setf (gdefinition predicate-name) |
138 |
|
#'(lambda (x) (declare (ignore x)) t)) |
139 |
|
(do-satisfies-deftype name predicate-name)) |
140 |
|
(let* ((*create-classes-from-internal-structure-definitions-p* nil) |
141 |
|
standard-class-wrapper standard-class |
142 |
|
funcallable-standard-class-wrapper funcallable-standard-class |
143 |
|
slot-class-wrapper slot-class |
144 |
|
built-in-class-wrapper built-in-class |
145 |
|
structure-class-wrapper structure-class |
146 |
|
standard-direct-slot-definition-wrapper standard-direct-slot-definition |
147 |
|
standard-effective-slot-definition-wrapper standard-effective-slot-definition |
148 |
|
class-eq-specializer-wrapper class-eq-specializer |
149 |
|
standard-generic-function-wrapper standard-generic-function) |
150 |
|
(initial-classes-and-wrappers |
151 |
|
standard-class funcallable-standard-class |
152 |
|
slot-class built-in-class structure-class |
153 |
|
standard-direct-slot-definition standard-effective-slot-definition |
154 |
|
class-eq-specializer standard-generic-function) |
155 |
|
;; |
156 |
|
;; First, make a class metaobject for each of the early classes. For |
157 |
|
;; each metaobject we also set its wrapper. Except for the class T, |
158 |
|
;; the wrapper is always that of STANDARD-CLASS. |
159 |
|
;; |
160 |
|
(dolist (definition *early-class-definitions*) |
161 |
|
(let* ((name (ecd-class-name definition)) |
162 |
|
(meta (ecd-metaclass definition)) |
163 |
|
(wrapper (ecase meta |
164 |
|
(slot-class slot-class-wrapper) |
165 |
|
(standard-class standard-class-wrapper) |
166 |
|
(funcallable-standard-class funcallable-standard-class-wrapper) |
167 |
|
(built-in-class built-in-class-wrapper) |
168 |
|
(structure-class structure-class-wrapper))) |
169 |
|
(class (or (find-class name nil) |
170 |
|
(allocate-standard-instance wrapper)))) |
171 |
|
(when (or (eq meta 'standard-class) (eq meta 'funcallable-standard-class)) |
172 |
|
(inform-type-system-about-std-class name)) |
173 |
|
(setf (find-class name) class))) |
174 |
|
;; |
175 |
|
;; |
176 |
|
;; |
177 |
|
(dolist (definition *early-class-definitions*) |
178 |
|
(let ((name (ecd-class-name definition)) |
179 |
|
(meta (ecd-metaclass definition)) |
180 |
|
(source (ecd-source definition)) |
181 |
|
(direct-supers (ecd-superclass-names definition)) |
182 |
|
(direct-slots (ecd-canonical-slots definition)) |
183 |
|
(other-initargs (ecd-other-initargs definition))) |
184 |
|
(let ((direct-default-initargs |
185 |
|
(getf other-initargs :direct-default-initargs))) |
186 |
|
(multiple-value-bind (slots cpl default-initargs direct-subclasses) |
187 |
|
(early-collect-inheritance name) |
188 |
|
(let* ((class (find-class name)) |
189 |
|
(wrapper (cond ((eq class slot-class) |
190 |
|
slot-class-wrapper) |
191 |
|
((eq class standard-class) |
192 |
|
standard-class-wrapper) |
193 |
|
((eq class funcallable-standard-class) |
194 |
|
funcallable-standard-class-wrapper) |
195 |
|
((eq class standard-direct-slot-definition) |
196 |
|
standard-direct-slot-definition-wrapper) |
197 |
|
((eq class standard-effective-slot-definition) |
198 |
|
standard-effective-slot-definition-wrapper) |
199 |
|
((eq class built-in-class) |
200 |
|
built-in-class-wrapper) |
201 |
|
((eq class structure-class) |
202 |
|
structure-class-wrapper) |
203 |
|
((eq class class-eq-specializer) |
204 |
|
class-eq-specializer-wrapper) |
205 |
|
((eq class standard-generic-function) |
206 |
|
standard-generic-function-wrapper) |
207 |
|
(t |
208 |
|
#-cmu17 |
209 |
|
(make-wrapper (length slots) class) |
210 |
|
#+cmu17 |
211 |
|
(boot-make-wrapper (length slots) name)))) |
212 |
|
(proto nil)) |
213 |
|
(when (eq name 't) (setq *the-wrapper-of-t* wrapper)) |
214 |
|
(set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) |
215 |
|
*the-pcl-package*) |
216 |
|
class) |
217 |
|
(dolist (slot slots) |
218 |
|
(unless (eq (getf slot :allocation :instance) :instance) |
219 |
|
(error "Slot allocation ~S not supported in bootstrap."))) |
220 |
|
|
221 |
|
(when #+cmu17 (typep wrapper 'wrapper) #-cmu17 t |
222 |
|
(setf (wrapper-instance-slots-layout wrapper) |
223 |
|
(mapcar #'canonical-slot-name slots)) |
224 |
|
(setf (wrapper-class-slots wrapper) |
225 |
|
())) |
226 |
|
|
227 |
|
(setq proto (if (eq meta 'funcallable-standard-class) |
228 |
|
(allocate-funcallable-instance wrapper) |
229 |
|
(allocate-standard-instance wrapper))) |
230 |
|
|
231 |
|
(setq direct-slots |
232 |
|
(bootstrap-make-slot-definitions |
233 |
|
name class direct-slots |
234 |
|
standard-direct-slot-definition-wrapper nil)) |
235 |
|
(setq slots |
236 |
|
(bootstrap-make-slot-definitions |
237 |
|
name class slots |
238 |
|
standard-effective-slot-definition-wrapper t)) |
239 |
|
|
240 |
|
(case meta |
241 |
|
((standard-class funcallable-standard-class) |
242 |
|
(bootstrap-initialize-class |
243 |
|
meta |
244 |
|
class name class-eq-specializer-wrapper source |
245 |
|
direct-supers direct-subclasses cpl wrapper proto |
246 |
|
direct-slots slots direct-default-initargs default-initargs)) |
247 |
|
(built-in-class ; *the-class-t* |
248 |
|
(bootstrap-initialize-class |
249 |
|
meta |
250 |
|
class name class-eq-specializer-wrapper source |
251 |
|
direct-supers direct-subclasses cpl wrapper proto)) |
252 |
|
(slot-class ; *the-class-slot-object* |
253 |
|
(bootstrap-initialize-class |
254 |
|
meta |
255 |
|
class name class-eq-specializer-wrapper source |
256 |
|
direct-supers direct-subclasses cpl wrapper proto)) |
257 |
|
(structure-class ; *the-class-structure-object* |
258 |
|
(bootstrap-initialize-class |
259 |
|
meta |
260 |
|
class name class-eq-specializer-wrapper source |
261 |
|
direct-supers direct-subclasses cpl wrapper)))))))) |
262 |
|
|
263 |
|
(let* ((smc-class (find-class 'standard-method-combination)) |
264 |
|
(smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper)) |
265 |
|
(smc (allocate-standard-instance smc-wrapper))) |
266 |
|
(flet ((set-slot (name value) |
267 |
|
(bootstrap-set-slot 'standard-method-combination smc name value))) |
268 |
|
(set-slot 'source (load-truename)) |
269 |
|
(set-slot 'type 'standard) |
270 |
|
(set-slot 'documentation "The standard method combination.") |
271 |
|
(set-slot 'options ())) |
272 |
|
(setq *standard-method-combination* smc)))) |
273 |
|
|
274 |
|
;;; |
275 |
|
;;; Initialize a class metaobject. |
276 |
|
;;; |
277 |
|
(defun bootstrap-initialize-class |
278 |
|
(metaclass-name class name |
279 |
|
class-eq-wrapper source direct-supers direct-subclasses cpl wrapper |
280 |
|
&optional proto direct-slots slots direct-default-initargs default-initargs) |
281 |
|
(flet ((classes (names) (mapcar #'find-class names)) |
282 |
|
(set-slot (slot-name value) |
283 |
|
(bootstrap-set-slot metaclass-name class slot-name value))) |
284 |
|
(set-slot 'name name) |
285 |
|
(set-slot 'source source) |
286 |
|
(set-slot 'type (if (eq class (find-class 't)) |
287 |
|
t |
288 |
|
`(class ,class))) |
289 |
|
(set-slot 'class-eq-specializer |
290 |
|
(let ((spec (allocate-standard-instance class-eq-wrapper))) |
291 |
|
(bootstrap-set-slot 'class-eq-specializer spec 'type |
292 |
|
`(class-eq ,class)) |
293 |
|
(bootstrap-set-slot 'class-eq-specializer spec 'object |
294 |
|
class) |
295 |
|
spec)) |
296 |
|
(set-slot 'class-precedence-list (classes cpl)) |
297 |
|
(set-slot 'can-precede-list (classes (cdr cpl))) |
298 |
|
(set-slot 'incompatible-superclass-list nil) |
299 |
|
(set-slot 'direct-superclasses (classes direct-supers)) |
300 |
|
(set-slot 'direct-subclasses (classes direct-subclasses)) |
301 |
|
(set-slot 'direct-methods (cons nil nil)) |
302 |
|
(set-slot 'wrapper wrapper) |
303 |
|
#+new-kcl-wrapper |
304 |
|
(setf (si::s-data-name wrapper) name) |
305 |
|
(set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) |
306 |
|
(make-class-predicate-name name))) |
307 |
|
(set-slot 'plist |
308 |
|
`(,@(and direct-default-initargs |
309 |
|
`(direct-default-initargs ,direct-default-initargs)) |
310 |
|
,@(and default-initargs |
311 |
|
`(default-initargs ,default-initargs)))) |
312 |
|
(when (memq metaclass-name '(standard-class funcallable-standard-class |
313 |
|
structure-class slot-class)) |
314 |
|
(set-slot 'direct-slots direct-slots) |
315 |
|
(set-slot 'slots slots) |
316 |
|
(set-slot 'initialize-info nil)) |
317 |
|
(if (eq metaclass-name 'structure-class) |
318 |
|
(let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) |
319 |
|
(set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) |
320 |
|
(make-class-predicate-name name))) |
321 |
|
(set-slot 'defstruct-form |
322 |
|
`(defstruct (structure-object (:constructor ,constructor-sym)))) |
323 |
|
(set-slot 'defstruct-constructor constructor-sym) |
324 |
|
(set-slot 'from-defclass-p t) |
325 |
|
(set-slot 'plist nil) |
326 |
|
(set-slot 'prototype (funcall constructor-sym))) |
327 |
|
(set-slot 'prototype (or proto (allocate-standard-instance wrapper)))) |
328 |
|
class)) |
329 |
|
|
330 |
|
(defun bootstrap-make-slot-definitions (name class slots wrapper effective-p) |
331 |
|
(let ((index -1)) |
332 |
|
(mapcar #'(lambda (slot) |
333 |
|
(incf index) |
334 |
|
(bootstrap-make-slot-definition |
335 |
|
name class slot wrapper effective-p index)) |
336 |
|
slots))) |
337 |
|
|
338 |
|
(defun bootstrap-make-slot-definition (name class slot wrapper effective-p index) |
339 |
|
(let* ((slotd-class-name (if effective-p |
340 |
|
'standard-effective-slot-definition |
341 |
|
'standard-direct-slot-definition)) |
342 |
|
(slotd (allocate-standard-instance wrapper)) |
343 |
|
(slot-name (getf slot :name))) |
344 |
|
(flet ((get-val (name) (getf slot name)) |
345 |
|
(set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val))) |
346 |
|
(set-val 'name slot-name) |
347 |
|
(set-val 'initform (get-val :initform)) |
348 |
|
(set-val 'initfunction (get-val :initfunction)) |
349 |
|
(set-val 'initargs (get-val :initargs)) |
350 |
|
(set-val 'readers (get-val :readers)) |
351 |
|
(set-val 'writers (get-val :writers)) |
352 |
|
(set-val 'allocation :instance) |
353 |
|
(set-val 'type (or (get-val :type) t)) |
354 |
|
(set-val 'documentation (or (get-val :documentation) "")) |
355 |
|
(set-val 'class class) |
356 |
|
(when effective-p |
357 |
|
(set-val 'location index) |
358 |
|
(let ((fsc-p nil)) |
359 |
|
(set-val 'reader-function (make-optimized-std-reader-method-function |
360 |
|
fsc-p slot-name index)) |
361 |
|
(set-val 'writer-function (make-optimized-std-writer-method-function |
362 |
|
fsc-p slot-name index)) |
363 |
|
(set-val 'boundp-function (make-optimized-std-boundp-method-function |
364 |
|
fsc-p slot-name index))) |
365 |
|
(set-val 'accessor-flags 7) |
366 |
|
(let ((table (or (gethash slot-name *name->class->slotd-table*) |
367 |
|
(setf (gethash slot-name *name->class->slotd-table*) |
368 |
|
(make-hash-table :test 'eq :size 5))))) |
369 |
|
(setf (gethash class table) slotd))) |
370 |
|
(when (and (eq name 'standard-class) |
371 |
|
(eq slot-name 'slots) effective-p) |
372 |
|
(setq *the-eslotd-standard-class-slots* slotd)) |
373 |
|
(when (and (eq name 'funcallable-standard-class) |
374 |
|
(eq slot-name 'slots) effective-p) |
375 |
|
(setq *the-eslotd-funcallable-standard-class-slots* slotd)) |
376 |
|
slotd))) |
377 |
|
|
378 |
|
(defun bootstrap-accessor-definitions (early-p) |
379 |
|
(let ((*early-p* early-p)) |
380 |
|
(dolist (definition *early-class-definitions*) |
381 |
|
(let ((name (ecd-class-name definition)) |
382 |
|
(meta (ecd-metaclass definition))) |
383 |
|
(unless (eq meta 'built-in-class) |
384 |
|
(let ((direct-slots (ecd-canonical-slots definition))) |
385 |
|
(dolist (slotd direct-slots) |
386 |
|
(let ((slot-name (getf slotd :name)) |
387 |
|
(readers (getf slotd :readers)) |
388 |
|
(writers (getf slotd :writers))) |
389 |
|
(bootstrap-accessor-definitions1 name slot-name readers writers nil) |
390 |
|
(bootstrap-accessor-definitions1 |
391 |
|
'slot-object |
392 |
|
slot-name |
393 |
|
(list (slot-reader-symbol slot-name)) |
394 |
|
(list (slot-writer-symbol slot-name)) |
395 |
|
(list (slot-boundp-symbol slot-name))))))))))) |
396 |
|
|
397 |
|
(defun bootstrap-accessor-definition (class-name accessor-name slot-name type) |
398 |
|
(multiple-value-bind (accessor-class make-method-function arglist specls doc) |
399 |
|
(ecase type |
400 |
|
(reader (values 'standard-reader-method #'make-std-reader-method-function |
401 |
|
(list class-name) (list class-name) |
402 |
|
"automatically generated reader method")) |
403 |
|
(writer (values 'standard-writer-method #'make-std-writer-method-function |
404 |
|
(list 'new-value class-name) (list 't class-name) |
405 |
|
"automatically generated writer method")) |
406 |
|
(boundp (values 'standard-boundp-method #'make-std-boundp-method-function |
407 |
|
(list class-name) (list class-name) |
408 |
|
"automatically generated boundp method"))) |
409 |
|
(let ((gf (ensure-generic-function accessor-name))) |
410 |
|
(if (find specls (early-gf-methods gf) |
411 |
|
:key #'early-method-specializers |
412 |
|
:test #'equal) |
413 |
|
(unless (assoc accessor-name *generic-function-fixups* |
414 |
|
:test #'equal) |
415 |
|
(update-dfun gf)) |
416 |
|
(add-method gf |
417 |
|
(make-a-method accessor-class |
418 |
|
() |
419 |
|
arglist specls |
420 |
|
(funcall make-method-function |
421 |
|
class-name slot-name) |
422 |
|
doc |
423 |
|
slot-name)))))) |
424 |
|
|
425 |
|
(defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps) |
426 |
|
(flet ((do-reader-definition (reader) |
427 |
|
(bootstrap-accessor-definition class-name reader slot-name 'reader)) |
428 |
|
(do-writer-definition (writer) |
429 |
|
(bootstrap-accessor-definition class-name writer slot-name 'writer)) |
430 |
|
(do-boundp-definition (boundp) |
431 |
|
(bootstrap-accessor-definition class-name boundp slot-name 'boundp))) |
432 |
|
(dolist (reader readers) (do-reader-definition reader)) |
433 |
|
(dolist (writer writers) (do-writer-definition writer)) |
434 |
|
(dolist (boundp boundps) (do-boundp-definition boundp)))) |
435 |
|
|
436 |
|
(defun bootstrap-class-predicates (early-p) |
437 |
|
(let ((*early-p* early-p)) |
438 |
|
(dolist (definition *early-class-definitions*) |
439 |
|
(let* ((name (ecd-class-name definition)) |
440 |
|
(class (find-class name))) |
441 |
|
(setf (find-class-predicate name) |
442 |
|
(make-class-predicate class (class-predicate-name class))))))) |
443 |
|
|
444 |
|
(defun bootstrap-built-in-classes () |
445 |
|
;; |
446 |
|
;; First make sure that all the supers listed in *built-in-class-lattice* |
447 |
|
;; are themselves defined by *built-in-class-lattice*. This is just to |
448 |
|
;; check for typos and other sorts of brainos. |
449 |
|
;; |
450 |
|
(dolist (e *built-in-classes*) |
451 |
|
(dolist (super (cadr e)) |
452 |
|
(unless (or (eq super 't) |
453 |
|
(assq super *built-in-classes*)) |
454 |
|
(error "In *built-in-classes*: ~S has ~S as a super,~%~ |
455 |
|
but ~S is not itself a class in *built-in-classes*." |
456 |
|
(car e) super super)))) |
457 |
|
|
458 |
|
;; |
459 |
|
;; In the first pass, we create a skeletal object to be bound to the |
460 |
|
;; class name. |
461 |
|
;; |
462 |
|
(let* ((built-in-class (find-class 'built-in-class)) |
463 |
|
(built-in-class-wrapper (class-wrapper built-in-class))) |
464 |
|
(dolist (e *built-in-classes*) |
465 |
|
(let ((class (allocate-standard-instance built-in-class-wrapper))) |
466 |
|
(setf (find-class (car e)) class)))) |
467 |
|
|
468 |
|
;; |
469 |
|
;; In the second pass, we initialize the class objects. |
470 |
|
;; |
471 |
|
(let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer)))) |
472 |
|
(dolist (e *built-in-classes*) |
473 |
|
; FIXME use regular destructuring-bind |
474 |
|
(pcl-destructuring-bind (name supers subs cpl prototype) e |
475 |
|
(let* ((class (find-class name)) |
476 |
|
#+cmu17 |
477 |
|
(lclass (lisp:find-class name)) |
478 |
|
(wrapper #-cmu17(make-wrapper 0 class) |
479 |
|
#+cmu17(kernel:class-layout lclass))) |
480 |
|
(set (get-built-in-class-symbol name) class) |
481 |
|
(set (get-built-in-wrapper-symbol name) wrapper) |
482 |
|
#+cmu17 |
483 |
|
(setf (kernel:class-pcl-class lclass) class) |
484 |
|
#-cmu17 |
485 |
|
(setf (wrapper-instance-slots-layout wrapper) () |
486 |
|
(wrapper-class-slots wrapper) ()) |
487 |
|
|
488 |
|
(bootstrap-initialize-class 'built-in-class class |
489 |
|
name class-eq-wrapper nil |
490 |
|
supers subs |
491 |
|
(cons name cpl) |
492 |
|
wrapper prototype))))) |
493 |
|
|
494 |
|
(dolist (e *built-in-classes*) |
495 |
|
(let* ((name (car e)) |
496 |
|
(class (find-class name))) |
497 |
|
(setf (find-class-predicate name) |
498 |
|
(make-class-predicate class (class-predicate-name class)))))) |
499 |
|
|
500 |
|
|
501 |
|
;;; |
502 |
|
;;; |
503 |
|
;;; |
504 |
|
#-(or new-kcl-wrapper cmu17) |
505 |
|
(progn |
506 |
|
(defvar *built-in-or-structure-wrapper-table* |
507 |
|
(make-hash-table :test 'eq)) |
508 |
|
|
509 |
|
(defvar wft-type1 nil) |
510 |
|
(defvar wft-wrapper1 nil) |
511 |
|
(defvar wft-type2 nil) |
512 |
|
(defvar wft-wrapper2 nil) |
513 |
|
|
514 |
|
(defun wrapper-for-structure (x) |
515 |
|
(let ((type (structure-type x))) |
516 |
|
(when (symbolp type) |
517 |
|
(cond ((eq type 'std-instance) |
518 |
|
(return-from wrapper-for-structure (std-instance-wrapper x))) |
519 |
|
((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1)) |
520 |
|
((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2)) |
521 |
|
(t (setq wft-type2 wft-type1 wft-wrapper2 wft-wrapper1)))) |
522 |
|
(let* ((cell (find-class-cell type)) |
523 |
|
(class (or (find-class-cell-class cell) |
524 |
|
(let* (#+lucid |
525 |
|
(*structure-type* type) |
526 |
|
#+lucid |
527 |
|
(*structure-length* (structure-length x type))) |
528 |
|
(find-class-from-cell type cell)))) |
529 |
|
(wrapper (if class (class-wrapper class) *the-wrapper-of-t*))) |
530 |
|
(when (symbolp type) |
531 |
|
(setq wft-type1 type wft-wrapper1 wrapper)) |
532 |
|
wrapper))) |
533 |
|
|
534 |
|
(defun built-in-or-structure-wrapper1 (x) |
535 |
|
(let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*))) |
536 |
|
(or (and (eq biw *the-wrapper-of-t*) |
537 |
|
(structurep x) |
538 |
|
(let* ((type (type-of x)) |
539 |
|
#+lucid |
540 |
|
(*structure-type* type) |
541 |
|
#+lucid |
542 |
|
(*structure-length* (structure-length x type)) |
543 |
|
(class (find-class type nil))) |
544 |
|
(and class (class-wrapper class)))) |
545 |
|
biw))) |
546 |
|
) |
547 |
|
|
548 |
|
#|| ; moved to low.lisp |
549 |
|
(defmacro built-in-or-structure-wrapper (x) |
550 |
|
(once-only (x) |
551 |
|
(if (structure-functions-exist-p) ; otherwise structurep is too slow for this |
552 |
|
`(if (structurep ,x) |
553 |
|
(wrapper-for-structure ,x) |
554 |
|
(if (symbolp ,x) |
555 |
|
(if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) |
556 |
|
(built-in-wrapper-of ,x))) |
557 |
|
`(or (and (symbolp ,x) |
558 |
|
(if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) |
559 |
|
(built-in-or-structure-wrapper1 ,x))))) |
560 |
|
|
561 |
|
#-cmu17 |
562 |
|
(defmacro wrapper-of-macro (x) |
563 |
|
`(cond ((std-instance-p ,x) |
564 |
|
(std-instance-wrapper ,x)) |
565 |
|
((fsc-instance-p ,x) |
566 |
|
(fsc-instance-wrapper ,x)) |
567 |
|
(t |
568 |
|
(#+new-kcl-wrapper built-in-wrapper-of |
569 |
|
#-new-kcl-wrapper built-in-or-structure-wrapper |
570 |
|
,x)))) |
571 |
|
|
572 |
|
#+cmu17 |
573 |
|
(defmacro wrapper-of-macro (x) |
574 |
|
`(kernel:layout-of ,x)) |
575 |
|
||# |
576 |
|
|
577 |
|
(defun class-of (x) |
578 |
|
(wrapper-class* (wrapper-of-macro x))) |
579 |
|
|
580 |
|
#+cmu17 |
581 |
|
(declaim (inline wrapper-of)) |
582 |
|
(defun wrapper-of (x) |
583 |
|
(wrapper-of-macro x)) |
584 |
|
|
585 |
|
#-cmu17 |
586 |
|
(defun structure-wrapper (x) |
587 |
|
(class-wrapper (find-class (structure-type x)))) |
588 |
|
|
589 |
|
(defvar find-structure-class nil) |
590 |
|
|
591 |
|
(defun eval-form (form) |
592 |
|
#'(lambda () (eval form))) |
593 |
|
|
594 |
|
(defun slot-initargs-from-structure-slotd (slotd) |
595 |
|
`(:name ,(structure-slotd-name slotd) |
596 |
|
:defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd) |
597 |
|
:internal-reader-function ,(structure-slotd-reader-function slotd) |
598 |
|
:internal-writer-function ,(structure-slotd-writer-function slotd) |
599 |
|
:type ,(or (structure-slotd-type slotd) t) |
600 |
|
:initform ,(structure-slotd-init-form slotd) |
601 |
|
:initfunction ,(eval-form (structure-slotd-init-form slotd)))) |
602 |
|
|
603 |
|
(defun find-structure-class (symbol) |
604 |
|
(if (structure-type-p symbol) |
605 |
|
(unless (eq find-structure-class symbol) |
606 |
|
(let ((find-structure-class symbol)) |
607 |
|
(ensure-class symbol |
608 |
|
:metaclass 'structure-class |
609 |
|
:name symbol |
610 |
|
:direct-superclasses |
611 |
|
(when (structure-type-included-type-name symbol) |
612 |
|
(list (structure-type-included-type-name symbol))) |
613 |
|
:direct-slots |
614 |
|
(mapcar #'slot-initargs-from-structure-slotd |
615 |
|
(structure-type-slot-description-list symbol))))) |
616 |
|
(error "~S is not a legal structure class name." symbol))) |
617 |
|
|
618 |
|
#-cmu17 |
619 |
|
(eval-when (compile eval) |
620 |
|
|
621 |
|
(defun make-built-in-class-subs () |
622 |
|
(mapcar #'(lambda (e) |
623 |
|
(let ((class (car e)) |
624 |
|
(class-subs ())) |
625 |
|
(dolist (s *built-in-classes*) |
626 |
|
(when (memq class (cadr s)) (pushnew (car s) class-subs))) |
627 |
|
(cons class class-subs))) |
628 |
|
(cons '(t) *built-in-classes*))) |
629 |
|
|
630 |
|
(defun make-built-in-class-tree () |
631 |
|
(let ((subs (make-built-in-class-subs))) |
632 |
|
(labels ((descend (class) |
633 |
|
(cons class (mapcar #'descend (cdr (assq class subs)))))) |
634 |
|
(descend 't)))) |
635 |
|
|
636 |
|
(defun make-built-in-wrapper-of-body () |
637 |
|
(make-built-in-wrapper-of-body-1 (make-built-in-class-tree) |
638 |
|
'x |
639 |
|
#'get-built-in-wrapper-symbol)) |
640 |
|
|
641 |
|
(defun make-built-in-wrapper-of-body-1 (tree var get-symbol) |
642 |
|
(let ((*specials* ())) |
643 |
|
(declare (special *specials*)) |
644 |
|
(let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol))) |
645 |
|
`(locally (declare (special .,*specials*)) ,inner)))) |
646 |
|
|
647 |
|
(defun make-built-in-wrapper-of-body-2 (tree var get-symbol) |
648 |
|
(declare (special *specials*)) |
649 |
|
(let ((symbol (funcall get-symbol (car tree)))) |
650 |
|
(push symbol *specials*) |
651 |
|
(let ((sub-tests |
652 |
|
(mapcar #'(lambda (x) |
653 |
|
(make-built-in-wrapper-of-body-2 x var get-symbol)) |
654 |
|
(cdr tree)))) |
655 |
|
`(and (typep ,var ',(car tree)) |
656 |
|
,(if sub-tests |
657 |
|
`(or ,.sub-tests ,symbol) |
658 |
|
symbol))))) |
659 |
|
) |
660 |
|
|
661 |
|
#-cmu17 |
662 |
|
(defun built-in-wrapper-of (x) |
663 |
|
#.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file |
664 |
|
(make-built-in-wrapper-of-body))) |
665 |
|
|
666 |
|
|
667 |
|
|
668 |
|
(defun method-function-returning-nil (args next-methods) |
669 |
|
(declare (ignore args next-methods)) |
670 |
|
nil) |
671 |
|
|
672 |
|
(defun method-function-returning-t (args next-methods) |
673 |
|
(declare (ignore args next-methods)) |
674 |
|
t) |
675 |
|
|
676 |
|
(defun make-class-predicate (class name) |
677 |
|
(let* ((gf (ensure-generic-function name)) |
678 |
|
(mlist (if (eq *boot-state* 'complete) |
679 |
|
(generic-function-methods gf) |
680 |
|
(early-gf-methods gf)))) |
681 |
|
(unless mlist |
682 |
|
(unless (eq class *the-class-t*) |
683 |
|
(let* ((default-method-function #'method-function-returning-nil) |
684 |
|
(default-method-initargs (list :function |
685 |
|
default-method-function)) |
686 |
|
(default-method (make-a-method 'standard-method |
687 |
|
() |
688 |
|
(list 'object) |
689 |
|
(list *the-class-t*) |
690 |
|
default-method-initargs |
691 |
|
"class predicate default method"))) |
692 |
|
(setf (method-function-get default-method-function :constant-value) nil) |
693 |
|
(add-method gf default-method))) |
694 |
|
(let* ((class-method-function #'method-function-returning-t) |
695 |
|
(class-method-initargs (list :function |
696 |
|
class-method-function)) |
697 |
|
(class-method (make-a-method 'standard-method |
698 |
|
() |
699 |
|
(list 'object) |
700 |
|
(list class) |
701 |
|
class-method-initargs |
702 |
|
"class predicate class method"))) |
703 |
|
(setf (method-function-get class-method-function :constant-value) t) |
704 |
|
(add-method gf class-method))) |
705 |
|
gf)) |
706 |
|
|
707 |
|
|
708 |
|
#+cmu17 |
709 |
|
;;; Set inherits from CPL and register layout. This actually installs the |
710 |
|
;;; class in the lisp type system. |
711 |
|
;;; |
712 |
|
(defun update-lisp-class-layout (class layout) |
713 |
|
(unless (eq (kernel:class-layout (kernel:layout-class layout)) |
714 |
|
layout) |
715 |
|
(setf (kernel:layout-inherits layout) |
716 |
|
(map 'vector #'class-wrapper |
717 |
|
(reverse (rest (class-precedence-list class))))) |
718 |
|
|
719 |
|
(kernel:register-layout layout :invalidate nil))) |
720 |
|
|
721 |
|
(eval-when (load eval) |
722 |
|
(clrhash *find-class*) |
723 |
|
(bootstrap-meta-braid) |
724 |
|
(bootstrap-accessor-definitions t) |
725 |
|
(bootstrap-class-predicates t) |
726 |
|
(bootstrap-accessor-definitions nil) |
727 |
|
(bootstrap-class-predicates nil) |
728 |
|
(bootstrap-built-in-classes) |
729 |
|
|
730 |
|
#+cmu17 |
731 |
|
(ext:do-hash (name x *find-class*) |
732 |
|
(let* ((class (find-class-from-cell name x)) |
733 |
|
(layout (class-wrapper class)) |
734 |
|
(lclass (kernel:layout-class layout)) |
735 |
|
(lclass-pcl-class (kernel:class-pcl-class lclass)) |
736 |
|
(olclass (lisp:find-class name nil))) |
737 |
|
(if lclass-pcl-class |
738 |
|
(assert (eq class lclass-pcl-class)) |
739 |
|
(setf (kernel:class-pcl-class lclass) class)) |
740 |
|
|
741 |
|
(update-lisp-class-layout class layout) |
742 |
|
|
743 |
|
(cond (olclass |
744 |
|
(assert (eq lclass olclass))) |
745 |
|
(t |
746 |
|
(setf (lisp:find-class name) lclass))))) |
747 |
|
|
748 |
|
(setq *boot-state* 'braid) |
749 |
|
) |
750 |
|
|
751 |
|
#-cmu17 |
752 |
|
(deftype slot-object () |
753 |
|
'(or standard-object structure-object)) |
754 |
|
|
755 |
|
(defmethod no-applicable-method (generic-function &rest args) |
756 |
|
(cerror "Retry call to ~S" |
757 |
|
"No matching method for the generic-function ~S,~@ |
758 |
|
when called with arguments ~S." |
759 |
|
generic-function args) |
760 |
|
(apply generic-function args)) |
761 |
|
|
762 |
|
(defmethod no-next-method ((generic-function standard-generic-function) |
763 |
|
(method standard-method) |
764 |
|
&rest args) |
765 |
|
(cerror "Try again." |
766 |
|
"No next method to ~S when calling generic function ~S with arguments ~S~%" |
767 |
|
method generic-function args) |
768 |
|
(apply generic-function args)) |
769 |
|
|
770 |
|
(defmethod no-primary-method ((generic-function standard-generic-function) |
771 |
|
&rest args) |
772 |
|
(cerror "Try again." |
773 |
|
"No primary method when calling generic function ~S with arguments ~S~%" |
774 |
|
generic-function args) |
775 |
|
(apply generic-function args)) |
776 |
|
|
777 |
|
(defmethod invalid-qualifiers ((gf generic-function) combin args methods) |
778 |
|
(if (null (cdr methods)) |
779 |
|
(error "~@<In a call to ~s with arguments ~:s: ~ |
780 |
|
The method ~s has invalid qualifiers for method ~ |
781 |
|
combination ~s.~@:>" |
782 |
|
gf args (car methods) combin) |
783 |
|
(error "~@<In a call to ~s with arguments ~:s: ~ |
784 |
|
The methods ~{~s~^, ~} have invalid qualifiers for ~ |
785 |
|
method combination ~s.~@:>" |
786 |
|
gf args methods combin))) |
787 |
|
|
788 |
|
(defun %no-primary-method (gf args) |
789 |
|
(apply #'no-primary-method gf args)) |
790 |
|
|
791 |
|
(defun %invalid-qualifiers (gf combin args methods) |
792 |
|
(invalid-qualifiers gf combin args methods)) |
793 |
|
|