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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Sun May 11 11:30:35 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.39: +10 -0 lines
	More SLOT-VALUE etc. on conditions.

	* src/pcl/slots.lisp (slot-value-using-class)
	(setf slot-boundp-using-class) <condition-class>: New methods.

	* src/pcl/std-class.lisp (initialize-internal-slot-functions): Use
	slot-name->class-table.
	(shared-initialize): Call update-pv-table-cache-info.
	(compute-slots) <around condition-class>: New method.

	* src/pcl/slots-boot.lisp (ensure-accessor): Use
	slot-name->class-table.
	(get-optimized-std-accessor-method-function)
	(get-optimized-std-slot-value-using-class-method-function):
	Handle condition classes.

	* src/pcl/methods.lisp (*condition-slot-value-using-class-method*)
	(*condition-setf-slot-value-using-class-method*)
	(*condition-slot-boundp-using-class-method*): New vars.
	(condition-svuc-method, set-condition-svuc-method): New functions.
	(update-std-or-str-methods): Handle conditions.

	* src/pcl/generic-functions.lisp (condition-class-p): New gf.

	* src/pcl/dfun.lisp (make-accessor-table): Use
	slot-name->class-table.

	* src/pcl/defs.lisp (*the-condition-class*): New var.
	(slot-name->class-table): New function.
	(condition): New class.
	(*early-class-predicates*): Add condition-class-p.

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

  ViewVC Help
Powered by ViewVC 1.1.5