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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (hide annotations)
Thu Mar 11 16:51:04 1999 UTC (15 years, 1 month ago) by pw
Branch: MAIN
Changes since 1.14: +10 -122 lines
Cleanup of the PCL directory. Removed files and conditional code
for long dead lisp implementations. Some parts of the code is
now a bit easier to read and (hopefully) understand.
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.15 (declare (ignore setf-var setf-case))
79 wlott 1.1 (once-only (spec)
80 pw 1.15 `(cond (t
81     (let ((,non-setf-var ,spec)) ,@non-setf-case)))))
82 wlott 1.1
83     ;;;
84     ;;; If symbol names a function which is traced or advised, return the
85     ;;; unadvised, traced etc. definition. This lets me get at the generic
86     ;;; function object even when it is traced.
87     ;;;
88     (defun unencapsulated-fdefinition (symbol)
89 pw 1.15 (fdefinition symbol))
90 wlott 1.1
91     ;;;
92     ;;; If symbol names a function which is traced or advised, redefine
93     ;;; the `real' definition without affecting the advise.
94     ;;;
95 phg 1.9 (defun fdefine-carefully (name new-definition)
96     #+cmu (progn
97     (c::%%defun name new-definition nil)
98     (c::note-name-defined name :function)
99     new-definition)
100 pw 1.15 #-(or cmu)
101 phg 1.9 (setf (symbol-function name) new-definition))
102 wlott 1.1
103     (defun gboundp (spec)
104     (parse-gspec spec
105     (name (fboundp name))
106     (name (fboundp (get-setf-function-name name)))))
107    
108     (defun gmakunbound (spec)
109     (parse-gspec spec
110     (name (fmakunbound name))
111     (name (fmakunbound (get-setf-function-name name)))))
112    
113     (defun gdefinition (spec)
114     (parse-gspec spec
115 pw 1.15 (name (or (unencapsulated-fdefinition name)))
116 wlott 1.1 (name (unencapsulated-fdefinition (get-setf-function-name name)))))
117    
118 pw 1.15 (defun (setf gdefinition) (new-value spec)
119 wlott 1.1 (parse-gspec spec
120     (name (fdefine-carefully name new-value))
121     (name (fdefine-carefully (get-setf-function-name name) new-value))))
122    
123 ram 1.8
124 ram 1.6 (proclaim '(special *the-class-t*
125 ram 1.8 *the-class-vector* *the-class-symbol*
126 ram 1.6 *the-class-string* *the-class-sequence*
127     *the-class-rational* *the-class-ratio*
128     *the-class-number* *the-class-null* *the-class-list*
129     *the-class-integer* *the-class-float* *the-class-cons*
130     *the-class-complex* *the-class-character*
131     *the-class-bit-vector* *the-class-array*
132 dtc 1.12 *the-class-stream*
133 ram 1.6
134     *the-class-slot-object*
135 dtc 1.14 *the-class-structure-object*
136     *the-class-std-object*
137 ram 1.6 *the-class-standard-object*
138 dtc 1.14 *the-class-funcallable-standard-object*
139 ram 1.6 *the-class-class*
140     *the-class-generic-function*
141     *the-class-built-in-class*
142     *the-class-slot-class*
143     *the-class-structure-class*
144 dtc 1.14 *the-class-std-class*
145 ram 1.6 *the-class-standard-class*
146     *the-class-funcallable-standard-class*
147 ram 1.8 *the-class-method*
148 ram 1.6 *the-class-standard-method*
149 ram 1.8 *the-class-standard-reader-method*
150     *the-class-standard-writer-method*
151     *the-class-standard-boundp-method*
152 ram 1.6 *the-class-standard-generic-function*
153 ram 1.8 *the-class-standard-effective-slot-definition*
154 ram 1.6
155 ram 1.8 *the-eslotd-standard-class-slots*
156     *the-eslotd-funcallable-standard-class-slots*))
157    
158 ram 1.6 (proclaim '(special *the-wrapper-of-t*
159     *the-wrapper-of-vector* *the-wrapper-of-symbol*
160     *the-wrapper-of-string* *the-wrapper-of-sequence*
161     *the-wrapper-of-rational* *the-wrapper-of-ratio*
162     *the-wrapper-of-number* *the-wrapper-of-null*
163     *the-wrapper-of-list* *the-wrapper-of-integer*
164     *the-wrapper-of-float* *the-wrapper-of-cons*
165     *the-wrapper-of-complex* *the-wrapper-of-character*
166     *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
167    
168 pw 1.11 ;;;; Type specifier hackery:
169    
170     ;;; internal to this file.
171 ram 1.6 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
172     (if (symbolp class)
173     (or (find-class class (not make-forward-referenced-class-p))
174     (ensure-class class))
175     class))
176    
177 pw 1.11 ;;; Interface
178 ram 1.6 (defun specializer-from-type (type &aux args)
179     (when (consp type)
180     (setq args (cdr type) type (car type)))
181     (cond ((symbolp type)
182     (or (and (null args) (find-class type))
183     (ecase type
184     (class (coerce-to-class (car args)))
185 ram 1.8 (prototype (make-instance 'class-prototype-specializer
186     :object (coerce-to-class (car args))))
187 ram 1.6 (class-eq (class-eq-specializer (coerce-to-class (car args))))
188     (eql (intern-eql-specializer (car args))))))
189 pw 1.11 #+cmu17
190     ((and (null args) (typep type 'lisp:class))
191     (or (kernel:class-pcl-class type)
192     (find-structure-class (lisp:class-name type))))
193 ram 1.6 ((specializerp type) type)))
194    
195 pw 1.11 ;;; interface
196 ram 1.6 (defun type-from-specializer (specl)
197 ram 1.8 (cond ((eq specl 't)
198     't)
199     ((consp specl)
200     (unless (member (car specl) '(class prototype class-eq eql))
201 ram 1.6 (error "~S is not a legal specializer type" specl))
202     specl)
203 ram 1.8 ((progn
204     (when (symbolp specl)
205     ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
206     (setq specl (find-class specl)))
207     (or (not (eq *boot-state* 'complete))
208     (specializerp specl)))
209     (specializer-type specl))
210 ram 1.6 (t
211     (error "~s is neither a type nor a specializer" specl))))
212    
213 ram 1.4 (defun type-class (type)
214 ram 1.6 (declare (special *the-class-t*))
215     (setq type (type-from-specializer type))
216     (if (atom type)
217 ram 1.8 (if (eq type 't)
218     *the-class-t*
219     (error "bad argument to type-class"))
220 ram 1.4 (case (car type)
221 ram 1.6 (eql (class-of (cadr type)))
222 ram 1.8 (prototype (class-of (cadr type))) ;?
223 ram 1.6 (class-eq (cadr type))
224     (class (cadr type)))))
225 ram 1.4
226 ram 1.6 (defun class-eq-type (class)
227     (specializer-type (class-eq-specializer class)))
228 ram 1.4
229 ram 1.6 (defun inform-type-system-about-std-class (name)
230     (let ((predicate-name (make-type-predicate-name name)))
231 phg 1.9 (setf (gdefinition predicate-name) (make-type-predicate name))
232 ram 1.6 (do-satisfies-deftype name predicate-name)))
233    
234     (defun make-type-predicate (name)
235     (let ((cell (find-class-cell name)))
236     #'(lambda (x)
237 ram 1.8 (funcall (the function (find-class-cell-predicate cell)) x))))
238 ram 1.6
239    
240     ;This stuff isn't right. Good thing it isn't used.
241     ;The satisfies predicate has to be a symbol. There is no way to
242     ;construct such a symbol from a class object if class names change.
243     (defun class-predicate (class)
244     (when (symbolp class) (setq class (find-class class)))
245     #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
246    
247 ram 1.4 (defun make-class-eq-predicate (class)
248     (when (symbolp class) (setq class (find-class class)))
249     #'(lambda (object) (eq class (class-of object))))
250    
251     (defun make-eql-predicate (eql-object)
252     #'(lambda (object) (eql eql-object object)))
253    
254 ram 1.8
255 pw 1.11 ;;; Internal to this file.
256 wlott 1.1 ;;;
257     ;;; These functions are a pale imitiation of their namesake. They accept
258     ;;; class objects or types where they should.
259     ;;;
260 ram 1.6 (defun *normalize-type (type)
261     (cond ((consp type)
262     (if (member (car type) '(not and or))
263     `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
264     (if (null (cdr type))
265     (*normalize-type (car type))
266     type)))
267     ((symbolp type)
268     (let ((class (find-class type nil)))
269     (if class
270     (let ((type (specializer-type class)))
271     (if (listp type) type `(,type)))
272     `(,type))))
273 ram 1.8 ((or (not (eq *boot-state* 'complete))
274     (specializerp type))
275     (specializer-type type))
276 ram 1.6 (t
277     (error "~s is not a type" type))))
278    
279 pw 1.11 ;;; internal to this file...
280 ram 1.6 (defun convert-to-system-type (type)
281     (case (car type)
282 pw 1.11 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
283     (cdr type))))
284     ((class class-eq) ; class-eq is impossible to do right
285     #-cmu17 (class-name (cadr type))
286     #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))
287 ram 1.6 (eql type)
288     (t (if (null (cdr type))
289     (car type)
290     type))))
291    
292 pw 1.11
293     ;;; *SUBTYPEP -- Interface
294     ;;;
295 phg 1.10 ;Writing the missing NOT and AND clauses will improve
296     ;the quality of code generated by generate-discrimination-net, but
297     ;calling subtypep in place of just returning (values nil nil) can be
298     ;very slow. *subtypep is used by PCL itself, and must be fast.
299 wlott 1.1 (defun *subtypep (type1 type2)
300 ram 1.8 (if (equal type1 type2)
301     (values t t)
302     (if (eq *boot-state* 'early)
303     (values (eq type1 type2) t)
304 phg 1.10 (let ((*in-precompute-effective-methods-p* t))
305 ram 1.8 (declare (special *in-precompute-effective-methods-p*))
306 phg 1.10 ;; *in-precompute-effective-methods-p* is not a good name.
307     ;; It changes the way class-applicable-using-class-p works.
308 ram 1.8 (setq type1 (*normalize-type type1))
309     (setq type2 (*normalize-type type2))
310 phg 1.10 (case (car type2)
311     (not
312     (values nil nil)) ; Should improve this.
313     (and
314     (values nil nil)) ; Should improve this.
315     ((eql wrapper-eq class-eq class)
316     (multiple-value-bind (app-p maybe-app-p)
317     (specializer-applicable-using-type-p type2 type1)
318     (values app-p (or app-p (not maybe-app-p)))))
319     (t
320     (subtypep (convert-to-system-type type1)
321     (convert-to-system-type type2))))))))
322 wlott 1.1
323     (defun do-satisfies-deftype (name predicate)
324 pw 1.11 #+cmu17 (declare (ignore name predicate))
325 pw 1.15 #-(or cmu17)
326 ram 1.6 ;; This is the default for ports for which we don't know any
327     ;; better. Note that for most ports, providing this definition
328     ;; should just speed up class definition. It shouldn't have an
329     ;; effect on performance of most user code.
330     (eval `(deftype ,name () '(satisfies ,predicate))))
331 wlott 1.1
332 ram 1.6 (defun make-type-predicate-name (name &optional kind)
333     (if (symbol-package name)
334     (intern (format nil
335     "~@[~A ~]TYPE-PREDICATE ~A ~A"
336     kind
337     (package-name (symbol-package name))
338     (symbol-name name))
339     *the-pcl-package*)
340     (make-symbol (format nil
341     "~@[~A ~]TYPE-PREDICATE ~A"
342     kind
343     (symbol-name name)))))
344 wlott 1.2
345 wlott 1.1
346    
347     (defvar *built-in-class-symbols* ())
348     (defvar *built-in-wrapper-symbols* ())
349    
350     (defun get-built-in-class-symbol (class-name)
351     (or (cadr (assq class-name *built-in-class-symbols*))
352     (let ((symbol (intern (format nil
353     "*THE-CLASS-~A*"
354     (symbol-name class-name))
355     *the-pcl-package*)))
356     (push (list class-name symbol) *built-in-class-symbols*)
357     symbol)))
358    
359     (defun get-built-in-wrapper-symbol (class-name)
360     (or (cadr (assq class-name *built-in-wrapper-symbols*))
361     (let ((symbol (intern (format nil
362     "*THE-WRAPPER-OF-~A*"
363     (symbol-name class-name))
364     *the-pcl-package*)))
365     (push (list class-name symbol) *built-in-wrapper-symbols*)
366     symbol)))
367    
368    
369    
370    
371     (pushnew 'class *variable-declarations*)
372     (pushnew 'variable-rebinding *variable-declarations*)
373    
374     (defun variable-class (var env)
375     (caddr (variable-declaration 'class var env)))
376    
377 ram 1.8 (defvar *name->class->slotd-table* (make-hash-table))
378 wlott 1.1
379    
380     ;;;
381     ;;; This is used by combined methods to communicate the next methods to
382     ;;; the methods they call. This variable is captured by a lexical variable
383     ;;; of the methods to give it the proper lexical scope.
384     ;;;
385     (defvar *next-methods* nil)
386    
387     (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
388    
389     (defvar *umi-gfs*)
390     (defvar *umi-complete-classes*)
391     (defvar *umi-reorder*)
392    
393     (defvar *invalidate-discriminating-function-force-p* ())
394     (defvar *invalid-dfuns-on-stack* ())
395    
396    
397     (defvar *standard-method-combination*)
398    
399     (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
400    
401    
402 ram 1.6 (defmacro define-gf-predicate (predicate-name &rest classes)
403     `(progn
404     (defmethod ,predicate-name ((x t)) nil)
405     ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
406     classes)))
407 wlott 1.1
408 ram 1.6 (defun make-class-predicate-name (name)
409 ram 1.8 (intern (format nil "~A::~A class predicate"
410     (package-name (symbol-package name))
411     name)
412     *the-pcl-package*))
413 wlott 1.1
414 ram 1.8 (defun plist-value (object name)
415     (getf (object-plist object) name))
416 wlott 1.1
417 pw 1.15 (defun (setf plist-value) (new-value object name)
418 ram 1.8 (if new-value
419     (setf (getf (object-plist object) name) new-value)
420     (progn
421     (remf (object-plist object) name)
422     nil)))
423 ram 1.6
424 wlott 1.1
425    
426     (defvar *built-in-classes*
427     ;;
428     ;; name supers subs cdr of cpl
429 ram 1.8 ;; prototype
430 ram 1.6 '(;(t () (number sequence array character symbol) ())
431 ram 1.8 (number (t) (complex float rational) (t))
432 ram 1.6 (complex (number) () (number t)
433 ram 1.8 #c(1 1))
434 ram 1.6 (float (number) () (number t)
435 ram 1.8 1.0)
436     (rational (number) (integer ratio) (number t))
437 ram 1.6 (integer (rational) () (rational number t)
438 ram 1.8 1)
439 ram 1.6 (ratio (rational) () (rational number t)
440     1/2)
441 wlott 1.1
442 ram 1.8 (sequence (t) (list vector) (t))
443     (list (sequence) (cons null) (sequence t))
444 ram 1.6 (cons (list) () (list sequence t)
445 ram 1.8 (nil))
446 wlott 1.1
447    
448 ram 1.6 (array (t) (vector) (t)
449 ram 1.8 #2A((NIL)))
450 wlott 1.1 (vector (array
451 ram 1.6 sequence) (string bit-vector) (array sequence t)
452 ram 1.8 #())
453 ram 1.6 (string (vector) () (vector array sequence t)
454 ram 1.8 "")
455 ram 1.6 (bit-vector (vector) () (vector array sequence t)
456 ram 1.8 #*1)
457 ram 1.6 (character (t) () (t)
458 ram 1.8 #\c)
459 wlott 1.1
460 ram 1.6 (symbol (t) (null) (t)
461 ram 1.8 symbol)
462     (null (symbol
463     list) () (symbol list sequence t)
464     nil)))
465 wlott 1.1
466 pw 1.11 #+cmu17
467     (labels ((direct-supers (class)
468     (if (typep class 'lisp:built-in-class)
469     (kernel:built-in-class-direct-superclasses class)
470     (let ((inherits (kernel:layout-inherits
471     (kernel:class-layout class))))
472     (list (svref inherits (1- (length inherits)))))))
473     (direct-subs (class)
474     (ext:collect ((res))
475     (let ((subs (kernel:class-subclasses class)))
476     (when subs
477     (ext:do-hash (sub v subs)
478     (declare (ignore v))
479     (when (member class (direct-supers sub))
480     (res sub)))))
481     (res))))
482     (ext:collect ((res))
483     (dolist (bic kernel::built-in-classes)
484     (let* ((name (car bic))
485     (class (lisp:find-class name)))
486     (unless (member name '(t kernel:instance kernel:funcallable-instance
487 dtc 1.12 function stream))
488 pw 1.11 (res `(,name
489     ,(mapcar #'lisp:class-name (direct-supers class))
490     ,(mapcar #'lisp:class-name (direct-subs class))
491     ,(map 'list #'(lambda (x)
492     (lisp:class-name (kernel:layout-class x)))
493     (reverse
494     (kernel:layout-inherits
495     (kernel:class-layout class))))
496     ,(let ((found (assoc name *built-in-classes*)))
497     (if found (fifth found) 42)))))))
498     (setq *built-in-classes* (res))))
499    
500 wlott 1.1
501     ;;;
502     ;;; The classes that define the kernel of the metabraid.
503     ;;;
504     (defclass t () ()
505     (:metaclass built-in-class))
506    
507 pw 1.11 #+cmu17
508     (progn
509     (defclass kernel:instance (t) ()
510     (:metaclass built-in-class))
511    
512     (defclass function (t) ()
513     (:metaclass built-in-class))
514    
515     (defclass kernel:funcallable-instance (function) ()
516 dtc 1.12 (:metaclass built-in-class))
517    
518     (defclass stream (t) ()
519 pw 1.11 (:metaclass built-in-class)))
520    
521 dtc 1.14 (defclass slot-object (t) ()
522 ram 1.6 (:metaclass slot-class))
523 wlott 1.1
524 dtc 1.14 (defclass structure-object (slot-object #+cmu17 kernel:instance) ()
525 ram 1.6 (:metaclass structure-class))
526    
527 pw 1.15 (defstruct (dead-beef-structure-object
528 ram 1.6 (:constructor |STRUCTURE-OBJECT class constructor|)))
529    
530 pw 1.11
531 dtc 1.14 (defclass std-object (slot-object) ()
532     (:metaclass std-class))
533    
534     (defclass standard-object (std-object #+cmu17 kernel:instance) ())
535 ram 1.6
536 dtc 1.14 (defclass funcallable-standard-object (std-object
537     #+cmu17 kernel:funcallable-instance)
538     ()
539     (:metaclass funcallable-standard-class))
540 wlott 1.1
541 dtc 1.14 (defclass specializer (standard-object)
542 ram 1.6 ((type
543     :initform nil
544     :reader specializer-type)))
545 wlott 1.1
546 dtc 1.14 (defclass definition-source-mixin (std-object)
547 wlott 1.1 ((source
548     :initform (load-truename)
549     :reader definition-source
550 dtc 1.14 :initarg :definition-source))
551     (:metaclass std-class))
552 wlott 1.1
553 dtc 1.14 (defclass plist-mixin (std-object)
554 wlott 1.1 ((plist
555 ram 1.6 :initform ()
556 dtc 1.14 :accessor object-plist))
557     (:metaclass std-class))
558 wlott 1.1
559 ram 1.8 (defclass documentation-mixin (plist-mixin)
560 dtc 1.14 ()
561     (:metaclass std-class))
562 wlott 1.1
563     (defclass dependent-update-mixin (plist-mixin)
564 dtc 1.14 ()
565     (:metaclass std-class))
566 wlott 1.1
567     ;;;
568     ;;; The class CLASS is a specified basic class. It is the common superclass
569 ram 1.8 ;;; of any kind of class. That is any class that can be a metaclass must
570     ;;; have the class CLASS in its class precedence list.
571 wlott 1.1 ;;;
572 ram 1.8 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
573     specializer)
574     ((name
575     :initform nil
576     :initarg :name
577     :accessor class-name)
578     (class-eq-specializer
579 ram 1.6 :initform nil
580 ram 1.8 :reader class-eq-specializer)
581     (direct-superclasses
582     :initform ()
583     :reader class-direct-superclasses)
584 wlott 1.1 (direct-subclasses
585 ram 1.8 :initform ()
586 wlott 1.1 :reader class-direct-subclasses)
587 ram 1.8 (direct-methods
588     :initform (cons nil nil))
589     (predicate-name
590 ram 1.6 :initform nil
591 ram 1.8 :reader class-predicate-name)))
592 wlott 1.1
593     ;;;
594     ;;; The class PCL-CLASS is an implementation-specific common superclass of
595     ;;; all specified subclasses of the class CLASS.
596     ;;;
597     (defclass pcl-class (class)
598 ram 1.8 ((class-precedence-list
599     :reader class-precedence-list)
600 ram 1.6 (can-precede-list
601     :initform ()
602     :reader class-can-precede-list)
603     (incompatible-superclass-list
604     :initform ()
605     :accessor class-incompatible-superclass-list)
606 wlott 1.1 (wrapper
607 ram 1.6 :initform nil
608     :reader class-wrapper)
609 ram 1.8 (prototype
610     :initform nil
611     :reader class-prototype)))
612 wlott 1.1
613 ram 1.6 (defclass slot-class (pcl-class)
614 ram 1.8 ((direct-slots
615     :initform ()
616     :accessor class-direct-slots)
617     (slots
618     :initform ()
619     :accessor class-slots)
620     (initialize-info
621     :initform nil
622     :accessor class-initialize-info)))
623 ram 1.6
624 wlott 1.1 ;;;
625     ;;; The class STD-CLASS is an implementation-specific common superclass of
626     ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
627     ;;;
628 ram 1.6 (defclass std-class (slot-class)
629 ram 1.8 ())
630 wlott 1.1
631     (defclass standard-class (std-class)
632     ())
633    
634     (defclass funcallable-standard-class (std-class)
635     ())
636    
637     (defclass forward-referenced-class (pcl-class) ())
638    
639     (defclass built-in-class (pcl-class) ())
640    
641 ram 1.6 (defclass structure-class (slot-class)
642 ram 1.8 ((defstruct-form
643     :initform ()
644     :accessor class-defstruct-form)
645 ram 1.6 (defstruct-constructor
646     :initform nil
647 ram 1.8 :accessor class-defstruct-constructor)
648 ram 1.6 (from-defclass-p
649     :initform nil
650 ram 1.8 :initarg :from-defclass-p)))
651    
652 ram 1.6
653     (defclass specializer-with-object (specializer) ())
654    
655     (defclass exact-class-specializer (specializer) ())
656    
657     (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
658     ((object :initarg :class :reader specializer-class :reader specializer-object)))
659    
660 ram 1.8 (defclass class-prototype-specializer (specializer-with-object)
661     ((object :initarg :class :reader specializer-class :reader specializer-object)))
662    
663 ram 1.6 (defclass eql-specializer (exact-class-specializer specializer-with-object)
664     ((object :initarg :object :reader specializer-object
665     :reader eql-specializer-object)))
666    
667     (defvar *eql-specializer-table* (make-hash-table :test 'eql))
668    
669     (defun intern-eql-specializer (object)
670     (or (gethash object *eql-specializer-table*)
671     (setf (gethash object *eql-specializer-table*)
672     (make-instance 'eql-specializer :object object))))
673    
674 wlott 1.1
675     ;;;
676     ;;; Slot definitions.
677     ;;;
678 dtc 1.14 (defclass slot-definition (standard-object)
679 wlott 1.1 ((name
680     :initform nil
681 ram 1.6 :initarg :name
682     :accessor slot-definition-name)
683 wlott 1.1 (initform
684 ram 1.6 :initform nil
685     :initarg :initform
686     :accessor slot-definition-initform)
687 wlott 1.1 (initfunction
688 ram 1.6 :initform nil
689     :initarg :initfunction
690     :accessor slot-definition-initfunction)
691 wlott 1.1 (readers
692     :initform nil
693 ram 1.6 :initarg :readers
694     :accessor slot-definition-readers)
695 wlott 1.1 (writers
696     :initform nil
697 ram 1.6 :initarg :writers
698     :accessor slot-definition-writers)
699 wlott 1.1 (initargs
700     :initform nil
701 ram 1.6 :initarg :initargs
702     :accessor slot-definition-initargs)
703 wlott 1.1 (type
704 ram 1.6 :initform t
705     :initarg :type
706     :accessor slot-definition-type)
707 ram 1.8 (documentation
708     :initform ""
709     :initarg :documentation)
710 ram 1.4 (class
711     :initform nil
712 ram 1.6 :initarg :class
713 ram 1.8 :accessor slot-definition-class)))
714 wlott 1.1
715 ram 1.6 (defclass standard-slot-definition (slot-definition)
716     ((allocation
717     :initform :instance
718     :initarg :allocation
719     :accessor slot-definition-allocation)))
720    
721     (defclass structure-slot-definition (slot-definition)
722     ((defstruct-accessor-symbol
723     :initform nil
724     :initarg :defstruct-accessor-symbol
725     :accessor slot-definition-defstruct-accessor-symbol)
726     (internal-reader-function
727     :initform nil
728     :initarg :internal-reader-function
729     :accessor slot-definition-internal-reader-function)
730     (internal-writer-function
731     :initform nil
732     :initarg :internal-writer-function
733     :accessor slot-definition-internal-writer-function)))
734    
735     (defclass direct-slot-definition (slot-definition)
736     ())
737    
738     (defclass effective-slot-definition (slot-definition)
739 ram 1.8 ((reader-function ; #'(lambda (object) ...)
740 ram 1.6 :accessor slot-definition-reader-function)
741     (writer-function ; #'(lambda (new-value object) ...)
742     :accessor slot-definition-writer-function)
743     (boundp-function ; #'(lambda (object) ...)
744     :accessor slot-definition-boundp-function)
745     (accessor-flags
746 ram 1.8 :initform 0)))
747 ram 1.6
748 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
749     direct-slot-definition)
750 ram 1.6 ())
751 wlott 1.1
752     (defclass standard-effective-slot-definition (standard-slot-definition
753     effective-slot-definition)
754 ram 1.8 ((location ; nil, a fixnum, a cons: (slot-name . value)
755     :initform nil
756     :accessor slot-definition-location)))
757 wlott 1.1
758 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
759     direct-slot-definition)
760     ())
761 wlott 1.1
762 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
763     effective-slot-definition)
764     ())
765 wlott 1.1
766 dtc 1.14 (defclass method (standard-object) ())
767 ram 1.7
768 ram 1.8 (defclass standard-method (definition-source-mixin plist-mixin method)
769     ((generic-function
770     :initform nil
771     :accessor method-generic-function)
772     ; (qualifiers
773     ; :initform ()
774     ; :initarg :qualifiers
775     ; :reader method-qualifiers)
776     (specializers
777     :initform ()
778     :initarg :specializers
779     :reader method-specializers)
780     (lambda-list
781     :initform ()
782     :initarg :lambda-list
783     :reader method-lambda-list)
784     (function
785     :initform nil
786     :initarg :function) ;no writer
787     (fast-function
788     :initform nil
789     :initarg :fast-function ;no writer
790     :reader method-fast-function)
791     ; (documentation
792     ; :initform nil
793     ; :initarg :documentation
794     ; :reader method-documentation)
795     ))
796 ram 1.7
797 ram 1.8 (defclass standard-accessor-method (standard-method)
798     ((slot-name :initform nil
799     :initarg :slot-name
800     :reader accessor-method-slot-name)
801     (slot-definition :initform nil
802     :initarg :slot-definition
803     :reader accessor-method-slot-definition)))
804 ram 1.7
805 ram 1.8 (defclass standard-reader-method (standard-accessor-method) ())
806 ram 1.7
807 ram 1.8 (defclass standard-writer-method (standard-accessor-method) ())
808 ram 1.7
809 ram 1.8 (defclass standard-boundp-method (standard-accessor-method) ())
810 ram 1.7
811 ram 1.8 (defclass generic-function (dependent-update-mixin
812     definition-source-mixin
813     documentation-mixin
814 dtc 1.14 funcallable-standard-object)
815 ram 1.8 ()
816     (:metaclass funcallable-standard-class))
817    
818     (defclass standard-generic-function (generic-function)
819     ((name
820     :initform nil
821     :initarg :name
822     :accessor generic-function-name)
823     (methods
824     :initform ()
825     :accessor generic-function-methods)
826     (method-class
827     :initarg :method-class
828     :accessor generic-function-method-class)
829     (method-combination
830     :initarg :method-combination
831     :accessor generic-function-method-combination)
832     (arg-info
833     :initform (make-arg-info)
834     :reader gf-arg-info)
835     (dfun-state
836     :initform ()
837     :accessor gf-dfun-state)
838     (pretty-arglist
839     :initform ()
840     :accessor gf-pretty-arglist)
841     )
842     (:metaclass funcallable-standard-class)
843     (:default-initargs :method-class *the-class-standard-method*
844     :method-combination *standard-method-combination*))
845 ram 1.7
846 dtc 1.14 (defclass method-combination (standard-object) ())
847 ram 1.7
848 ram 1.8 (defclass standard-method-combination
849     (definition-source-mixin method-combination)
850     ((type :reader method-combination-type
851     :initarg :type)
852     (documentation :reader method-combination-documentation
853     :initarg :documentation)
854     (options :reader method-combination-options
855     :initarg :options)))
856 ram 1.7
857 ram 1.6 (defparameter *early-class-predicates*
858     '((specializer specializerp)
859     (exact-class-specializer exact-class-specializer-p)
860     (class-eq-specializer class-eq-specializer-p)
861     (eql-specializer eql-specializer-p)
862     (class classp)
863 ram 1.8 (slot-class slot-class-p)
864 dtc 1.14 (std-class std-class-p)
865 ram 1.6 (standard-class standard-class-p)
866     (funcallable-standard-class funcallable-standard-class-p)
867     (structure-class structure-class-p)
868 ram 1.8 (forward-referenced-class forward-referenced-class-p)
869     (method method-p)
870     (standard-method standard-method-p)
871     (standard-accessor-method standard-accessor-method-p)
872     (standard-reader-method standard-reader-method-p)
873     (standard-writer-method standard-writer-method-p)
874     (standard-boundp-method standard-boundp-method-p)
875     (generic-function generic-function-p)
876     (standard-generic-function standard-generic-function-p)
877     (method-combination method-combination-p)))
878 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5