1 |
|
;;;-*-Mode:LISP; Package:(PCL LISP 1000); 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 |
|
|
28 |
|
(in-package :pcl) |
29 |
|
|
30 |
|
(eval-when (compile load eval) |
31 |
|
|
32 |
|
(defvar *defclass-times* '(load eval)) ;Probably have to change this |
33 |
|
;if you use defconstructor. |
34 |
|
(defvar *defmethod-times* '(load eval)) |
35 |
|
(defvar *defgeneric-times* '(load eval)) |
36 |
|
|
37 |
|
; defvar is now actually in macros |
38 |
|
;(defvar *boot-state* ()) ;NIL |
39 |
|
;EARLY |
40 |
|
;BRAID |
41 |
|
;COMPLETE |
42 |
|
) |
43 |
|
|
44 |
|
(eval-when (load eval) |
45 |
|
(when (eq *boot-state* 'complete) |
46 |
|
(error "Trying to load (or compile) PCL in an environment in which it~%~ |
47 |
|
has already been loaded. This doesn't work, you will have to~%~ |
48 |
|
get a fresh lisp (reboot) and then load PCL.")) |
49 |
|
(when *boot-state* |
50 |
|
(cerror "Try loading (or compiling) PCL anyways." |
51 |
|
"Trying to load (or compile) PCL in an environment in which it~%~ |
52 |
|
has already been partially loaded. This may not work, you may~%~ |
53 |
|
need to get a fresh lisp (reboot) and then load PCL.")) |
54 |
|
) |
55 |
|
|
56 |
|
|
57 |
|
|
58 |
|
;;; |
59 |
|
;;; This is like fdefinition on the Lispm. If Common Lisp had something like |
60 |
|
;;; function specs I wouldn't need this. On the other hand, I don't like the |
61 |
|
;;; way this really works so maybe function specs aren't really right either? |
62 |
|
;;; |
63 |
|
;;; I also don't understand the real implications of a Lisp-1 on this sort of |
64 |
|
;;; thing. Certainly some of the lossage in all of this is because these |
65 |
|
;;; SPECs name global definitions. |
66 |
|
;;; |
67 |
|
;;; Note that this implementation is set up so that an implementation which |
68 |
|
;;; has a 'real' function spec mechanism can use that instead and in that way |
69 |
|
;;; get rid of setf generic function names. |
70 |
|
;;; |
71 |
|
(defmacro parse-gspec (spec |
72 |
|
(non-setf-var . non-setf-case) |
73 |
|
(setf-var . setf-case)) |
74 |
|
(declare (indentation 1 1)) |
75 |
|
#+setf (declare (ignore setf-var setf-case)) |
76 |
|
(once-only (spec) |
77 |
|
`(cond (#-setf (symbolp ,spec) #+setf t |
78 |
|
(let ((,non-setf-var ,spec)) ,@non-setf-case)) |
79 |
|
#-setf |
80 |
|
((and (listp ,spec) |
81 |
|
(eq (car ,spec) 'setf) |
82 |
|
(symbolp (cadr ,spec))) |
83 |
|
(let ((,setf-var (cadr ,spec))) ,@setf-case)) |
84 |
|
#-setf |
85 |
|
(t |
86 |
|
(error |
87 |
|
"Can't understand ~S as a generic function specifier.~%~ |
88 |
|
It must be either a symbol which can name a function or~%~ |
89 |
|
a list like ~S, where the car is the symbol ~S and the cadr~%~ |
90 |
|
is a symbol which can name a generic function." |
91 |
|
,spec '(setf <foo>) 'setf))))) |
92 |
|
|
93 |
|
;;; |
94 |
|
;;; If symbol names a function which is traced or advised, return the |
95 |
|
;;; unadvised, traced etc. definition. This lets me get at the generic |
96 |
|
;;; function object even when it is traced. |
97 |
|
;;; |
98 |
|
(defun unencapsulated-fdefinition (symbol) |
99 |
|
#+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol)) |
100 |
|
#+Lucid (lucid::get-unadvised-procedure (symbol-function symbol)) |
101 |
|
#+excl (or (excl::encapsulated-basic-definition symbol) |
102 |
|
(symbol-function symbol)) |
103 |
|
#+xerox (il:virginfn symbol) |
104 |
|
#+setf (fdefinition symbol) |
105 |
|
; #+kcl (symbol-function |
106 |
|
; (let ((sym (when (symbolp symbol) (get symbol 'si::traced))) first-form) |
107 |
|
; (if (and sym |
108 |
|
; (consp (symbol-function symbol)) |
109 |
|
; (consp (setq first-form (nth 3 (symbol-function symbol)))) |
110 |
|
; (eq (car first-form) 'si::trace-call)) |
111 |
|
; sym |
112 |
|
; symbol))) |
113 |
|
#-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol)) |
114 |
|
|
115 |
|
;;; |
116 |
|
;;; If symbol names a function which is traced or advised, redefine |
117 |
|
;;; the `real' definition without affecting the advise. |
118 |
|
;;; |
119 |
|
(defun fdefine-carefully (name new-definition) |
120 |
|
#+Lispm (si:fdefine name new-definition t t) |
121 |
|
#+Lucid (let ((lucid::*redefinition-action* nil)) |
122 |
|
(setf (symbol-function name) new-definition)) |
123 |
|
#+excl (setf (symbol-function name) new-definition) |
124 |
|
#+xerox (let ((advisedp (member name il:advisedfns :test #'eq)) |
125 |
|
(brokenp (member name il:brokenfns :test #'eq))) |
126 |
|
;; In XeroxLisp (late of envos) tracing is implemented |
127 |
|
;; as a special case of "breaking". Advising, however, |
128 |
|
;; is treated specially. |
129 |
|
(xcl:unadvise-function name :no-error t) |
130 |
|
(xcl:unbreak-function name :no-error t) |
131 |
|
(setf (symbol-function name) new-definition) |
132 |
|
(when brokenp (xcl:rebreak-function name)) |
133 |
|
(when advisedp (xcl:readvise-function name))) |
134 |
|
;; FIXME add setf expander for fdefinition -- right now we go through |
135 |
|
;; the following code which expands to a call to si::fset |
136 |
|
#+(and setf (not cmu) (not kcl)) (setf (fdefinition name) new-definition) |
137 |
|
#+kcl (setf (symbol-function |
138 |
|
(let ((sym (when (symbolp name) (get name 'si::traced))) first-form) |
139 |
|
(if (and sym |
140 |
|
(consp (symbol-function name)) |
141 |
|
(consp (setq first-form |
142 |
|
(nth 3 (symbol-function name)))) |
143 |
|
(eq (car first-form) 'si::trace-call)) |
144 |
|
sym |
145 |
|
name))) |
146 |
|
new-definition) |
147 |
|
#+cmu (progn |
148 |
|
(c::%%defun name new-definition nil) |
149 |
|
(c::note-name-defined name :function) |
150 |
|
new-definition) |
151 |
|
#-(or Lispm Lucid excl Xerox setf kcl cmu) |
152 |
|
(setf (symbol-function name) new-definition)) |
153 |
|
|
154 |
|
(defun gboundp (spec) |
155 |
|
(parse-gspec spec |
156 |
|
(name (fboundp name)) |
157 |
|
(name (fboundp (get-setf-function-name name))))) |
158 |
|
|
159 |
|
(defun gmakunbound (spec) |
160 |
|
(parse-gspec spec |
161 |
|
(name (fmakunbound name)) |
162 |
|
(name (fmakunbound (get-setf-function-name name))))) |
163 |
|
|
164 |
|
(defun gdefinition (spec) |
165 |
|
(parse-gspec spec |
166 |
|
(name (or #-setf (macro-function name) ;?? |
167 |
|
(unencapsulated-fdefinition name))) |
168 |
|
(name (unencapsulated-fdefinition (get-setf-function-name name))))) |
169 |
|
|
170 |
|
(defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec) |
171 |
|
(parse-gspec spec |
172 |
|
(name (fdefine-carefully name new-value)) |
173 |
|
(name (fdefine-carefully (get-setf-function-name name) new-value)))) |
174 |
|
|
175 |
|
|
176 |
|
(proclaim '(special *the-class-t* |
177 |
|
*the-class-vector* *the-class-symbol* |
178 |
|
*the-class-string* *the-class-sequence* |
179 |
|
*the-class-rational* *the-class-ratio* |
180 |
|
*the-class-number* *the-class-null* *the-class-list* |
181 |
|
*the-class-integer* *the-class-float* *the-class-cons* |
182 |
|
*the-class-complex* *the-class-character* |
183 |
|
*the-class-bit-vector* *the-class-array* |
184 |
|
|
185 |
|
*the-class-slot-object* |
186 |
|
*the-class-standard-object* |
187 |
|
*the-class-structure-object* |
188 |
|
*the-class-class* |
189 |
|
*the-class-generic-function* |
190 |
|
*the-class-built-in-class* |
191 |
|
*the-class-slot-class* |
192 |
|
*the-class-structure-class* |
193 |
|
*the-class-standard-class* |
194 |
|
*the-class-funcallable-standard-class* |
195 |
|
*the-class-method* |
196 |
|
*the-class-standard-method* |
197 |
|
*the-class-standard-reader-method* |
198 |
|
*the-class-standard-writer-method* |
199 |
|
*the-class-standard-boundp-method* |
200 |
|
*the-class-standard-generic-function* |
201 |
|
*the-class-standard-effective-slot-definition* |
202 |
|
|
203 |
|
*the-eslotd-standard-class-slots* |
204 |
|
*the-eslotd-funcallable-standard-class-slots*)) |
205 |
|
|
206 |
|
(proclaim '(special *the-wrapper-of-t* |
207 |
|
*the-wrapper-of-vector* *the-wrapper-of-symbol* |
208 |
|
*the-wrapper-of-string* *the-wrapper-of-sequence* |
209 |
|
*the-wrapper-of-rational* *the-wrapper-of-ratio* |
210 |
|
*the-wrapper-of-number* *the-wrapper-of-null* |
211 |
|
*the-wrapper-of-list* *the-wrapper-of-integer* |
212 |
|
*the-wrapper-of-float* *the-wrapper-of-cons* |
213 |
|
*the-wrapper-of-complex* *the-wrapper-of-character* |
214 |
|
*the-wrapper-of-bit-vector* *the-wrapper-of-array*)) |
215 |
|
|
216 |
|
;;;; Type specifier hackery: |
217 |
|
|
218 |
|
;;; internal to this file. |
219 |
|
(defun coerce-to-class (class &optional make-forward-referenced-class-p) |
220 |
|
(if (symbolp class) |
221 |
|
(or (find-class class (not make-forward-referenced-class-p)) |
222 |
|
(ensure-class class)) |
223 |
|
class)) |
224 |
|
|
225 |
|
;;; Interface |
226 |
|
(defun specializer-from-type (type &aux args) |
227 |
|
(when (consp type) |
228 |
|
(setq args (cdr type) type (car type))) |
229 |
|
(cond ((symbolp type) |
230 |
|
(or (and (null args) (find-class type)) |
231 |
|
(ecase type |
232 |
|
(class (coerce-to-class (car args))) |
233 |
|
(prototype (make-instance 'class-prototype-specializer |
234 |
|
:object (coerce-to-class (car args)))) |
235 |
|
(class-eq (class-eq-specializer (coerce-to-class (car args)))) |
236 |
|
(eql (intern-eql-specializer (car args)))))) |
237 |
|
#+cmu17 |
238 |
|
((and (null args) (typep type 'lisp:class)) |
239 |
|
(or (kernel:class-pcl-class type) |
240 |
|
(find-structure-class (lisp:class-name type)))) |
241 |
|
((specializerp type) type))) |
242 |
|
|
243 |
|
;;; interface |
244 |
|
(defun type-from-specializer (specl) |
245 |
|
(cond ((eq specl 't) |
246 |
|
't) |
247 |
|
((consp specl) |
248 |
|
(unless (member (car specl) '(class prototype class-eq eql)) |
249 |
|
(error "~S is not a legal specializer type" specl)) |
250 |
|
specl) |
251 |
|
((progn |
252 |
|
(when (symbolp specl) |
253 |
|
;;maybe (or (find-class specl nil) (ensure-class specl)) instead? |
254 |
|
(setq specl (find-class specl))) |
255 |
|
(or (not (eq *boot-state* 'complete)) |
256 |
|
(specializerp specl))) |
257 |
|
(specializer-type specl)) |
258 |
|
(t |
259 |
|
(error "~s is neither a type nor a specializer" specl)))) |
260 |
|
|
261 |
|
(defun type-class (type) |
262 |
|
(declare (special *the-class-t*)) |
263 |
|
(setq type (type-from-specializer type)) |
264 |
|
(if (atom type) |
265 |
|
(if (eq type 't) |
266 |
|
*the-class-t* |
267 |
|
(error "bad argument to type-class")) |
268 |
|
(case (car type) |
269 |
|
(eql (class-of (cadr type))) |
270 |
|
(prototype (class-of (cadr type))) ;? |
271 |
|
(class-eq (cadr type)) |
272 |
|
(class (cadr type))))) |
273 |
|
|
274 |
|
(defun class-eq-type (class) |
275 |
|
(specializer-type (class-eq-specializer class))) |
276 |
|
|
277 |
|
(defun inform-type-system-about-std-class (name) |
278 |
|
(let ((predicate-name (make-type-predicate-name name))) |
279 |
|
(setf (gdefinition predicate-name) (make-type-predicate name)) |
280 |
|
(do-satisfies-deftype name predicate-name))) |
281 |
|
|
282 |
|
(defun make-type-predicate (name) |
283 |
|
(let ((cell (find-class-cell name))) |
284 |
|
#'(lambda (x) |
285 |
|
(funcall (the function (find-class-cell-predicate cell)) x)))) |
286 |
|
|
287 |
|
|
288 |
|
;This stuff isn't right. Good thing it isn't used. |
289 |
|
;The satisfies predicate has to be a symbol. There is no way to |
290 |
|
;construct such a symbol from a class object if class names change. |
291 |
|
(defun class-predicate (class) |
292 |
|
(when (symbolp class) (setq class (find-class class))) |
293 |
|
#'(lambda (object) (memq class (class-precedence-list (class-of object))))) |
294 |
|
|
295 |
|
(defun make-class-eq-predicate (class) |
296 |
|
(when (symbolp class) (setq class (find-class class))) |
297 |
|
#'(lambda (object) (eq class (class-of object)))) |
298 |
|
|
299 |
|
(defun make-eql-predicate (eql-object) |
300 |
|
#'(lambda (object) (eql eql-object object))) |
301 |
|
|
302 |
|
#|| ; The argument to satisfies must be a symbol. |
303 |
|
(deftype class (&optional class) |
304 |
|
(if class |
305 |
|
`(satisfies ,(class-predicate class)) |
306 |
|
`(satisfies ,(class-predicate 'class)))) |
307 |
|
|
308 |
|
(deftype class-eq (class) |
309 |
|
`(satisfies ,(make-class-eq-predicate class))) |
310 |
|
||# |
311 |
|
|
312 |
|
#-(or excl cmu17) |
313 |
|
(deftype eql (type-object) |
314 |
|
`(member ,type-object)) |
315 |
|
|
316 |
|
|
317 |
|
;;; Internal to this file. |
318 |
|
;;; |
319 |
|
;;; These functions are a pale imitiation of their namesake. They accept |
320 |
|
;;; class objects or types where they should. |
321 |
|
;;; |
322 |
|
(defun *normalize-type (type) |
323 |
|
(cond ((consp type) |
324 |
|
(if (member (car type) '(not and or)) |
325 |
|
`(,(car type) ,@(mapcar #'*normalize-type (cdr type))) |
326 |
|
(if (null (cdr type)) |
327 |
|
(*normalize-type (car type)) |
328 |
|
type))) |
329 |
|
((symbolp type) |
330 |
|
(let ((class (find-class type nil))) |
331 |
|
(if class |
332 |
|
(let ((type (specializer-type class))) |
333 |
|
(if (listp type) type `(,type))) |
334 |
|
`(,type)))) |
335 |
|
((or (not (eq *boot-state* 'complete)) |
336 |
|
(specializerp type)) |
337 |
|
(specializer-type type)) |
338 |
|
(t |
339 |
|
(error "~s is not a type" type)))) |
340 |
|
|
341 |
|
;;; Not used... |
342 |
|
#+nil |
343 |
|
(defun unparse-type-list (tlist) |
344 |
|
(mapcar #'unparse-type tlist)) |
345 |
|
|
346 |
|
;;; Not used... |
347 |
|
#+nil |
348 |
|
(defun unparse-type (type) |
349 |
|
(if (atom type) |
350 |
|
(if (specializerp type) |
351 |
|
(unparse-type (specializer-type type)) |
352 |
|
type) |
353 |
|
(case (car type) |
354 |
|
(eql type) |
355 |
|
(class-eq `(class-eq ,(class-name (cadr type)))) |
356 |
|
(class (class-name (cadr type))) |
357 |
|
(t `(,(car type) ,@(unparse-type-list (cdr type))))))) |
358 |
|
|
359 |
|
;;; internal to this file... |
360 |
|
(defun convert-to-system-type (type) |
361 |
|
(case (car type) |
362 |
|
((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type |
363 |
|
(cdr type)))) |
364 |
|
((class class-eq) ; class-eq is impossible to do right |
365 |
|
#-cmu17 (class-name (cadr type)) |
366 |
|
#+cmu17 (kernel:layout-class (class-wrapper (cadr type)))) |
367 |
|
(eql type) |
368 |
|
(t (if (null (cdr type)) |
369 |
|
(car type) |
370 |
|
type)))) |
371 |
|
|
372 |
|
;;; not used... |
373 |
|
#+nil |
374 |
|
(defun *typep (object type) |
375 |
|
(setq type (*normalize-type type)) |
376 |
|
(cond ((member (car type) '(eql wrapper-eq class-eq class)) |
377 |
|
(specializer-applicable-using-type-p type `(eql ,object))) |
378 |
|
((eq (car type) 'not) |
379 |
|
(not (*typep object (cadr type)))) |
380 |
|
(t |
381 |
|
(typep object (convert-to-system-type type))))) |
382 |
|
|
383 |
|
|
384 |
|
;;; *SUBTYPEP -- Interface |
385 |
|
;;; |
386 |
|
;Writing the missing NOT and AND clauses will improve |
387 |
|
;the quality of code generated by generate-discrimination-net, but |
388 |
|
;calling subtypep in place of just returning (values nil nil) can be |
389 |
|
;very slow. *subtypep is used by PCL itself, and must be fast. |
390 |
|
(defun *subtypep (type1 type2) |
391 |
|
(if (equal type1 type2) |
392 |
|
(values t t) |
393 |
|
(if (eq *boot-state* 'early) |
394 |
|
(values (eq type1 type2) t) |
395 |
|
(let ((*in-precompute-effective-methods-p* t)) |
396 |
|
(declare (special *in-precompute-effective-methods-p*)) |
397 |
|
;; *in-precompute-effective-methods-p* is not a good name. |
398 |
|
;; It changes the way class-applicable-using-class-p works. |
399 |
|
(setq type1 (*normalize-type type1)) |
400 |
|
(setq type2 (*normalize-type type2)) |
401 |
|
(case (car type2) |
402 |
|
(not |
403 |
|
(values nil nil)) ; Should improve this. |
404 |
|
(and |
405 |
|
(values nil nil)) ; Should improve this. |
406 |
|
((eql wrapper-eq class-eq class) |
407 |
|
(multiple-value-bind (app-p maybe-app-p) |
408 |
|
(specializer-applicable-using-type-p type2 type1) |
409 |
|
(values app-p (or app-p (not maybe-app-p))))) |
410 |
|
(t |
411 |
|
(subtypep (convert-to-system-type type1) |
412 |
|
(convert-to-system-type type2)))))))) |
413 |
|
|
414 |
|
(defun do-satisfies-deftype (name predicate) |
415 |
|
#+cmu17 (declare (ignore name predicate)) |
416 |
|
#+(or :Genera (and :Lucid (not :Prime)) ExCL :coral) |
417 |
|
(let* ((specifier `(satisfies ,predicate)) |
418 |
|
(expand-fn #'(lambda (&rest ignore) |
419 |
|
(declare (ignore ignore)) |
420 |
|
specifier))) |
421 |
|
;; Specific ports can insert their own way of doing this. Many |
422 |
|
;; ports may find the expand-fn defined above useful. |
423 |
|
;; |
424 |
|
(or #+:Genera |
425 |
|
(setf (get name 'deftype) expand-fn) |
426 |
|
#+(and :Lucid (not :Prime)) |
427 |
|
(system::define-macro `(deftype ,name) expand-fn nil) |
428 |
|
#+ExCL |
429 |
|
(setf (get name 'excl::deftype-expander) expand-fn) |
430 |
|
#+:coral |
431 |
|
(setf (get name 'ccl::deftype-expander) expand-fn))) |
432 |
|
#-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17) |
433 |
|
;; This is the default for ports for which we don't know any |
434 |
|
;; better. Note that for most ports, providing this definition |
435 |
|
;; should just speed up class definition. It shouldn't have an |
436 |
|
;; effect on performance of most user code. |
437 |
|
(eval `(deftype ,name () '(satisfies ,predicate)))) |
438 |
|
|
439 |
|
(defun make-type-predicate-name (name &optional kind) |
440 |
|
(if (symbol-package name) |
441 |
|
(intern (format nil |
442 |
|
"~@[~A ~]TYPE-PREDICATE ~A ~A" |
443 |
|
kind |
444 |
|
(package-name (symbol-package name)) |
445 |
|
(symbol-name name)) |
446 |
|
*the-pcl-package*) |
447 |
|
(make-symbol (format nil |
448 |
|
"~@[~A ~]TYPE-PREDICATE ~A" |
449 |
|
kind |
450 |
|
(symbol-name name))))) |
451 |
|
|
452 |
|
|
453 |
|
|
454 |
|
(defvar *built-in-class-symbols* ()) |
455 |
|
(defvar *built-in-wrapper-symbols* ()) |
456 |
|
|
457 |
|
(defun get-built-in-class-symbol (class-name) |
458 |
|
(or (cadr (assq class-name *built-in-class-symbols*)) |
459 |
|
(let ((symbol (intern (format nil |
460 |
|
"*THE-CLASS-~A*" |
461 |
|
(symbol-name class-name)) |
462 |
|
*the-pcl-package*))) |
463 |
|
(push (list class-name symbol) *built-in-class-symbols*) |
464 |
|
symbol))) |
465 |
|
|
466 |
|
(defun get-built-in-wrapper-symbol (class-name) |
467 |
|
(or (cadr (assq class-name *built-in-wrapper-symbols*)) |
468 |
|
(let ((symbol (intern (format nil |
469 |
|
"*THE-WRAPPER-OF-~A*" |
470 |
|
(symbol-name class-name)) |
471 |
|
*the-pcl-package*))) |
472 |
|
(push (list class-name symbol) *built-in-wrapper-symbols*) |
473 |
|
symbol))) |
474 |
|
|
475 |
|
|
476 |
|
|
477 |
|
|
478 |
|
(pushnew 'class *variable-declarations*) |
479 |
|
(pushnew 'variable-rebinding *variable-declarations*) |
480 |
|
|
481 |
|
(defun variable-class (var env) |
482 |
|
(caddr (variable-declaration 'class var env))) |
483 |
|
|
484 |
|
(defvar *name->class->slotd-table* (make-hash-table)) |
485 |
|
|
486 |
|
|
487 |
|
;;; |
488 |
|
;;; This is used by combined methods to communicate the next methods to |
489 |
|
;;; the methods they call. This variable is captured by a lexical variable |
490 |
|
;;; of the methods to give it the proper lexical scope. |
491 |
|
;;; |
492 |
|
(defvar *next-methods* nil) |
493 |
|
|
494 |
|
(defvar *not-an-eql-specializer* '(not-an-eql-specializer)) |
495 |
|
|
496 |
|
(defvar *umi-gfs*) |
497 |
|
(defvar *umi-complete-classes*) |
498 |
|
(defvar *umi-reorder*) |
499 |
|
|
500 |
|
(defvar *invalidate-discriminating-function-force-p* ()) |
501 |
|
(defvar *invalid-dfuns-on-stack* ()) |
502 |
|
|
503 |
|
|
504 |
|
(defvar *standard-method-combination*) |
505 |
|
|
506 |
|
(defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;*** |
507 |
|
|
508 |
|
|
509 |
|
(defmacro define-gf-predicate (predicate-name &rest classes) |
510 |
|
`(progn |
511 |
|
(defmethod ,predicate-name ((x t)) nil) |
512 |
|
,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) |
513 |
|
classes))) |
514 |
|
|
515 |
|
(defun make-class-predicate-name (name) |
516 |
|
(intern (format nil "~A::~A class predicate" |
517 |
|
(package-name (symbol-package name)) |
518 |
|
name) |
519 |
|
*the-pcl-package*)) |
520 |
|
|
521 |
|
(defun plist-value (object name) |
522 |
|
(getf (object-plist object) name)) |
523 |
|
|
524 |
|
(defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name) |
525 |
|
(if new-value |
526 |
|
(setf (getf (object-plist object) name) new-value) |
527 |
|
(progn |
528 |
|
(remf (object-plist object) name) |
529 |
|
nil))) |
530 |
|
|
531 |
|
|
532 |
|
|
533 |
|
(defvar *built-in-classes* |
534 |
|
;; |
535 |
|
;; name supers subs cdr of cpl |
536 |
|
;; prototype |
537 |
|
'(;(t () (number sequence array character symbol) ()) |
538 |
|
(number (t) (complex float rational) (t)) |
539 |
|
(complex (number) () (number t) |
540 |
|
#c(1 1)) |
541 |
|
(float (real) () (real number t) |
542 |
|
1.0) |
543 |
|
(real (number) (rational float) (number t)) |
544 |
|
(rational (real) (integer ratio) (real number t)) |
545 |
|
(integer (rational) () (rational real number t) |
546 |
|
1) |
547 |
|
(ratio (rational) () (rational real number t) |
548 |
|
1/2) |
549 |
|
|
550 |
|
(sequence (t) (list vector) (t)) |
551 |
|
(list (sequence) (cons null) (sequence t)) |
552 |
|
(cons (list) () (list sequence t) |
553 |
|
(nil)) |
554 |
|
|
555 |
|
|
556 |
|
(array (t) (vector) (t) |
557 |
|
#2A((NIL))) |
558 |
|
(vector (array |
559 |
|
sequence) (string bit-vector) (array sequence t) |
560 |
|
#()) |
561 |
|
(string (vector) () (vector array sequence t) |
562 |
|
"") |
563 |
|
(bit-vector (vector) () (vector array sequence t) |
564 |
|
#*1) |
565 |
|
(character (t) () (t) |
566 |
|
#\c) |
567 |
|
|
568 |
|
(symbol (t) (null) (t) |
569 |
|
symbol) |
570 |
|
(null (symbol |
571 |
|
list) () (symbol list sequence t) |
572 |
|
nil))) |
573 |
|
|
574 |
|
#+cmu17 |
575 |
|
(labels ((direct-supers (class) |
576 |
|
(if (typep class 'lisp:built-in-class) |
577 |
|
(kernel:built-in-class-direct-superclasses class) |
578 |
|
(let ((inherits (kernel:layout-inherits |
579 |
|
(kernel:class-layout class)))) |
580 |
|
(list (svref inherits (1- (length inherits))))))) |
581 |
|
(direct-subs (class) |
582 |
|
(ext:collect ((res)) |
583 |
|
(let ((subs (kernel:class-subclasses class))) |
584 |
|
(when subs |
585 |
|
(ext:do-hash (sub v subs) |
586 |
|
(declare (ignore v)) |
587 |
|
(when (member class (direct-supers sub)) |
588 |
|
(res sub))))) |
589 |
|
(res)))) |
590 |
|
(ext:collect ((res)) |
591 |
|
(dolist (bic kernel::built-in-classes) |
592 |
|
(let* ((name (car bic)) |
593 |
|
(class (lisp:find-class name))) |
594 |
|
(unless (member name '(t kernel:instance kernel:funcallable-instance |
595 |
|
function)) |
596 |
|
(res `(,name |
597 |
|
,(mapcar #'lisp:class-name (direct-supers class)) |
598 |
|
,(mapcar #'lisp:class-name (direct-subs class)) |
599 |
|
,(map 'list #'(lambda (x) |
600 |
|
(lisp:class-name (kernel:layout-class x))) |
601 |
|
(reverse |
602 |
|
(kernel:layout-inherits |
603 |
|
(kernel:class-layout class)))) |
604 |
|
,(let ((found (assoc name *built-in-classes*))) |
605 |
|
(if found (fifth found) 42))))))) |
606 |
|
(setq *built-in-classes* (res)))) |
607 |
|
|
608 |
|
|
609 |
|
;;; |
610 |
|
;;; The classes that define the kernel of the metabraid. |
611 |
|
;;; |
612 |
|
(defclass t () () |
613 |
|
(:metaclass built-in-class)) |
614 |
|
|
615 |
|
#+cmu17 |
616 |
|
(progn |
617 |
|
(defclass kernel:instance (t) () |
618 |
|
(:metaclass built-in-class)) |
619 |
|
|
620 |
|
(defclass function (t) () |
621 |
|
(:metaclass built-in-class)) |
622 |
|
|
623 |
|
(defclass kernel:funcallable-instance (function) () |
624 |
|
(:metaclass built-in-class))) |
625 |
|
|
626 |
|
(defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () |
627 |
|
(:metaclass slot-class)) |
628 |
|
|
629 |
|
(defclass structure-object (slot-object) () |
630 |
|
(:metaclass structure-class)) |
631 |
|
|
632 |
|
(defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object |
633 |
|
(:constructor |STRUCTURE-OBJECT class constructor|))) |
634 |
|
|
635 |
|
|
636 |
|
(defclass standard-object (slot-object) ()) |
637 |
|
|
638 |
|
(defclass metaobject (standard-object) ()) |
639 |
|
|
640 |
|
(defclass specializer (metaobject) |
641 |
|
((type |
642 |
|
:initform nil |
643 |
|
:reader specializer-type))) |
644 |
|
|
645 |
|
(defclass definition-source-mixin (standard-object) |
646 |
|
((source |
647 |
|
:initform (load-truename) |
648 |
|
:reader definition-source |
649 |
|
:initarg :definition-source))) |
650 |
|
|
651 |
|
(defclass plist-mixin (standard-object) |
652 |
|
((plist |
653 |
|
:initform () |
654 |
|
:accessor object-plist))) |
655 |
|
|
656 |
|
(defclass documentation-mixin (plist-mixin) |
657 |
|
()) |
658 |
|
|
659 |
|
(defclass dependent-update-mixin (plist-mixin) |
660 |
|
()) |
661 |
|
|
662 |
|
;;; |
663 |
|
;;; The class CLASS is a specified basic class. It is the common superclass |
664 |
|
;;; of any kind of class. That is any class that can be a metaclass must |
665 |
|
;;; have the class CLASS in its class precedence list. |
666 |
|
;;; |
667 |
|
(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin |
668 |
|
specializer) |
669 |
|
((name |
670 |
|
:initform nil |
671 |
|
:initarg :name |
672 |
|
:accessor class-name) |
673 |
|
(class-eq-specializer |
674 |
|
:initform nil |
675 |
|
:reader class-eq-specializer) |
676 |
|
(direct-superclasses |
677 |
|
:initform () |
678 |
|
:reader class-direct-superclasses) |
679 |
|
(direct-subclasses |
680 |
|
:initform () |
681 |
|
:reader class-direct-subclasses) |
682 |
|
(direct-methods |
683 |
|
:initform (cons nil nil)) |
684 |
|
(predicate-name |
685 |
|
:initform nil |
686 |
|
:reader class-predicate-name))) |
687 |
|
|
688 |
|
;;; |
689 |
|
;;; The class PCL-CLASS is an implementation-specific common superclass of |
690 |
|
;;; all specified subclasses of the class CLASS. |
691 |
|
;;; |
692 |
|
(defclass pcl-class (class) |
693 |
|
((class-precedence-list |
694 |
|
:reader class-precedence-list) |
695 |
|
(can-precede-list |
696 |
|
:initform () |
697 |
|
:reader class-can-precede-list) |
698 |
|
(incompatible-superclass-list |
699 |
|
:initform () |
700 |
|
:accessor class-incompatible-superclass-list) |
701 |
|
(wrapper |
702 |
|
:initform nil |
703 |
|
:reader class-wrapper) |
704 |
|
(prototype |
705 |
|
:initform nil |
706 |
|
:reader class-prototype))) |
707 |
|
|
708 |
|
(defclass slot-class (pcl-class) |
709 |
|
((direct-slots |
710 |
|
:initform () |
711 |
|
:accessor class-direct-slots) |
712 |
|
(slots |
713 |
|
:initform () |
714 |
|
:accessor class-slots) |
715 |
|
(initialize-info |
716 |
|
:initform nil |
717 |
|
:accessor class-initialize-info))) |
718 |
|
|
719 |
|
;;; |
720 |
|
;;; The class STD-CLASS is an implementation-specific common superclass of |
721 |
|
;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. |
722 |
|
;;; |
723 |
|
(defclass std-class (slot-class) |
724 |
|
()) |
725 |
|
|
726 |
|
(defclass standard-class (std-class) |
727 |
|
()) |
728 |
|
|
729 |
|
(defclass funcallable-standard-class (std-class) |
730 |
|
()) |
731 |
|
|
732 |
|
(defclass forward-referenced-class (pcl-class) ()) |
733 |
|
|
734 |
|
(defclass built-in-class (pcl-class) ()) |
735 |
|
|
736 |
|
(defclass structure-class (slot-class) |
737 |
|
((defstruct-form |
738 |
|
:initform () |
739 |
|
:accessor class-defstruct-form) |
740 |
|
(defstruct-constructor |
741 |
|
:initform nil |
742 |
|
:accessor class-defstruct-constructor) |
743 |
|
(from-defclass-p |
744 |
|
:initform nil |
745 |
|
:initarg :from-defclass-p))) |
746 |
|
|
747 |
|
|
748 |
|
(defclass specializer-with-object (specializer) ()) |
749 |
|
|
750 |
|
(defclass exact-class-specializer (specializer) ()) |
751 |
|
|
752 |
|
(defclass class-eq-specializer (exact-class-specializer specializer-with-object) |
753 |
|
((object :initarg :class :reader specializer-class :reader specializer-object))) |
754 |
|
|
755 |
|
(defclass class-prototype-specializer (specializer-with-object) |
756 |
|
((object :initarg :class :reader specializer-class :reader specializer-object))) |
757 |
|
|
758 |
|
(defclass eql-specializer (exact-class-specializer specializer-with-object) |
759 |
|
((object :initarg :object :reader specializer-object |
760 |
|
:reader eql-specializer-object))) |
761 |
|
|
762 |
|
(defvar *eql-specializer-table* (make-hash-table :test 'eql)) |
763 |
|
|
764 |
|
(defun intern-eql-specializer (object) |
765 |
|
(or (gethash object *eql-specializer-table*) |
766 |
|
(setf (gethash object *eql-specializer-table*) |
767 |
|
(make-instance 'eql-specializer :object object)))) |
768 |
|
|
769 |
|
|
770 |
|
;;; |
771 |
|
;;; Slot definitions. |
772 |
|
;;; |
773 |
|
(defclass slot-definition (metaobject) |
774 |
|
((name |
775 |
|
:initform nil |
776 |
|
:initarg :name |
777 |
|
:accessor slot-definition-name) |
778 |
|
(initform |
779 |
|
:initform nil |
780 |
|
:initarg :initform |
781 |
|
:accessor slot-definition-initform) |
782 |
|
(initfunction |
783 |
|
:initform nil |
784 |
|
:initarg :initfunction |
785 |
|
:accessor slot-definition-initfunction) |
786 |
|
(readers |
787 |
|
:initform nil |
788 |
|
:initarg :readers |
789 |
|
:accessor slot-definition-readers) |
790 |
|
(writers |
791 |
|
:initform nil |
792 |
|
:initarg :writers |
793 |
|
:accessor slot-definition-writers) |
794 |
|
(initargs |
795 |
|
:initform nil |
796 |
|
:initarg :initargs |
797 |
|
:accessor slot-definition-initargs) |
798 |
|
(type |
799 |
|
:initform t |
800 |
|
:initarg :type |
801 |
|
:accessor slot-definition-type) |
802 |
|
(documentation |
803 |
|
:initform "" |
804 |
|
:initarg :documentation) |
805 |
|
(class |
806 |
|
:initform nil |
807 |
|
:initarg :class |
808 |
|
:accessor slot-definition-class))) |
809 |
|
|
810 |
|
(defclass standard-slot-definition (slot-definition) |
811 |
|
((allocation |
812 |
|
:initform :instance |
813 |
|
:initarg :allocation |
814 |
|
:accessor slot-definition-allocation))) |
815 |
|
|
816 |
|
(defclass structure-slot-definition (slot-definition) |
817 |
|
((defstruct-accessor-symbol |
818 |
|
:initform nil |
819 |
|
:initarg :defstruct-accessor-symbol |
820 |
|
:accessor slot-definition-defstruct-accessor-symbol) |
821 |
|
(internal-reader-function |
822 |
|
:initform nil |
823 |
|
:initarg :internal-reader-function |
824 |
|
:accessor slot-definition-internal-reader-function) |
825 |
|
(internal-writer-function |
826 |
|
:initform nil |
827 |
|
:initarg :internal-writer-function |
828 |
|
:accessor slot-definition-internal-writer-function))) |
829 |
|
|
830 |
|
(defclass direct-slot-definition (slot-definition) |
831 |
|
()) |
832 |
|
|
833 |
|
(defclass effective-slot-definition (slot-definition) |
834 |
|
((reader-function ; #'(lambda (object) ...) |
835 |
|
:accessor slot-definition-reader-function) |
836 |
|
(writer-function ; #'(lambda (new-value object) ...) |
837 |
|
:accessor slot-definition-writer-function) |
838 |
|
(boundp-function ; #'(lambda (object) ...) |
839 |
|
:accessor slot-definition-boundp-function) |
840 |
|
(accessor-flags |
841 |
|
:initform 0))) |
842 |
|
|
843 |
|
(defclass standard-direct-slot-definition (standard-slot-definition |
844 |
|
direct-slot-definition) |
845 |
|
()) |
846 |
|
|
847 |
|
(defclass standard-effective-slot-definition (standard-slot-definition |
848 |
|
effective-slot-definition) |
849 |
|
((location ; nil, a fixnum, a cons: (slot-name . value) |
850 |
|
:initform nil |
851 |
|
:accessor slot-definition-location))) |
852 |
|
|
853 |
|
(defclass structure-direct-slot-definition (structure-slot-definition |
854 |
|
direct-slot-definition) |
855 |
|
()) |
856 |
|
|
857 |
|
(defclass structure-effective-slot-definition (structure-slot-definition |
858 |
|
effective-slot-definition) |
859 |
|
()) |
860 |
|
|
861 |
|
(defclass method (metaobject) ()) |
862 |
|
|
863 |
|
(defclass standard-method (definition-source-mixin plist-mixin method) |
864 |
|
((generic-function |
865 |
|
:initform nil |
866 |
|
:accessor method-generic-function) |
867 |
|
; (qualifiers |
868 |
|
; :initform () |
869 |
|
; :initarg :qualifiers |
870 |
|
; :reader method-qualifiers) |
871 |
|
(specializers |
872 |
|
:initform () |
873 |
|
:initarg :specializers |
874 |
|
:reader method-specializers) |
875 |
|
(lambda-list |
876 |
|
:initform () |
877 |
|
:initarg :lambda-list |
878 |
|
:reader method-lambda-list) |
879 |
|
(function |
880 |
|
:initform nil |
881 |
|
:initarg :function) ;no writer |
882 |
|
(fast-function |
883 |
|
:initform nil |
884 |
|
:initarg :fast-function ;no writer |
885 |
|
:reader method-fast-function) |
886 |
|
; (documentation |
887 |
|
; :initform nil |
888 |
|
; :initarg :documentation |
889 |
|
; :reader method-documentation) |
890 |
|
)) |
891 |
|
|
892 |
|
(defclass standard-accessor-method (standard-method) |
893 |
|
((slot-name :initform nil |
894 |
|
:initarg :slot-name |
895 |
|
:reader accessor-method-slot-name) |
896 |
|
(slot-definition :initform nil |
897 |
|
:initarg :slot-definition |
898 |
|
:reader accessor-method-slot-definition))) |
899 |
|
|
900 |
|
(defclass standard-reader-method (standard-accessor-method) ()) |
901 |
|
|
902 |
|
(defclass standard-writer-method (standard-accessor-method) ()) |
903 |
|
|
904 |
|
(defclass standard-boundp-method (standard-accessor-method) ()) |
905 |
|
|
906 |
|
(defclass generic-function (dependent-update-mixin |
907 |
|
definition-source-mixin |
908 |
|
documentation-mixin |
909 |
|
metaobject |
910 |
|
#+cmu17 kernel:funcallable-instance) |
911 |
|
() |
912 |
|
(:metaclass funcallable-standard-class)) |
913 |
|
|
914 |
|
(defclass standard-generic-function (generic-function) |
915 |
|
((name |
916 |
|
:initform nil |
917 |
|
:initarg :name |
918 |
|
:accessor generic-function-name) |
919 |
|
(methods |
920 |
|
:initform () |
921 |
|
:accessor generic-function-methods) |
922 |
|
(method-class |
923 |
|
:initarg :method-class |
924 |
|
:accessor generic-function-method-class) |
925 |
|
(method-combination |
926 |
|
:initarg :method-combination |
927 |
|
:accessor generic-function-method-combination) |
928 |
|
(arg-info |
929 |
|
:initform (make-arg-info) |
930 |
|
:reader gf-arg-info) |
931 |
|
(dfun-state |
932 |
|
:initform () |
933 |
|
:accessor gf-dfun-state) |
934 |
|
(pretty-arglist |
935 |
|
:initform () |
936 |
|
:accessor gf-pretty-arglist) |
937 |
|
) |
938 |
|
(:metaclass funcallable-standard-class) |
939 |
|
(:default-initargs :method-class *the-class-standard-method* |
940 |
|
:method-combination *standard-method-combination*)) |
941 |
|
|
942 |
|
(defclass method-combination (metaobject) ()) |
943 |
|
|
944 |
|
(defclass standard-method-combination |
945 |
|
(definition-source-mixin method-combination) |
946 |
|
((type :reader method-combination-type |
947 |
|
:initarg :type) |
948 |
|
(documentation :reader method-combination-documentation |
949 |
|
:initarg :documentation) |
950 |
|
(options :reader method-combination-options |
951 |
|
:initarg :options))) |
952 |
|
|
953 |
|
(defclass long-method-combination (standard-method-combination) |
954 |
|
((function |
955 |
|
:initarg :function |
956 |
|
:reader long-method-combination-function) |
957 |
|
(arguments-lambda-list |
958 |
|
:initarg :arguments-lambda-list |
959 |
|
:reader long-method-combination-arguments-lambda-list))) |
960 |
|
|
961 |
|
(defparameter *early-class-predicates* |
962 |
|
'((specializer specializerp) |
963 |
|
(exact-class-specializer exact-class-specializer-p) |
964 |
|
(class-eq-specializer class-eq-specializer-p) |
965 |
|
(eql-specializer eql-specializer-p) |
966 |
|
(class classp) |
967 |
|
(slot-class slot-class-p) |
968 |
|
(standard-class standard-class-p) |
969 |
|
(funcallable-standard-class funcallable-standard-class-p) |
970 |
|
(structure-class structure-class-p) |
971 |
|
(forward-referenced-class forward-referenced-class-p) |
972 |
|
(method method-p) |
973 |
|
(standard-method standard-method-p) |
974 |
|
(standard-accessor-method standard-accessor-method-p) |
975 |
|
(standard-reader-method standard-reader-method-p) |
976 |
|
(standard-writer-method standard-writer-method-p) |
977 |
|
(standard-boundp-method standard-boundp-method-p) |
978 |
|
(generic-function generic-function-p) |
979 |
|
(standard-generic-function standard-generic-function-p) |
980 |
|
(method-combination method-combination-p) |
981 |
|
(long-method-combination long-method-combination-p))) |
982 |
|
|