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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (hide annotations)
Sat May 10 19:09:02 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.38: +13 -2 lines
	SLOT-EXISTS-P is supposed to work on conditions.  Detected
	by Paul Dietz.

	* src/pcl/std-class.lisp (class-direct-slots, class-slots)
	<condition-class>: Remove methods.
	(shared-initialize) <condition-class>: Initialize direct
	and effective slots.
	(direct-slot-definition-class, effective-slot-definition-class)
	(finalize-inheritance, shared-initialize) <condition-class>:
	New methods.

	* src/pcl/braid.lisp (ensure-non-standard-class): Pass slot
	initargs to ensure-class for condition classes.

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

  ViewVC Help
Powered by ViewVC 1.1.5