/[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.4 - (hide annotations) (vendor branch)
Tue Oct 4 12:54:29 1994 UTC (19 years, 6 months ago) by ram
Branch: cmu
Changes since 1.10.1.3: +2 -1 lines
Commented out defvar of *boot-state* in defs.
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     (defstruct (structure-object
633     (:constructor |STRUCTURE-OBJECT class constructor|)))
634    
635     (defclass standard-object (slot-object) ())
636    
637 wlott 1.1 (defclass metaobject (standard-object) ())
638    
639 ram 1.6 (defclass specializer (metaobject)
640     ((type
641     :initform nil
642     :reader specializer-type)))
643 wlott 1.1
644     (defclass definition-source-mixin (standard-object)
645     ((source
646     :initform (load-truename)
647     :reader definition-source
648     :initarg :definition-source)))
649    
650     (defclass plist-mixin (standard-object)
651     ((plist
652 ram 1.6 :initform ()
653     :accessor object-plist)))
654 wlott 1.1
655 ram 1.8 (defclass documentation-mixin (plist-mixin)
656     ())
657 wlott 1.1
658     (defclass dependent-update-mixin (plist-mixin)
659     ())
660    
661     ;;;
662     ;;; The class CLASS is a specified basic class. It is the common superclass
663 ram 1.8 ;;; of any kind of class. That is any class that can be a metaclass must
664     ;;; have the class CLASS in its class precedence list.
665 wlott 1.1 ;;;
666 ram 1.8 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
667     specializer)
668     ((name
669     :initform nil
670     :initarg :name
671     :accessor class-name)
672     (class-eq-specializer
673 ram 1.6 :initform nil
674 ram 1.8 :reader class-eq-specializer)
675     (direct-superclasses
676     :initform ()
677     :reader class-direct-superclasses)
678 wlott 1.1 (direct-subclasses
679 ram 1.8 :initform ()
680 wlott 1.1 :reader class-direct-subclasses)
681 ram 1.8 (direct-methods
682     :initform (cons nil nil))
683     (predicate-name
684 ram 1.6 :initform nil
685 ram 1.8 :reader class-predicate-name)))
686 wlott 1.1
687     ;;;
688     ;;; The class PCL-CLASS is an implementation-specific common superclass of
689     ;;; all specified subclasses of the class CLASS.
690     ;;;
691     (defclass pcl-class (class)
692 ram 1.8 ((class-precedence-list
693     :reader class-precedence-list)
694 ram 1.6 (can-precede-list
695     :initform ()
696     :reader class-can-precede-list)
697     (incompatible-superclass-list
698     :initform ()
699     :accessor class-incompatible-superclass-list)
700 wlott 1.1 (wrapper
701 ram 1.6 :initform nil
702     :reader class-wrapper)
703 ram 1.8 (prototype
704     :initform nil
705     :reader class-prototype)))
706 wlott 1.1
707 ram 1.6 (defclass slot-class (pcl-class)
708 ram 1.8 ((direct-slots
709     :initform ()
710     :accessor class-direct-slots)
711     (slots
712     :initform ()
713     :accessor class-slots)
714     (initialize-info
715     :initform nil
716     :accessor class-initialize-info)))
717 ram 1.6
718 wlott 1.1 ;;;
719     ;;; The class STD-CLASS is an implementation-specific common superclass of
720     ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
721     ;;;
722 ram 1.6 (defclass std-class (slot-class)
723 ram 1.8 ())
724 wlott 1.1
725     (defclass standard-class (std-class)
726     ())
727    
728     (defclass funcallable-standard-class (std-class)
729     ())
730    
731     (defclass forward-referenced-class (pcl-class) ())
732    
733     (defclass built-in-class (pcl-class) ())
734    
735 ram 1.6 (defclass structure-class (slot-class)
736 ram 1.8 ((defstruct-form
737     :initform ()
738     :accessor class-defstruct-form)
739 ram 1.6 (defstruct-constructor
740     :initform nil
741 ram 1.8 :accessor class-defstruct-constructor)
742 ram 1.6 (from-defclass-p
743     :initform nil
744 ram 1.8 :initarg :from-defclass-p)))
745    
746 ram 1.6
747     (defclass specializer-with-object (specializer) ())
748    
749     (defclass exact-class-specializer (specializer) ())
750    
751     (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
752     ((object :initarg :class :reader specializer-class :reader specializer-object)))
753    
754 ram 1.8 (defclass class-prototype-specializer (specializer-with-object)
755     ((object :initarg :class :reader specializer-class :reader specializer-object)))
756    
757 ram 1.6 (defclass eql-specializer (exact-class-specializer specializer-with-object)
758     ((object :initarg :object :reader specializer-object
759     :reader eql-specializer-object)))
760    
761     (defvar *eql-specializer-table* (make-hash-table :test 'eql))
762    
763     (defun intern-eql-specializer (object)
764     (or (gethash object *eql-specializer-table*)
765     (setf (gethash object *eql-specializer-table*)
766     (make-instance 'eql-specializer :object object))))
767    
768 wlott 1.1
769     ;;;
770     ;;; Slot definitions.
771     ;;;
772 ram 1.8 (defclass slot-definition (metaobject)
773 wlott 1.1 ((name
774     :initform nil
775 ram 1.6 :initarg :name
776     :accessor slot-definition-name)
777 wlott 1.1 (initform
778 ram 1.6 :initform nil
779     :initarg :initform
780     :accessor slot-definition-initform)
781 wlott 1.1 (initfunction
782 ram 1.6 :initform nil
783     :initarg :initfunction
784     :accessor slot-definition-initfunction)
785 wlott 1.1 (readers
786     :initform nil
787 ram 1.6 :initarg :readers
788     :accessor slot-definition-readers)
789 wlott 1.1 (writers
790     :initform nil
791 ram 1.6 :initarg :writers
792     :accessor slot-definition-writers)
793 wlott 1.1 (initargs
794     :initform nil
795 ram 1.6 :initarg :initargs
796     :accessor slot-definition-initargs)
797 wlott 1.1 (type
798 ram 1.6 :initform t
799     :initarg :type
800     :accessor slot-definition-type)
801 ram 1.8 (documentation
802     :initform ""
803     :initarg :documentation)
804 ram 1.4 (class
805     :initform nil
806 ram 1.6 :initarg :class
807 ram 1.8 :accessor slot-definition-class)))
808 wlott 1.1
809 ram 1.6 (defclass standard-slot-definition (slot-definition)
810     ((allocation
811     :initform :instance
812     :initarg :allocation
813     :accessor slot-definition-allocation)))
814    
815     (defclass structure-slot-definition (slot-definition)
816     ((defstruct-accessor-symbol
817     :initform nil
818     :initarg :defstruct-accessor-symbol
819     :accessor slot-definition-defstruct-accessor-symbol)
820     (internal-reader-function
821     :initform nil
822     :initarg :internal-reader-function
823     :accessor slot-definition-internal-reader-function)
824     (internal-writer-function
825     :initform nil
826     :initarg :internal-writer-function
827     :accessor slot-definition-internal-writer-function)))
828    
829     (defclass direct-slot-definition (slot-definition)
830     ())
831    
832     (defclass effective-slot-definition (slot-definition)
833 ram 1.8 ((reader-function ; #'(lambda (object) ...)
834 ram 1.6 :accessor slot-definition-reader-function)
835     (writer-function ; #'(lambda (new-value object) ...)
836     :accessor slot-definition-writer-function)
837     (boundp-function ; #'(lambda (object) ...)
838     :accessor slot-definition-boundp-function)
839     (accessor-flags
840 ram 1.8 :initform 0)))
841 ram 1.6
842 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
843     direct-slot-definition)
844 ram 1.6 ())
845 wlott 1.1
846     (defclass standard-effective-slot-definition (standard-slot-definition
847     effective-slot-definition)
848 ram 1.8 ((location ; nil, a fixnum, a cons: (slot-name . value)
849     :initform nil
850     :accessor slot-definition-location)))
851 wlott 1.1
852 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
853     direct-slot-definition)
854     ())
855 wlott 1.1
856 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
857     effective-slot-definition)
858     ())
859 wlott 1.1
860 ram 1.8 (defclass method (metaobject) ())
861 ram 1.7
862 ram 1.8 (defclass standard-method (definition-source-mixin plist-mixin method)
863     ((generic-function
864     :initform nil
865     :accessor method-generic-function)
866     ; (qualifiers
867     ; :initform ()
868     ; :initarg :qualifiers
869     ; :reader method-qualifiers)
870     (specializers
871     :initform ()
872     :initarg :specializers
873     :reader method-specializers)
874     (lambda-list
875     :initform ()
876     :initarg :lambda-list
877     :reader method-lambda-list)
878     (function
879     :initform nil
880     :initarg :function) ;no writer
881     (fast-function
882     :initform nil
883     :initarg :fast-function ;no writer
884     :reader method-fast-function)
885     ; (documentation
886     ; :initform nil
887     ; :initarg :documentation
888     ; :reader method-documentation)
889     ))
890 ram 1.7
891 ram 1.8 (defclass standard-accessor-method (standard-method)
892     ((slot-name :initform nil
893     :initarg :slot-name
894     :reader accessor-method-slot-name)
895     (slot-definition :initform nil
896     :initarg :slot-definition
897     :reader accessor-method-slot-definition)))
898 ram 1.7
899 ram 1.8 (defclass standard-reader-method (standard-accessor-method) ())
900 ram 1.7
901 ram 1.8 (defclass standard-writer-method (standard-accessor-method) ())
902 ram 1.7
903 ram 1.8 (defclass standard-boundp-method (standard-accessor-method) ())
904 ram 1.7
905 ram 1.8 (defclass generic-function (dependent-update-mixin
906     definition-source-mixin
907     documentation-mixin
908 ram 1.10.1.1 metaobject
909     #+cmu17 kernel:funcallable-instance)
910 ram 1.8 ()
911     (:metaclass funcallable-standard-class))
912    
913     (defclass standard-generic-function (generic-function)
914     ((name
915     :initform nil
916     :initarg :name
917     :accessor generic-function-name)
918     (methods
919     :initform ()
920     :accessor generic-function-methods)
921     (method-class
922     :initarg :method-class
923     :accessor generic-function-method-class)
924     (method-combination
925     :initarg :method-combination
926     :accessor generic-function-method-combination)
927     (arg-info
928     :initform (make-arg-info)
929     :reader gf-arg-info)
930     (dfun-state
931     :initform ()
932     :accessor gf-dfun-state)
933     (pretty-arglist
934     :initform ()
935     :accessor gf-pretty-arglist)
936     )
937     (:metaclass funcallable-standard-class)
938     (:default-initargs :method-class *the-class-standard-method*
939     :method-combination *standard-method-combination*))
940 ram 1.7
941 ram 1.8 (defclass method-combination (metaobject) ())
942 ram 1.7
943 ram 1.8 (defclass standard-method-combination
944     (definition-source-mixin method-combination)
945     ((type :reader method-combination-type
946     :initarg :type)
947     (documentation :reader method-combination-documentation
948     :initarg :documentation)
949     (options :reader method-combination-options
950     :initarg :options)))
951 ram 1.7
952 ram 1.6 (defparameter *early-class-predicates*
953     '((specializer specializerp)
954     (exact-class-specializer exact-class-specializer-p)
955     (class-eq-specializer class-eq-specializer-p)
956     (eql-specializer eql-specializer-p)
957     (class classp)
958 ram 1.8 (slot-class slot-class-p)
959 ram 1.6 (standard-class standard-class-p)
960     (funcallable-standard-class funcallable-standard-class-p)
961     (structure-class structure-class-p)
962 ram 1.8 (forward-referenced-class forward-referenced-class-p)
963     (method method-p)
964     (standard-method standard-method-p)
965     (standard-accessor-method standard-accessor-method-p)
966     (standard-reader-method standard-reader-method-p)
967     (standard-writer-method standard-writer-method-p)
968     (standard-boundp-method standard-boundp-method-p)
969     (generic-function generic-function-p)
970     (standard-generic-function standard-generic-function-p)
971     (method-combination method-combination-p)))
972 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5