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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10.1.5 - (hide annotations) (vendor branch)
Fri Oct 28 21:15:01 1994 UTC (19 years, 6 months ago) by ram
Branch: cmu
Changes since 1.10.1.4: +1 -0 lines
Conditionalize out structure-object defstruct since it doesn't make any sense
to me.
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 ram 1.10.1.4 ; 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 ram 1.10.1.1 #+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    
186     *the-class-slot-object*
187     *the-class-standard-object*
188     *the-class-structure-object*
189     *the-class-class*
190     *the-class-generic-function*
191     *the-class-built-in-class*
192     *the-class-slot-class*
193     *the-class-structure-class*
194     *the-class-standard-class*
195     *the-class-funcallable-standard-class*
196 ram 1.8 *the-class-method*
197 ram 1.6 *the-class-standard-method*
198 ram 1.8 *the-class-standard-reader-method*
199     *the-class-standard-writer-method*
200     *the-class-standard-boundp-method*
201 ram 1.6 *the-class-standard-generic-function*
202 ram 1.8 *the-class-standard-effective-slot-definition*
203 ram 1.6
204 ram 1.8 *the-eslotd-standard-class-slots*
205     *the-eslotd-funcallable-standard-class-slots*))
206    
207 ram 1.6 (proclaim '(special *the-wrapper-of-t*
208     *the-wrapper-of-vector* *the-wrapper-of-symbol*
209     *the-wrapper-of-string* *the-wrapper-of-sequence*
210     *the-wrapper-of-rational* *the-wrapper-of-ratio*
211     *the-wrapper-of-number* *the-wrapper-of-null*
212     *the-wrapper-of-list* *the-wrapper-of-integer*
213     *the-wrapper-of-float* *the-wrapper-of-cons*
214     *the-wrapper-of-complex* *the-wrapper-of-character*
215     *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
216    
217 ram 1.10.1.1 ;;;; Type specifier hackery:
218    
219     ;;; internal to this file.
220 ram 1.6 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
221     (if (symbolp class)
222     (or (find-class class (not make-forward-referenced-class-p))
223     (ensure-class class))
224     class))
225    
226 ram 1.10.1.1 ;;; Interface
227 ram 1.6 (defun specializer-from-type (type &aux args)
228     (when (consp type)
229     (setq args (cdr type) type (car type)))
230     (cond ((symbolp type)
231     (or (and (null args) (find-class type))
232     (ecase type
233     (class (coerce-to-class (car args)))
234 ram 1.8 (prototype (make-instance 'class-prototype-specializer
235     :object (coerce-to-class (car args))))
236 ram 1.6 (class-eq (class-eq-specializer (coerce-to-class (car args))))
237     (eql (intern-eql-specializer (car args))))))
238 ram 1.10.1.3 #+cmu17
239     ((and (null args) (typep type 'lisp:class))
240     (or (kernel:class-pcl-class type)
241     (find-structure-class (lisp:class-name type))))
242 ram 1.6 ((specializerp type) type)))
243    
244 ram 1.10.1.1 ;;; interface
245 ram 1.6 (defun type-from-specializer (specl)
246 ram 1.8 (cond ((eq specl 't)
247     't)
248     ((consp specl)
249     (unless (member (car specl) '(class prototype class-eq eql))
250 ram 1.6 (error "~S is not a legal specializer type" specl))
251     specl)
252 ram 1.8 ((progn
253     (when (symbolp specl)
254     ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
255     (setq specl (find-class specl)))
256     (or (not (eq *boot-state* 'complete))
257     (specializerp specl)))
258     (specializer-type specl))
259 ram 1.6 (t
260     (error "~s is neither a type nor a specializer" specl))))
261    
262 ram 1.4 (defun type-class (type)
263 ram 1.6 (declare (special *the-class-t*))
264     (setq type (type-from-specializer type))
265     (if (atom type)
266 ram 1.8 (if (eq type 't)
267     *the-class-t*
268     (error "bad argument to type-class"))
269 ram 1.4 (case (car type)
270 ram 1.6 (eql (class-of (cadr type)))
271 ram 1.8 (prototype (class-of (cadr type))) ;?
272 ram 1.6 (class-eq (cadr type))
273     (class (cadr type)))))
274 ram 1.4
275 ram 1.6 (defun class-eq-type (class)
276     (specializer-type (class-eq-specializer class)))
277 ram 1.4
278 ram 1.6 (defun inform-type-system-about-std-class (name)
279     (let ((predicate-name (make-type-predicate-name name)))
280 phg 1.9 (setf (gdefinition predicate-name) (make-type-predicate name))
281 ram 1.6 (do-satisfies-deftype name predicate-name)))
282    
283     (defun make-type-predicate (name)
284     (let ((cell (find-class-cell name)))
285     #'(lambda (x)
286 ram 1.8 (funcall (the function (find-class-cell-predicate cell)) x))))
287 ram 1.6
288    
289     ;This stuff isn't right. Good thing it isn't used.
290     ;The satisfies predicate has to be a symbol. There is no way to
291     ;construct such a symbol from a class object if class names change.
292     (defun class-predicate (class)
293     (when (symbolp class) (setq class (find-class class)))
294     #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
295    
296 ram 1.4 (defun make-class-eq-predicate (class)
297     (when (symbolp class) (setq class (find-class class)))
298     #'(lambda (object) (eq class (class-of object))))
299    
300     (defun make-eql-predicate (eql-object)
301     #'(lambda (object) (eql eql-object object)))
302    
303 ram 1.6 #|| ; The argument to satisfies must be a symbol.
304     (deftype class (&optional class)
305     (if class
306     `(satisfies ,(class-predicate class))
307     `(satisfies ,(class-predicate 'class))))
308 ram 1.4
309 ram 1.6 (deftype class-eq (class)
310     `(satisfies ,(make-class-eq-predicate class)))
311     ||#
312 ram 1.4
313 ram 1.10.1.1 #-(or excl cmu17)
314 ram 1.6 (deftype eql (type-object)
315     `(member ,type-object))
316 ram 1.4
317 ram 1.8
318 ram 1.10.1.1 ;;; Internal to this file.
319 wlott 1.1 ;;;
320     ;;; These functions are a pale imitiation of their namesake. They accept
321     ;;; class objects or types where they should.
322     ;;;
323 ram 1.6 (defun *normalize-type (type)
324     (cond ((consp type)
325     (if (member (car type) '(not and or))
326     `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
327     (if (null (cdr type))
328     (*normalize-type (car type))
329     type)))
330     ((symbolp type)
331     (let ((class (find-class type nil)))
332     (if class
333     (let ((type (specializer-type class)))
334     (if (listp type) type `(,type)))
335     `(,type))))
336 ram 1.8 ((or (not (eq *boot-state* 'complete))
337     (specializerp type))
338     (specializer-type type))
339 ram 1.6 (t
340     (error "~s is not a type" type))))
341    
342 ram 1.10.1.1 ;;; Not used...
343     #+nil
344 ram 1.6 (defun unparse-type-list (tlist)
345     (mapcar #'unparse-type tlist))
346    
347 ram 1.10.1.1 ;;; Not used...
348     #+nil
349 ram 1.6 (defun unparse-type (type)
350     (if (atom type)
351     (if (specializerp type)
352     (unparse-type (specializer-type type))
353     type)
354     (case (car type)
355     (eql type)
356     (class-eq `(class-eq ,(class-name (cadr type))))
357     (class (class-name (cadr type)))
358     (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
359    
360 ram 1.10.1.1 ;;; internal to this file...
361 ram 1.6 (defun convert-to-system-type (type)
362     (case (car type)
363 ram 1.10.1.1 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
364     (cdr type))))
365 ram 1.10.1.2 ((class class-eq) ; class-eq is impossible to do right
366     #-cmu17 (class-name (cadr type))
367     #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))
368 ram 1.6 (eql type)
369     (t (if (null (cdr type))
370     (car type)
371     type))))
372    
373 ram 1.10.1.1 ;;; not used...
374     #+nil
375 wlott 1.1 (defun *typep (object type)
376 ram 1.6 (setq type (*normalize-type type))
377 ram 1.8 (cond ((member (car type) '(eql wrapper-eq class-eq class))
378 ram 1.6 (specializer-applicable-using-type-p type `(eql ,object)))
379     ((eq (car type) 'not)
380     (not (*typep object (cadr type))))
381     (t
382     (typep object (convert-to-system-type type)))))
383 wlott 1.1
384 ram 1.10.1.1
385     ;;; *SUBTYPEP -- Interface
386     ;;;
387 phg 1.10 ;Writing the missing NOT and AND clauses will improve
388     ;the quality of code generated by generate-discrimination-net, but
389     ;calling subtypep in place of just returning (values nil nil) can be
390     ;very slow. *subtypep is used by PCL itself, and must be fast.
391 wlott 1.1 (defun *subtypep (type1 type2)
392 ram 1.8 (if (equal type1 type2)
393     (values t t)
394     (if (eq *boot-state* 'early)
395     (values (eq type1 type2) t)
396 phg 1.10 (let ((*in-precompute-effective-methods-p* t))
397 ram 1.8 (declare (special *in-precompute-effective-methods-p*))
398 phg 1.10 ;; *in-precompute-effective-methods-p* is not a good name.
399     ;; It changes the way class-applicable-using-class-p works.
400 ram 1.8 (setq type1 (*normalize-type type1))
401     (setq type2 (*normalize-type type2))
402 phg 1.10 (case (car type2)
403     (not
404     (values nil nil)) ; Should improve this.
405     (and
406     (values nil nil)) ; Should improve this.
407     ((eql wrapper-eq class-eq class)
408     (multiple-value-bind (app-p maybe-app-p)
409     (specializer-applicable-using-type-p type2 type1)
410     (values app-p (or app-p (not maybe-app-p)))))
411     (t
412     (subtypep (convert-to-system-type type1)
413     (convert-to-system-type type2))))))))
414 wlott 1.1
415     (defun do-satisfies-deftype (name predicate)
416 ram 1.10.1.1 #+cmu17 (declare (ignore name predicate))
417 ram 1.6 #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
418 wlott 1.1 (let* ((specifier `(satisfies ,predicate))
419     (expand-fn #'(lambda (&rest ignore)
420     (declare (ignore ignore))
421     specifier)))
422     ;; Specific ports can insert their own way of doing this. Many
423     ;; ports may find the expand-fn defined above useful.
424     ;;
425     (or #+:Genera
426     (setf (get name 'deftype) expand-fn)
427     #+(and :Lucid (not :Prime))
428     (system::define-macro `(deftype ,name) expand-fn nil)
429     #+ExCL
430     (setf (get name 'excl::deftype-expander) expand-fn)
431     #+:coral
432 ram 1.6 (setf (get name 'ccl::deftype-expander) expand-fn)))
433 ram 1.10.1.1 #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17)
434 ram 1.6 ;; This is the default for ports for which we don't know any
435     ;; better. Note that for most ports, providing this definition
436     ;; should just speed up class definition. It shouldn't have an
437     ;; effect on performance of most user code.
438     (eval `(deftype ,name () '(satisfies ,predicate))))
439 wlott 1.1
440 ram 1.6 (defun make-type-predicate-name (name &optional kind)
441     (if (symbol-package name)
442     (intern (format nil
443     "~@[~A ~]TYPE-PREDICATE ~A ~A"
444     kind
445     (package-name (symbol-package name))
446     (symbol-name name))
447     *the-pcl-package*)
448     (make-symbol (format nil
449     "~@[~A ~]TYPE-PREDICATE ~A"
450     kind
451     (symbol-name name)))))
452 wlott 1.2
453 wlott 1.1
454    
455     (defvar *built-in-class-symbols* ())
456     (defvar *built-in-wrapper-symbols* ())
457    
458     (defun get-built-in-class-symbol (class-name)
459     (or (cadr (assq class-name *built-in-class-symbols*))
460     (let ((symbol (intern (format nil
461     "*THE-CLASS-~A*"
462     (symbol-name class-name))
463     *the-pcl-package*)))
464     (push (list class-name symbol) *built-in-class-symbols*)
465     symbol)))
466    
467     (defun get-built-in-wrapper-symbol (class-name)
468     (or (cadr (assq class-name *built-in-wrapper-symbols*))
469     (let ((symbol (intern (format nil
470     "*THE-WRAPPER-OF-~A*"
471     (symbol-name class-name))
472     *the-pcl-package*)))
473     (push (list class-name symbol) *built-in-wrapper-symbols*)
474     symbol)))
475    
476    
477    
478    
479     (pushnew 'class *variable-declarations*)
480     (pushnew 'variable-rebinding *variable-declarations*)
481    
482     (defun variable-class (var env)
483     (caddr (variable-declaration 'class var env)))
484    
485 ram 1.8 (defvar *name->class->slotd-table* (make-hash-table))
486 wlott 1.1
487    
488     ;;;
489     ;;; This is used by combined methods to communicate the next methods to
490     ;;; the methods they call. This variable is captured by a lexical variable
491     ;;; of the methods to give it the proper lexical scope.
492     ;;;
493     (defvar *next-methods* nil)
494    
495     (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
496    
497     (defvar *umi-gfs*)
498     (defvar *umi-complete-classes*)
499     (defvar *umi-reorder*)
500    
501     (defvar *invalidate-discriminating-function-force-p* ())
502     (defvar *invalid-dfuns-on-stack* ())
503    
504    
505     (defvar *standard-method-combination*)
506    
507     (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
508    
509    
510 ram 1.6 (defmacro define-gf-predicate (predicate-name &rest classes)
511     `(progn
512     (defmethod ,predicate-name ((x t)) nil)
513     ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
514     classes)))
515 wlott 1.1
516 ram 1.6 (defun make-class-predicate-name (name)
517 ram 1.8 (intern (format nil "~A::~A class predicate"
518     (package-name (symbol-package name))
519     name)
520     *the-pcl-package*))
521 wlott 1.1
522 ram 1.8 (defun plist-value (object name)
523     (getf (object-plist object) name))
524 wlott 1.1
525 ram 1.6 (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
526 ram 1.8 (if new-value
527     (setf (getf (object-plist object) name) new-value)
528     (progn
529     (remf (object-plist object) name)
530     nil)))
531 ram 1.6
532 wlott 1.1
533    
534     (defvar *built-in-classes*
535     ;;
536     ;; name supers subs cdr of cpl
537 ram 1.8 ;; prototype
538 ram 1.6 '(;(t () (number sequence array character symbol) ())
539 ram 1.8 (number (t) (complex float rational) (t))
540 ram 1.6 (complex (number) () (number t)
541 ram 1.8 #c(1 1))
542 ram 1.6 (float (number) () (number t)
543 ram 1.8 1.0)
544     (rational (number) (integer ratio) (number t))
545 ram 1.6 (integer (rational) () (rational number t)
546 ram 1.8 1)
547 ram 1.6 (ratio (rational) () (rational number t)
548     1/2)
549 wlott 1.1
550 ram 1.8 (sequence (t) (list vector) (t))
551     (list (sequence) (cons null) (sequence t))
552 ram 1.6 (cons (list) () (list sequence t)
553 ram 1.8 (nil))
554 wlott 1.1
555    
556 ram 1.6 (array (t) (vector) (t)
557 ram 1.8 #2A((NIL)))
558 wlott 1.1 (vector (array
559 ram 1.6 sequence) (string bit-vector) (array sequence t)
560 ram 1.8 #())
561 ram 1.6 (string (vector) () (vector array sequence t)
562 ram 1.8 "")
563 ram 1.6 (bit-vector (vector) () (vector array sequence t)
564 ram 1.8 #*1)
565 ram 1.6 (character (t) () (t)
566 ram 1.8 #\c)
567 wlott 1.1
568 ram 1.6 (symbol (t) (null) (t)
569 ram 1.8 symbol)
570     (null (symbol
571     list) () (symbol list sequence t)
572     nil)))
573 wlott 1.1
574 ram 1.10.1.1 #+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 wlott 1.1
609     ;;;
610     ;;; The classes that define the kernel of the metabraid.
611     ;;;
612     (defclass t () ()
613     (:metaclass built-in-class))
614    
615 ram 1.10.1.1 #+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 ram 1.6 (:metaclass slot-class))
628 wlott 1.1
629 ram 1.6 (defclass structure-object (slot-object) ()
630     (:metaclass structure-class))
631    
632 ram 1.10.1.5 #-cmu17
633 ram 1.6 (defstruct (structure-object
634     (:constructor |STRUCTURE-OBJECT class constructor|)))
635    
636     (defclass standard-object (slot-object) ())
637    
638 wlott 1.1 (defclass metaobject (standard-object) ())
639    
640 ram 1.6 (defclass specializer (metaobject)
641     ((type
642     :initform nil
643     :reader specializer-type)))
644 wlott 1.1
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 ram 1.6 :initform ()
654     :accessor object-plist)))
655 wlott 1.1
656 ram 1.8 (defclass documentation-mixin (plist-mixin)
657     ())
658 wlott 1.1
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 ram 1.8 ;;; 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 wlott 1.1 ;;;
667 ram 1.8 (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 ram 1.6 :initform nil
675 ram 1.8 :reader class-eq-specializer)
676     (direct-superclasses
677     :initform ()
678     :reader class-direct-superclasses)
679 wlott 1.1 (direct-subclasses
680 ram 1.8 :initform ()
681 wlott 1.1 :reader class-direct-subclasses)
682 ram 1.8 (direct-methods
683     :initform (cons nil nil))
684     (predicate-name
685 ram 1.6 :initform nil
686 ram 1.8 :reader class-predicate-name)))
687 wlott 1.1
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 ram 1.8 ((class-precedence-list
694     :reader class-precedence-list)
695 ram 1.6 (can-precede-list
696     :initform ()
697     :reader class-can-precede-list)
698     (incompatible-superclass-list
699     :initform ()
700     :accessor class-incompatible-superclass-list)
701 wlott 1.1 (wrapper
702 ram 1.6 :initform nil
703     :reader class-wrapper)
704 ram 1.8 (prototype
705     :initform nil
706     :reader class-prototype)))
707 wlott 1.1
708 ram 1.6 (defclass slot-class (pcl-class)
709 ram 1.8 ((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 ram 1.6
719 wlott 1.1 ;;;
720     ;;; The class STD-CLASS is an implementation-specific common superclass of
721     ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
722     ;;;
723 ram 1.6 (defclass std-class (slot-class)
724 ram 1.8 ())
725 wlott 1.1
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 ram 1.6 (defclass structure-class (slot-class)
737 ram 1.8 ((defstruct-form
738     :initform ()
739     :accessor class-defstruct-form)
740 ram 1.6 (defstruct-constructor
741     :initform nil
742 ram 1.8 :accessor class-defstruct-constructor)
743 ram 1.6 (from-defclass-p
744     :initform nil
745 ram 1.8 :initarg :from-defclass-p)))
746    
747 ram 1.6
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 ram 1.8 (defclass class-prototype-specializer (specializer-with-object)
756     ((object :initarg :class :reader specializer-class :reader specializer-object)))
757    
758 ram 1.6 (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 wlott 1.1
770     ;;;
771     ;;; Slot definitions.
772     ;;;
773 ram 1.8 (defclass slot-definition (metaobject)
774 wlott 1.1 ((name
775     :initform nil
776 ram 1.6 :initarg :name
777     :accessor slot-definition-name)
778 wlott 1.1 (initform
779 ram 1.6 :initform nil
780     :initarg :initform
781     :accessor slot-definition-initform)
782 wlott 1.1 (initfunction
783 ram 1.6 :initform nil
784     :initarg :initfunction
785     :accessor slot-definition-initfunction)
786 wlott 1.1 (readers
787     :initform nil
788 ram 1.6 :initarg :readers
789     :accessor slot-definition-readers)
790 wlott 1.1 (writers
791     :initform nil
792 ram 1.6 :initarg :writers
793     :accessor slot-definition-writers)
794 wlott 1.1 (initargs
795     :initform nil
796 ram 1.6 :initarg :initargs
797     :accessor slot-definition-initargs)
798 wlott 1.1 (type
799 ram 1.6 :initform t
800     :initarg :type
801     :accessor slot-definition-type)
802 ram 1.8 (documentation
803     :initform ""
804     :initarg :documentation)
805 ram 1.4 (class
806     :initform nil
807 ram 1.6 :initarg :class
808 ram 1.8 :accessor slot-definition-class)))
809 wlott 1.1
810 ram 1.6 (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 ram 1.8 ((reader-function ; #'(lambda (object) ...)
835 ram 1.6 :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 ram 1.8 :initform 0)))
842 ram 1.6
843 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
844     direct-slot-definition)
845 ram 1.6 ())
846 wlott 1.1
847     (defclass standard-effective-slot-definition (standard-slot-definition
848     effective-slot-definition)
849 ram 1.8 ((location ; nil, a fixnum, a cons: (slot-name . value)
850     :initform nil
851     :accessor slot-definition-location)))
852 wlott 1.1
853 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
854     direct-slot-definition)
855     ())
856 wlott 1.1
857 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
858     effective-slot-definition)
859     ())
860 wlott 1.1
861 ram 1.8 (defclass method (metaobject) ())
862 ram 1.7
863 ram 1.8 (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 ram 1.7
892 ram 1.8 (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 ram 1.7
900 ram 1.8 (defclass standard-reader-method (standard-accessor-method) ())
901 ram 1.7
902 ram 1.8 (defclass standard-writer-method (standard-accessor-method) ())
903 ram 1.7
904 ram 1.8 (defclass standard-boundp-method (standard-accessor-method) ())
905 ram 1.7
906 ram 1.8 (defclass generic-function (dependent-update-mixin
907     definition-source-mixin
908     documentation-mixin
909 ram 1.10.1.1 metaobject
910     #+cmu17 kernel:funcallable-instance)
911 ram 1.8 ()
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 ram 1.7
942 ram 1.8 (defclass method-combination (metaobject) ())
943 ram 1.7
944 ram 1.8 (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 ram 1.7
953 ram 1.6 (defparameter *early-class-predicates*
954     '((specializer specializerp)
955     (exact-class-specializer exact-class-specializer-p)
956     (class-eq-specializer class-eq-specializer-p)
957     (eql-specializer eql-specializer-p)
958     (class classp)
959 ram 1.8 (slot-class slot-class-p)
960 ram 1.6 (standard-class standard-class-p)
961     (funcallable-standard-class funcallable-standard-class-p)
962     (structure-class structure-class-p)
963 ram 1.8 (forward-referenced-class forward-referenced-class-p)
964     (method method-p)
965     (standard-method standard-method-p)
966     (standard-accessor-method standard-accessor-method-p)
967     (standard-reader-method standard-reader-method-p)
968     (standard-writer-method standard-writer-method-p)
969     (standard-boundp-method standard-boundp-method-p)
970     (generic-function generic-function-p)
971     (standard-generic-function standard-generic-function-p)
972     (method-combination method-combination-p)))
973 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5