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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (hide annotations)
Wed Jun 11 19:17:25 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, double-double-init-sparc-2, double-double-base, snapshot-2007-09, snapshot-2007-08, ppc_gencgc_snap_2006-01-06, snapshot-2008-05, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, snapshot-2003-10, snapshot-2004-10, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, release-19c-base, mod-arith-base, sparc_gencgc_merge, snapshot-2004-12, snapshot-2004-11, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, prm-before-macosx-merge-tag, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, snapshot-2007-03, release-19a-base, sparc_gencgc, snapshot-2007-04, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, release-19d-pre2, release-19d-pre1, double-double-init-checkpoint-1, double-double-reader-base, snapshot-2005-03, release-19b-base, double-double-init-x86, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, snapshot-2005-10, snapshot-2005-12, snapshot-2005-01, unicode-utf16-string-support, release-19c-pre1, release-19e-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, sparc_gencgc_branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, lisp-executable, double-double-branch, unicode-utf16-branch, release-19e-branch, release-19a-branch, release-19c-branch
Changes since 1.42: +1 -4 lines
	Remove an unused slot from classes.

	* src/pcl/defs.lisp (slot-class): Remove unused slot
	initialize-info.

	* src/pcl/generic-functions.lisp (setf class-initialize-info)
	(class-initialize-info): Remove.

	* src/pcl/braid.lisp (bootstrap-initialize-class): Don't
	set the slot.
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 gerd 1.43 :accessor class-slots)))
505 ram 1.6
506 wlott 1.1 ;;;
507     ;;; The class STD-CLASS is an implementation-specific common superclass of
508     ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
509     ;;;
510 gerd 1.34 (defclass std-class (slot-class) ())
511 wlott 1.1
512 gerd 1.34 (defclass standard-class (std-class) ())
513 wlott 1.1
514 gerd 1.34 (defclass funcallable-standard-class (std-class) ())
515 wlott 1.1
516     (defclass forward-referenced-class (pcl-class) ())
517    
518     (defclass built-in-class (pcl-class) ())
519    
520 ram 1.6 (defclass structure-class (slot-class)
521 gerd 1.34 ((defstruct-form
522     :initform ()
523     :accessor class-defstruct-form)
524     (defstruct-constructor
525     :initform nil
526     :accessor class-defstruct-constructor)
527     (from-defclass-p
528     :initform nil
529     :initarg :from-defclass-p)))
530 ram 1.8
531 gerd 1.40 (defclass condition (slot-object kernel:instance) ()
532     (:metaclass condition-class))
533    
534 gerd 1.39 (defclass condition-class (slot-class) ())
535 ram 1.6
536     (defclass specializer-with-object (specializer) ())
537    
538     (defclass exact-class-specializer (specializer) ())
539    
540 gerd 1.34 ;;;
541     ;;; Extension specializing on the exact specified class. You must set
542     ;;; pcl::*allow-experimental-specializers-p* to use this extension.
543     ;;;
544     ;;; (defclass foo () ())
545     ;;; (defclass bar (foo) ())
546     ;;;
547     ;;; (setq pcl::*allow-experimental-specializers-p* t)
548     ;;; (defmethod m (x) nil)
549     ;;; (defmethod m ((x (pcl::class-eq 'foo))) t)
550     ;;;
551     ;;; (m (make-instance 'foo)) => t
552     ;;; (m (make-instance 'bar)) => nil
553     ;;;
554    
555     (defclass class-eq-specializer (exact-class-specializer
556     specializer-with-object)
557     ((object
558     :initarg :class
559     :reader specializer-class
560     :reader specializer-object)))
561 ram 1.8
562 ram 1.6 (defclass eql-specializer (exact-class-specializer specializer-with-object)
563 gerd 1.34 ((object
564     :initarg :object
565     :reader specializer-object
566     :reader eql-specializer-object)))
567 ram 1.6
568     (defvar *eql-specializer-table* (make-hash-table :test 'eql))
569    
570 gerd 1.34 ;;;
571     ;;; When compiled with an intact PCL, the MAKE-INSTANCE in the function
572     ;;; below will generate an optimized constructor, and a LOAD-TIME-VALUE
573     ;;; creating it. That means CTOR must be initialized before this file
574     ;;; is.
575     ;;;
576 ram 1.6 (defun intern-eql-specializer (object)
577     (or (gethash object *eql-specializer-table*)
578     (setf (gethash object *eql-specializer-table*)
579     (make-instance 'eql-specializer :object object))))
580    
581 wlott 1.1
582     ;;;
583     ;;; Slot definitions.
584     ;;;
585 gerd 1.35 (defclass slot-definition (metaobject)
586 gerd 1.34 ((name
587     :initform nil
588     :initarg :name
589     :accessor slot-definition-name)
590     (initform
591     :initform nil
592     :initarg :initform
593     :accessor slot-definition-initform)
594     (initfunction
595     :initform nil
596     :initarg :initfunction
597     :accessor slot-definition-initfunction)
598     (readers
599     :initform nil
600     :initarg :readers
601     :accessor slot-definition-readers)
602     (writers
603     :initform nil
604     :initarg :writers
605     :accessor slot-definition-writers)
606     (initargs
607     :initform nil
608     :initarg :initargs
609     :accessor slot-definition-initargs)
610     (type
611     :initform t
612     :initarg :type
613     :accessor slot-definition-type)
614     (documentation
615     :initform ""
616     :initarg :documentation)
617     (class
618     :initform nil
619     :initarg :class
620     :accessor slot-definition-class)))
621 wlott 1.1
622 ram 1.6 (defclass standard-slot-definition (slot-definition)
623     ((allocation
624     :initform :instance
625     :initarg :allocation
626 pmai 1.30 :accessor slot-definition-allocation)
627     (allocation-class
628 gerd 1.34 :documentation "For class slots, the class defininig the slot.
629     For inherited class slots, this is the superclass from which the slot
630     was inherited."
631 pmai 1.30 :initform nil
632     :initarg :allocation-class
633     :accessor slot-definition-allocation-class)))
634 ram 1.6
635     (defclass structure-slot-definition (slot-definition)
636     ((defstruct-accessor-symbol
637     :initform nil
638     :initarg :defstruct-accessor-symbol
639     :accessor slot-definition-defstruct-accessor-symbol)
640     (internal-reader-function
641     :initform nil
642     :initarg :internal-reader-function
643     :accessor slot-definition-internal-reader-function)
644     (internal-writer-function
645     :initform nil
646     :initarg :internal-writer-function
647     :accessor slot-definition-internal-writer-function)))
648    
649 gerd 1.39 (defclass condition-slot-definition (standard-slot-definition)
650     ())
651    
652 ram 1.6 (defclass direct-slot-definition (slot-definition)
653     ())
654    
655     (defclass effective-slot-definition (slot-definition)
656 pmai 1.23 ((reader-function ; (lambda (object) ...)
657 ram 1.6 :accessor slot-definition-reader-function)
658 pmai 1.23 (writer-function ; (lambda (new-value object) ...)
659 ram 1.6 :accessor slot-definition-writer-function)
660 pmai 1.23 (boundp-function ; (lambda (object) ...)
661 ram 1.6 :accessor slot-definition-boundp-function)
662     (accessor-flags
663 ram 1.8 :initform 0)))
664 ram 1.6
665 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
666     direct-slot-definition)
667 ram 1.6 ())
668 wlott 1.1
669     (defclass standard-effective-slot-definition (standard-slot-definition
670     effective-slot-definition)
671 gerd 1.39 ((location
672 ram 1.8 :initform nil
673     :accessor slot-definition-location)))
674 wlott 1.1
675 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
676     direct-slot-definition)
677     ())
678 wlott 1.1
679 gerd 1.39 (defclass condition-direct-slot-definition (condition-slot-definition
680     direct-slot-definition)
681     ())
682    
683 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
684 gerd 1.39 effective-slot-definition)
685     ())
686    
687     (defclass condition-effective-slot-definition (condition-slot-definition
688 ram 1.6 effective-slot-definition)
689     ())
690 wlott 1.1
691 gerd 1.35 (defclass method (metaobject) ())
692 ram 1.7
693 gerd 1.42 (defclass standard-method (method definition-source-mixin documentation-mixin)
694 gerd 1.34 ((generic-function
695     :initform nil
696     :accessor method-generic-function)
697     (specializers
698     :initform ()
699     :initarg :specializers
700     :reader method-specializers)
701     (lambda-list
702     :initform ()
703     :initarg :lambda-list
704     :reader method-lambda-list)
705     (function
706     :initform nil
707     :initarg :function)
708     (fast-function
709     :initform nil
710     :initarg :fast-function
711     :reader method-fast-function)))
712 ram 1.7
713 ram 1.8 (defclass standard-accessor-method (standard-method)
714 gerd 1.34 ((slot-name
715     :initform nil
716     :initarg :slot-name
717     :reader accessor-method-slot-name)
718     (slot-definition
719     :initform nil
720     :initarg :slot-definition
721     :reader accessor-method-slot-definition)))
722 ram 1.7
723 ram 1.8 (defclass standard-reader-method (standard-accessor-method) ())
724 ram 1.7
725 ram 1.8 (defclass standard-writer-method (standard-accessor-method) ())
726 ram 1.7
727 ram 1.8 (defclass standard-boundp-method (standard-accessor-method) ())
728 ram 1.7
729 ram 1.8 (defclass generic-function (dependent-update-mixin
730     definition-source-mixin
731     documentation-mixin
732 gerd 1.35 metaobject
733 dtc 1.14 funcallable-standard-object)
734 gerd 1.34 ()
735 ram 1.8 (:metaclass funcallable-standard-class))
736    
737     (defclass standard-generic-function (generic-function)
738 gerd 1.34 ((name
739     :initform nil
740     :initarg :name
741     :accessor generic-function-name)
742     (methods
743     :initform ()
744     :accessor generic-function-methods)
745     (method-class
746     :initarg :method-class
747     :accessor generic-function-method-class)
748     (method-combination
749     :initarg :method-combination
750     :accessor generic-function-method-combination)
751     (arg-info
752     :initform (make-arg-info)
753     :reader gf-arg-info)
754     (dfun-state
755     :initform ()
756     :accessor gf-dfun-state)
757     (pretty-arglist
758     :initform ()
759     :accessor gf-pretty-arglist)
760     (declarations
761     :initform ()
762     :initarg :declarations
763     :reader generic-function-declarations))
764 ram 1.8 (:metaclass funcallable-standard-class)
765     (:default-initargs :method-class *the-class-standard-method*
766 gerd 1.34 :method-combination *standard-method-combination*))
767 ram 1.7
768 gerd 1.35 (defclass method-combination (metaobject) ())
769 ram 1.7
770 ram 1.8 (defclass standard-method-combination
771 gerd 1.34 (definition-source-mixin method-combination)
772     ((type
773     :reader method-combination-type
774     :initarg :type)
775     (documentation
776     :reader method-combination-documentation
777     :initarg :documentation)
778     (options
779     :reader method-combination-options
780     :initarg :options)))
781 ram 1.7
782 pmai 1.31 (defclass long-method-combination (standard-method-combination)
783     ((function
784     :initarg :function
785     :reader long-method-combination-function)
786 gerd 1.34 (args-lambda-list
787     :initarg :args-lambda-list
788     :reader long-method-combination-args-lambda-list)))
789    
790     (defclass seal (standard-object)
791     ((quality
792     :initarg :quality
793     :reader seal-quality)))
794 pmai 1.31
795 ram 1.6 (defparameter *early-class-predicates*
796     '((specializer specializerp)
797     (exact-class-specializer exact-class-specializer-p)
798     (class-eq-specializer class-eq-specializer-p)
799     (eql-specializer eql-specializer-p)
800     (class classp)
801 ram 1.8 (slot-class slot-class-p)
802 dtc 1.14 (std-class std-class-p)
803 ram 1.6 (standard-class standard-class-p)
804     (funcallable-standard-class funcallable-standard-class-p)
805     (structure-class structure-class-p)
806 gerd 1.40 (condition-class condition-class-p)
807 ram 1.8 (forward-referenced-class forward-referenced-class-p)
808     (method method-p)
809     (standard-method standard-method-p)
810     (standard-accessor-method standard-accessor-method-p)
811     (standard-reader-method standard-reader-method-p)
812     (standard-writer-method standard-writer-method-p)
813     (standard-boundp-method standard-boundp-method-p)
814     (generic-function generic-function-p)
815     (standard-generic-function standard-generic-function-p)
816 pmai 1.31 (method-combination method-combination-p)
817     (long-method-combination long-method-combination-p)))
818 gerd 1.34
819 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5