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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5