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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Fri Jun 5 02:53:51 1998 UTC (15 years, 10 months ago) by dtc
Branch: MAIN
Changes since 1.13: +30 -54 lines
Rework the PCL class hierarchy to better match the disjoint instance
and funcallable-instance types within CMUCL. Add the new class
funcallable-standard-object, and the new class std-object as a
superclass of both standard-object and
funcallable-standard-object. Generic-functions are now
funcallable-standard-objects implemented as FINs and disjoint from
standard-objects which are implemented as instances in CMUCL, fixing
some problems in the type system.

This change moves the PCL implementation away from the MOP
specification which requires that generic-functions be
standard-objects. However ANSI CL does not require generic functions
to be standard-objects and the MOP author Gregor Kiczales suggests it
is appropriate for generic functions to be disjoint from
standard-objects.
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 dtc 1.14 *the-class-structure-object*
189     *the-class-std-object*
190 ram 1.6 *the-class-standard-object*
191 dtc 1.14 *the-class-funcallable-standard-object*
192 ram 1.6 *the-class-class*
193     *the-class-generic-function*
194     *the-class-built-in-class*
195     *the-class-slot-class*
196     *the-class-structure-class*
197 dtc 1.14 *the-class-std-class*
198 ram 1.6 *the-class-standard-class*
199     *the-class-funcallable-standard-class*
200 ram 1.8 *the-class-method*
201 ram 1.6 *the-class-standard-method*
202 ram 1.8 *the-class-standard-reader-method*
203     *the-class-standard-writer-method*
204     *the-class-standard-boundp-method*
205 ram 1.6 *the-class-standard-generic-function*
206 ram 1.8 *the-class-standard-effective-slot-definition*
207 ram 1.6
208 ram 1.8 *the-eslotd-standard-class-slots*
209     *the-eslotd-funcallable-standard-class-slots*))
210    
211 ram 1.6 (proclaim '(special *the-wrapper-of-t*
212     *the-wrapper-of-vector* *the-wrapper-of-symbol*
213     *the-wrapper-of-string* *the-wrapper-of-sequence*
214     *the-wrapper-of-rational* *the-wrapper-of-ratio*
215     *the-wrapper-of-number* *the-wrapper-of-null*
216     *the-wrapper-of-list* *the-wrapper-of-integer*
217     *the-wrapper-of-float* *the-wrapper-of-cons*
218     *the-wrapper-of-complex* *the-wrapper-of-character*
219     *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
220    
221 pw 1.11 ;;;; Type specifier hackery:
222    
223     ;;; internal to this file.
224 ram 1.6 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
225     (if (symbolp class)
226     (or (find-class class (not make-forward-referenced-class-p))
227     (ensure-class class))
228     class))
229    
230 pw 1.11 ;;; Interface
231 ram 1.6 (defun specializer-from-type (type &aux args)
232     (when (consp type)
233     (setq args (cdr type) type (car type)))
234     (cond ((symbolp type)
235     (or (and (null args) (find-class type))
236     (ecase type
237     (class (coerce-to-class (car args)))
238 ram 1.8 (prototype (make-instance 'class-prototype-specializer
239     :object (coerce-to-class (car args))))
240 ram 1.6 (class-eq (class-eq-specializer (coerce-to-class (car args))))
241     (eql (intern-eql-specializer (car args))))))
242 pw 1.11 #+cmu17
243     ((and (null args) (typep type 'lisp:class))
244     (or (kernel:class-pcl-class type)
245     (find-structure-class (lisp:class-name type))))
246 ram 1.6 ((specializerp type) type)))
247    
248 pw 1.11 ;;; interface
249 ram 1.6 (defun type-from-specializer (specl)
250 ram 1.8 (cond ((eq specl 't)
251     't)
252     ((consp specl)
253     (unless (member (car specl) '(class prototype class-eq eql))
254 ram 1.6 (error "~S is not a legal specializer type" specl))
255     specl)
256 ram 1.8 ((progn
257     (when (symbolp specl)
258     ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
259     (setq specl (find-class specl)))
260     (or (not (eq *boot-state* 'complete))
261     (specializerp specl)))
262     (specializer-type specl))
263 ram 1.6 (t
264     (error "~s is neither a type nor a specializer" specl))))
265    
266 ram 1.4 (defun type-class (type)
267 ram 1.6 (declare (special *the-class-t*))
268     (setq type (type-from-specializer type))
269     (if (atom type)
270 ram 1.8 (if (eq type 't)
271     *the-class-t*
272     (error "bad argument to type-class"))
273 ram 1.4 (case (car type)
274 ram 1.6 (eql (class-of (cadr type)))
275 ram 1.8 (prototype (class-of (cadr type))) ;?
276 ram 1.6 (class-eq (cadr type))
277     (class (cadr type)))))
278 ram 1.4
279 ram 1.6 (defun class-eq-type (class)
280     (specializer-type (class-eq-specializer class)))
281 ram 1.4
282 ram 1.6 (defun inform-type-system-about-std-class (name)
283     (let ((predicate-name (make-type-predicate-name name)))
284 phg 1.9 (setf (gdefinition predicate-name) (make-type-predicate name))
285 ram 1.6 (do-satisfies-deftype name predicate-name)))
286    
287     (defun make-type-predicate (name)
288     (let ((cell (find-class-cell name)))
289     #'(lambda (x)
290 ram 1.8 (funcall (the function (find-class-cell-predicate cell)) x))))
291 ram 1.6
292    
293     ;This stuff isn't right. Good thing it isn't used.
294     ;The satisfies predicate has to be a symbol. There is no way to
295     ;construct such a symbol from a class object if class names change.
296     (defun class-predicate (class)
297     (when (symbolp class) (setq class (find-class class)))
298     #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
299    
300 ram 1.4 (defun make-class-eq-predicate (class)
301     (when (symbolp class) (setq class (find-class class)))
302     #'(lambda (object) (eq class (class-of object))))
303    
304     (defun make-eql-predicate (eql-object)
305     #'(lambda (object) (eql eql-object object)))
306    
307 ram 1.6 #|| ; The argument to satisfies must be a symbol.
308     (deftype class (&optional class)
309     (if class
310     `(satisfies ,(class-predicate class))
311     `(satisfies ,(class-predicate 'class))))
312 ram 1.4
313 ram 1.6 (deftype class-eq (class)
314     `(satisfies ,(make-class-eq-predicate class)))
315     ||#
316 ram 1.4
317 pw 1.11 #-(or excl cmu17)
318 ram 1.6 (deftype eql (type-object)
319     `(member ,type-object))
320 ram 1.4
321 ram 1.8
322 pw 1.11 ;;; Internal to this file.
323 wlott 1.1 ;;;
324     ;;; These functions are a pale imitiation of their namesake. They accept
325     ;;; class objects or types where they should.
326     ;;;
327 ram 1.6 (defun *normalize-type (type)
328     (cond ((consp type)
329     (if (member (car type) '(not and or))
330     `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
331     (if (null (cdr type))
332     (*normalize-type (car type))
333     type)))
334     ((symbolp type)
335     (let ((class (find-class type nil)))
336     (if class
337     (let ((type (specializer-type class)))
338     (if (listp type) type `(,type)))
339     `(,type))))
340 ram 1.8 ((or (not (eq *boot-state* 'complete))
341     (specializerp type))
342     (specializer-type type))
343 ram 1.6 (t
344     (error "~s is not a type" type))))
345    
346 pw 1.11 ;;; Not used...
347     #+nil
348 ram 1.6 (defun unparse-type-list (tlist)
349     (mapcar #'unparse-type tlist))
350    
351 pw 1.11 ;;; Not used...
352     #+nil
353 ram 1.6 (defun unparse-type (type)
354     (if (atom type)
355     (if (specializerp type)
356     (unparse-type (specializer-type type))
357     type)
358     (case (car type)
359     (eql type)
360     (class-eq `(class-eq ,(class-name (cadr type))))
361     (class (class-name (cadr type)))
362     (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
363    
364 pw 1.11 ;;; internal to this file...
365 ram 1.6 (defun convert-to-system-type (type)
366     (case (car type)
367 pw 1.11 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
368     (cdr type))))
369     ((class class-eq) ; class-eq is impossible to do right
370     #-cmu17 (class-name (cadr type))
371     #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))
372 ram 1.6 (eql type)
373     (t (if (null (cdr type))
374     (car type)
375     type))))
376    
377 pw 1.11 ;;; not used...
378     #+nil
379 wlott 1.1 (defun *typep (object type)
380 ram 1.6 (setq type (*normalize-type type))
381 ram 1.8 (cond ((member (car type) '(eql wrapper-eq class-eq class))
382 ram 1.6 (specializer-applicable-using-type-p type `(eql ,object)))
383     ((eq (car type) 'not)
384     (not (*typep object (cadr type))))
385     (t
386     (typep object (convert-to-system-type type)))))
387 wlott 1.1
388 pw 1.11
389     ;;; *SUBTYPEP -- Interface
390     ;;;
391 phg 1.10 ;Writing the missing NOT and AND clauses will improve
392     ;the quality of code generated by generate-discrimination-net, but
393     ;calling subtypep in place of just returning (values nil nil) can be
394     ;very slow. *subtypep is used by PCL itself, and must be fast.
395 wlott 1.1 (defun *subtypep (type1 type2)
396 ram 1.8 (if (equal type1 type2)
397     (values t t)
398     (if (eq *boot-state* 'early)
399     (values (eq type1 type2) t)
400 phg 1.10 (let ((*in-precompute-effective-methods-p* t))
401 ram 1.8 (declare (special *in-precompute-effective-methods-p*))
402 phg 1.10 ;; *in-precompute-effective-methods-p* is not a good name.
403     ;; It changes the way class-applicable-using-class-p works.
404 ram 1.8 (setq type1 (*normalize-type type1))
405     (setq type2 (*normalize-type type2))
406 phg 1.10 (case (car type2)
407     (not
408     (values nil nil)) ; Should improve this.
409     (and
410     (values nil nil)) ; Should improve this.
411     ((eql wrapper-eq class-eq class)
412     (multiple-value-bind (app-p maybe-app-p)
413     (specializer-applicable-using-type-p type2 type1)
414     (values app-p (or app-p (not maybe-app-p)))))
415     (t
416     (subtypep (convert-to-system-type type1)
417     (convert-to-system-type type2))))))))
418 wlott 1.1
419     (defun do-satisfies-deftype (name predicate)
420 pw 1.11 #+cmu17 (declare (ignore name predicate))
421 ram 1.6 #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
422 wlott 1.1 (let* ((specifier `(satisfies ,predicate))
423     (expand-fn #'(lambda (&rest ignore)
424     (declare (ignore ignore))
425     specifier)))
426     ;; Specific ports can insert their own way of doing this. Many
427     ;; ports may find the expand-fn defined above useful.
428     ;;
429     (or #+:Genera
430     (setf (get name 'deftype) expand-fn)
431     #+(and :Lucid (not :Prime))
432     (system::define-macro `(deftype ,name) expand-fn nil)
433     #+ExCL
434     (setf (get name 'excl::deftype-expander) expand-fn)
435     #+:coral
436 ram 1.6 (setf (get name 'ccl::deftype-expander) expand-fn)))
437 pw 1.11 #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17)
438 ram 1.6 ;; This is the default for ports for which we don't know any
439     ;; better. Note that for most ports, providing this definition
440     ;; should just speed up class definition. It shouldn't have an
441     ;; effect on performance of most user code.
442     (eval `(deftype ,name () '(satisfies ,predicate))))
443 wlott 1.1
444 ram 1.6 (defun make-type-predicate-name (name &optional kind)
445     (if (symbol-package name)
446     (intern (format nil
447     "~@[~A ~]TYPE-PREDICATE ~A ~A"
448     kind
449     (package-name (symbol-package name))
450     (symbol-name name))
451     *the-pcl-package*)
452     (make-symbol (format nil
453     "~@[~A ~]TYPE-PREDICATE ~A"
454     kind
455     (symbol-name name)))))
456 wlott 1.2
457 wlott 1.1
458    
459     (defvar *built-in-class-symbols* ())
460     (defvar *built-in-wrapper-symbols* ())
461    
462     (defun get-built-in-class-symbol (class-name)
463     (or (cadr (assq class-name *built-in-class-symbols*))
464     (let ((symbol (intern (format nil
465     "*THE-CLASS-~A*"
466     (symbol-name class-name))
467     *the-pcl-package*)))
468     (push (list class-name symbol) *built-in-class-symbols*)
469     symbol)))
470    
471     (defun get-built-in-wrapper-symbol (class-name)
472     (or (cadr (assq class-name *built-in-wrapper-symbols*))
473     (let ((symbol (intern (format nil
474     "*THE-WRAPPER-OF-~A*"
475     (symbol-name class-name))
476     *the-pcl-package*)))
477     (push (list class-name symbol) *built-in-wrapper-symbols*)
478     symbol)))
479    
480    
481    
482    
483     (pushnew 'class *variable-declarations*)
484     (pushnew 'variable-rebinding *variable-declarations*)
485    
486     (defun variable-class (var env)
487     (caddr (variable-declaration 'class var env)))
488    
489 ram 1.8 (defvar *name->class->slotd-table* (make-hash-table))
490 wlott 1.1
491    
492     ;;;
493     ;;; This is used by combined methods to communicate the next methods to
494     ;;; the methods they call. This variable is captured by a lexical variable
495     ;;; of the methods to give it the proper lexical scope.
496     ;;;
497     (defvar *next-methods* nil)
498    
499     (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
500    
501     (defvar *umi-gfs*)
502     (defvar *umi-complete-classes*)
503     (defvar *umi-reorder*)
504    
505     (defvar *invalidate-discriminating-function-force-p* ())
506     (defvar *invalid-dfuns-on-stack* ())
507    
508    
509     (defvar *standard-method-combination*)
510    
511     (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
512    
513    
514 ram 1.6 (defmacro define-gf-predicate (predicate-name &rest classes)
515     `(progn
516     (defmethod ,predicate-name ((x t)) nil)
517     ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
518     classes)))
519 wlott 1.1
520 ram 1.6 (defun make-class-predicate-name (name)
521 ram 1.8 (intern (format nil "~A::~A class predicate"
522     (package-name (symbol-package name))
523     name)
524     *the-pcl-package*))
525 wlott 1.1
526 ram 1.8 (defun plist-value (object name)
527     (getf (object-plist object) name))
528 wlott 1.1
529 ram 1.6 (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
530 ram 1.8 (if new-value
531     (setf (getf (object-plist object) name) new-value)
532     (progn
533     (remf (object-plist object) name)
534     nil)))
535 ram 1.6
536 wlott 1.1
537    
538     (defvar *built-in-classes*
539     ;;
540     ;; name supers subs cdr of cpl
541 ram 1.8 ;; prototype
542 ram 1.6 '(;(t () (number sequence array character symbol) ())
543 ram 1.8 (number (t) (complex float rational) (t))
544 ram 1.6 (complex (number) () (number t)
545 ram 1.8 #c(1 1))
546 ram 1.6 (float (number) () (number t)
547 ram 1.8 1.0)
548     (rational (number) (integer ratio) (number t))
549 ram 1.6 (integer (rational) () (rational number t)
550 ram 1.8 1)
551 ram 1.6 (ratio (rational) () (rational number t)
552     1/2)
553 wlott 1.1
554 ram 1.8 (sequence (t) (list vector) (t))
555     (list (sequence) (cons null) (sequence t))
556 ram 1.6 (cons (list) () (list sequence t)
557 ram 1.8 (nil))
558 wlott 1.1
559    
560 ram 1.6 (array (t) (vector) (t)
561 ram 1.8 #2A((NIL)))
562 wlott 1.1 (vector (array
563 ram 1.6 sequence) (string bit-vector) (array sequence t)
564 ram 1.8 #())
565 ram 1.6 (string (vector) () (vector array sequence t)
566 ram 1.8 "")
567 ram 1.6 (bit-vector (vector) () (vector array sequence t)
568 ram 1.8 #*1)
569 ram 1.6 (character (t) () (t)
570 ram 1.8 #\c)
571 wlott 1.1
572 ram 1.6 (symbol (t) (null) (t)
573 ram 1.8 symbol)
574     (null (symbol
575     list) () (symbol list sequence t)
576     nil)))
577 wlott 1.1
578 pw 1.11 #+cmu17
579     (labels ((direct-supers (class)
580     (if (typep class 'lisp:built-in-class)
581     (kernel:built-in-class-direct-superclasses class)
582     (let ((inherits (kernel:layout-inherits
583     (kernel:class-layout class))))
584     (list (svref inherits (1- (length inherits)))))))
585     (direct-subs (class)
586     (ext:collect ((res))
587     (let ((subs (kernel:class-subclasses class)))
588     (when subs
589     (ext:do-hash (sub v subs)
590     (declare (ignore v))
591     (when (member class (direct-supers sub))
592     (res sub)))))
593     (res))))
594     (ext:collect ((res))
595     (dolist (bic kernel::built-in-classes)
596     (let* ((name (car bic))
597     (class (lisp:find-class name)))
598     (unless (member name '(t kernel:instance kernel:funcallable-instance
599 dtc 1.12 function stream))
600 pw 1.11 (res `(,name
601     ,(mapcar #'lisp:class-name (direct-supers class))
602     ,(mapcar #'lisp:class-name (direct-subs class))
603     ,(map 'list #'(lambda (x)
604     (lisp:class-name (kernel:layout-class x)))
605     (reverse
606     (kernel:layout-inherits
607     (kernel:class-layout class))))
608     ,(let ((found (assoc name *built-in-classes*)))
609     (if found (fifth found) 42)))))))
610     (setq *built-in-classes* (res))))
611    
612 wlott 1.1
613     ;;;
614     ;;; The classes that define the kernel of the metabraid.
615     ;;;
616     (defclass t () ()
617     (:metaclass built-in-class))
618    
619 pw 1.11 #+cmu17
620     (progn
621     (defclass kernel:instance (t) ()
622     (:metaclass built-in-class))
623    
624     (defclass function (t) ()
625     (:metaclass built-in-class))
626    
627     (defclass kernel:funcallable-instance (function) ()
628 dtc 1.12 (:metaclass built-in-class))
629    
630     (defclass stream (t) ()
631 pw 1.11 (:metaclass built-in-class)))
632    
633 dtc 1.14 (defclass slot-object (t) ()
634 ram 1.6 (:metaclass slot-class))
635 wlott 1.1
636 dtc 1.14 (defclass structure-object (slot-object #+cmu17 kernel:instance) ()
637 ram 1.6 (:metaclass structure-class))
638    
639 pw 1.11 (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object
640 ram 1.6 (:constructor |STRUCTURE-OBJECT class constructor|)))
641    
642 pw 1.11
643 dtc 1.14 (defclass std-object (slot-object) ()
644     (:metaclass std-class))
645    
646     (defclass standard-object (std-object #+cmu17 kernel:instance) ())
647 ram 1.6
648 dtc 1.14 (defclass funcallable-standard-object (std-object
649     #+cmu17 kernel:funcallable-instance)
650     ()
651     (:metaclass funcallable-standard-class))
652 wlott 1.1
653 dtc 1.14 (defclass specializer (standard-object)
654 ram 1.6 ((type
655     :initform nil
656     :reader specializer-type)))
657 wlott 1.1
658 dtc 1.14 (defclass definition-source-mixin (std-object)
659 wlott 1.1 ((source
660     :initform (load-truename)
661     :reader definition-source
662 dtc 1.14 :initarg :definition-source))
663     (:metaclass std-class))
664 wlott 1.1
665 dtc 1.14 (defclass plist-mixin (std-object)
666 wlott 1.1 ((plist
667 ram 1.6 :initform ()
668 dtc 1.14 :accessor object-plist))
669     (:metaclass std-class))
670 wlott 1.1
671 ram 1.8 (defclass documentation-mixin (plist-mixin)
672 dtc 1.14 ()
673     (:metaclass std-class))
674 wlott 1.1
675     (defclass dependent-update-mixin (plist-mixin)
676 dtc 1.14 ()
677     (:metaclass std-class))
678 wlott 1.1
679     ;;;
680     ;;; The class CLASS is a specified basic class. It is the common superclass
681 ram 1.8 ;;; of any kind of class. That is any class that can be a metaclass must
682     ;;; have the class CLASS in its class precedence list.
683 wlott 1.1 ;;;
684 ram 1.8 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
685     specializer)
686     ((name
687     :initform nil
688     :initarg :name
689     :accessor class-name)
690     (class-eq-specializer
691 ram 1.6 :initform nil
692 ram 1.8 :reader class-eq-specializer)
693     (direct-superclasses
694     :initform ()
695     :reader class-direct-superclasses)
696 wlott 1.1 (direct-subclasses
697 ram 1.8 :initform ()
698 wlott 1.1 :reader class-direct-subclasses)
699 ram 1.8 (direct-methods
700     :initform (cons nil nil))
701     (predicate-name
702 ram 1.6 :initform nil
703 ram 1.8 :reader class-predicate-name)))
704 wlott 1.1
705     ;;;
706     ;;; The class PCL-CLASS is an implementation-specific common superclass of
707     ;;; all specified subclasses of the class CLASS.
708     ;;;
709     (defclass pcl-class (class)
710 ram 1.8 ((class-precedence-list
711     :reader class-precedence-list)
712 ram 1.6 (can-precede-list
713     :initform ()
714     :reader class-can-precede-list)
715     (incompatible-superclass-list
716     :initform ()
717     :accessor class-incompatible-superclass-list)
718 wlott 1.1 (wrapper
719 ram 1.6 :initform nil
720     :reader class-wrapper)
721 ram 1.8 (prototype
722     :initform nil
723     :reader class-prototype)))
724 wlott 1.1
725 ram 1.6 (defclass slot-class (pcl-class)
726 ram 1.8 ((direct-slots
727     :initform ()
728     :accessor class-direct-slots)
729     (slots
730     :initform ()
731     :accessor class-slots)
732     (initialize-info
733     :initform nil
734     :accessor class-initialize-info)))
735 ram 1.6
736 wlott 1.1 ;;;
737     ;;; The class STD-CLASS is an implementation-specific common superclass of
738     ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
739     ;;;
740 ram 1.6 (defclass std-class (slot-class)
741 ram 1.8 ())
742 wlott 1.1
743     (defclass standard-class (std-class)
744     ())
745    
746     (defclass funcallable-standard-class (std-class)
747     ())
748    
749     (defclass forward-referenced-class (pcl-class) ())
750    
751     (defclass built-in-class (pcl-class) ())
752    
753 ram 1.6 (defclass structure-class (slot-class)
754 ram 1.8 ((defstruct-form
755     :initform ()
756     :accessor class-defstruct-form)
757 ram 1.6 (defstruct-constructor
758     :initform nil
759 ram 1.8 :accessor class-defstruct-constructor)
760 ram 1.6 (from-defclass-p
761     :initform nil
762 ram 1.8 :initarg :from-defclass-p)))
763    
764 ram 1.6
765     (defclass specializer-with-object (specializer) ())
766    
767     (defclass exact-class-specializer (specializer) ())
768    
769     (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
770     ((object :initarg :class :reader specializer-class :reader specializer-object)))
771    
772 ram 1.8 (defclass class-prototype-specializer (specializer-with-object)
773     ((object :initarg :class :reader specializer-class :reader specializer-object)))
774    
775 ram 1.6 (defclass eql-specializer (exact-class-specializer specializer-with-object)
776     ((object :initarg :object :reader specializer-object
777     :reader eql-specializer-object)))
778    
779     (defvar *eql-specializer-table* (make-hash-table :test 'eql))
780    
781     (defun intern-eql-specializer (object)
782     (or (gethash object *eql-specializer-table*)
783     (setf (gethash object *eql-specializer-table*)
784     (make-instance 'eql-specializer :object object))))
785    
786 wlott 1.1
787     ;;;
788     ;;; Slot definitions.
789     ;;;
790 dtc 1.14 (defclass slot-definition (standard-object)
791 wlott 1.1 ((name
792     :initform nil
793 ram 1.6 :initarg :name
794     :accessor slot-definition-name)
795 wlott 1.1 (initform
796 ram 1.6 :initform nil
797     :initarg :initform
798     :accessor slot-definition-initform)
799 wlott 1.1 (initfunction
800 ram 1.6 :initform nil
801     :initarg :initfunction
802     :accessor slot-definition-initfunction)
803 wlott 1.1 (readers
804     :initform nil
805 ram 1.6 :initarg :readers
806     :accessor slot-definition-readers)
807 wlott 1.1 (writers
808     :initform nil
809 ram 1.6 :initarg :writers
810     :accessor slot-definition-writers)
811 wlott 1.1 (initargs
812     :initform nil
813 ram 1.6 :initarg :initargs
814     :accessor slot-definition-initargs)
815 wlott 1.1 (type
816 ram 1.6 :initform t
817     :initarg :type
818     :accessor slot-definition-type)
819 ram 1.8 (documentation
820     :initform ""
821     :initarg :documentation)
822 ram 1.4 (class
823     :initform nil
824 ram 1.6 :initarg :class
825 ram 1.8 :accessor slot-definition-class)))
826 wlott 1.1
827 ram 1.6 (defclass standard-slot-definition (slot-definition)
828     ((allocation
829     :initform :instance
830     :initarg :allocation
831     :accessor slot-definition-allocation)))
832    
833     (defclass structure-slot-definition (slot-definition)
834     ((defstruct-accessor-symbol
835     :initform nil
836     :initarg :defstruct-accessor-symbol
837     :accessor slot-definition-defstruct-accessor-symbol)
838     (internal-reader-function
839     :initform nil
840     :initarg :internal-reader-function
841     :accessor slot-definition-internal-reader-function)
842     (internal-writer-function
843     :initform nil
844     :initarg :internal-writer-function
845     :accessor slot-definition-internal-writer-function)))
846    
847     (defclass direct-slot-definition (slot-definition)
848     ())
849    
850     (defclass effective-slot-definition (slot-definition)
851 ram 1.8 ((reader-function ; #'(lambda (object) ...)
852 ram 1.6 :accessor slot-definition-reader-function)
853     (writer-function ; #'(lambda (new-value object) ...)
854     :accessor slot-definition-writer-function)
855     (boundp-function ; #'(lambda (object) ...)
856     :accessor slot-definition-boundp-function)
857     (accessor-flags
858 ram 1.8 :initform 0)))
859 ram 1.6
860 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
861     direct-slot-definition)
862 ram 1.6 ())
863 wlott 1.1
864     (defclass standard-effective-slot-definition (standard-slot-definition
865     effective-slot-definition)
866 ram 1.8 ((location ; nil, a fixnum, a cons: (slot-name . value)
867     :initform nil
868     :accessor slot-definition-location)))
869 wlott 1.1
870 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
871     direct-slot-definition)
872     ())
873 wlott 1.1
874 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
875     effective-slot-definition)
876     ())
877 wlott 1.1
878 dtc 1.14 (defclass method (standard-object) ())
879 ram 1.7
880 ram 1.8 (defclass standard-method (definition-source-mixin plist-mixin method)
881     ((generic-function
882     :initform nil
883     :accessor method-generic-function)
884     ; (qualifiers
885     ; :initform ()
886     ; :initarg :qualifiers
887     ; :reader method-qualifiers)
888     (specializers
889     :initform ()
890     :initarg :specializers
891     :reader method-specializers)
892     (lambda-list
893     :initform ()
894     :initarg :lambda-list
895     :reader method-lambda-list)
896     (function
897     :initform nil
898     :initarg :function) ;no writer
899     (fast-function
900     :initform nil
901     :initarg :fast-function ;no writer
902     :reader method-fast-function)
903     ; (documentation
904     ; :initform nil
905     ; :initarg :documentation
906     ; :reader method-documentation)
907     ))
908 ram 1.7
909 ram 1.8 (defclass standard-accessor-method (standard-method)
910     ((slot-name :initform nil
911     :initarg :slot-name
912     :reader accessor-method-slot-name)
913     (slot-definition :initform nil
914     :initarg :slot-definition
915     :reader accessor-method-slot-definition)))
916 ram 1.7
917 ram 1.8 (defclass standard-reader-method (standard-accessor-method) ())
918 ram 1.7
919 ram 1.8 (defclass standard-writer-method (standard-accessor-method) ())
920 ram 1.7
921 ram 1.8 (defclass standard-boundp-method (standard-accessor-method) ())
922 ram 1.7
923 ram 1.8 (defclass generic-function (dependent-update-mixin
924     definition-source-mixin
925     documentation-mixin
926 dtc 1.14 funcallable-standard-object)
927 ram 1.8 ()
928     (:metaclass funcallable-standard-class))
929    
930     (defclass standard-generic-function (generic-function)
931     ((name
932     :initform nil
933     :initarg :name
934     :accessor generic-function-name)
935     (methods
936     :initform ()
937     :accessor generic-function-methods)
938     (method-class
939     :initarg :method-class
940     :accessor generic-function-method-class)
941     (method-combination
942     :initarg :method-combination
943     :accessor generic-function-method-combination)
944     (arg-info
945     :initform (make-arg-info)
946     :reader gf-arg-info)
947     (dfun-state
948     :initform ()
949     :accessor gf-dfun-state)
950     (pretty-arglist
951     :initform ()
952     :accessor gf-pretty-arglist)
953     )
954     (:metaclass funcallable-standard-class)
955     (:default-initargs :method-class *the-class-standard-method*
956     :method-combination *standard-method-combination*))
957 ram 1.7
958 dtc 1.14 (defclass method-combination (standard-object) ())
959 ram 1.7
960 ram 1.8 (defclass standard-method-combination
961     (definition-source-mixin method-combination)
962     ((type :reader method-combination-type
963     :initarg :type)
964     (documentation :reader method-combination-documentation
965     :initarg :documentation)
966     (options :reader method-combination-options
967     :initarg :options)))
968 ram 1.7
969 ram 1.6 (defparameter *early-class-predicates*
970     '((specializer specializerp)
971     (exact-class-specializer exact-class-specializer-p)
972     (class-eq-specializer class-eq-specializer-p)
973     (eql-specializer eql-specializer-p)
974     (class classp)
975 ram 1.8 (slot-class slot-class-p)
976 dtc 1.14 (std-class std-class-p)
977 ram 1.6 (standard-class standard-class-p)
978     (funcallable-standard-class funcallable-standard-class-p)
979     (structure-class structure-class-p)
980 ram 1.8 (forward-referenced-class forward-referenced-class-p)
981     (method method-p)
982     (standard-method standard-method-p)
983     (standard-accessor-method standard-accessor-method-p)
984     (standard-reader-method standard-reader-method-p)
985     (standard-writer-method standard-writer-method-p)
986     (standard-boundp-method standard-boundp-method-p)
987     (generic-function generic-function-p)
988     (standard-generic-function standard-generic-function-p)
989     (method-combination method-combination-p)))
990 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5