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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (hide annotations)
Fri Jun 6 14:00:05 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
Changes since 1.41: +1 -7 lines
	Problems with class precedence lists found by Paul Dietz.

	* src/pcl/defs.lisp (toplevel): Don't compute the cpl of built-in
	classes from the kernel's layout-inherits because that gives wrong
	results, for instance for null.
	(standard-method): Make method the first superclass.

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

  ViewVC Help
Powered by ViewVC 1.1.5