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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5