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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33.2.5 - (hide annotations)
Thu Mar 20 23:41:00 2003 UTC (11 years, 1 month ago) by gerd
Branch: cold-pcl
Changes since 1.33.2.4: +2 -1 lines
* std-class.lisp (inform-type-system-about-class)
(shared-initialize :after): New methods for condition-class.

* macros.lisp (find-class-from-cell): Test both structure-type-p
and condition-type-p.  Use ensure-non-standard-class.

* low.lisp (structure-type-p): Return false for conditions.
(condition-type-p): New function.

* env.lisp (coerce-to-pcl-class, make-instance, change-class)
(frob): Remove methods specializing on kernel::class.

* defs.lisp (specializer-from-type): Use
ensure-non-standard-class.
(condition-class): New metaclass.

* cmucl-documentation.lisp (setf documentation): Test
both structure-type-p and condition-type-p.

* cache.lisp (wrapper-class*): Call ensure-non-standard-class.
(raise-metatype): Handle condition-class.

* braid.lisp (find-structure-class): Variable removed.
(bootstrap-initialize-class): Add supplied-p parameter for the
prototype because class null has a nil prototype.
(ensure-non-standard-class): Renamed from find-structure-class.
Handle conditions.
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.33.2.1 #-(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.33.2.1 (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.33.2.1 "~@<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.33.2.1 ;;;
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.33.2.2 ;;; 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.33.2.2
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.33.2.2
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-std-object*
92     *the-class-standard-object*
93     *the-class-funcallable-standard-object*
94     *the-class-class*
95     *the-class-generic-function*
96     *the-class-built-in-class*
97     *the-class-slot-class*
98     *the-class-structure-class*
99     *the-class-std-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.33.2.4 ((and (null args) (typep type 'kernel::class))
143     (or (kernel:%class-pcl-class type)
144 gerd 1.33.2.5 (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.33.2.1 (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.33.2.1 (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.33.2.1 (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.33.2.4 (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.33.2.1 (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.33.2.1 (let ((symbol (symbolicate *the-pcl-package*
271 gerd 1.33.2.3 '*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.33.2.1 (let ((symbol (symbolicate *the-pcl-package*
278 gerd 1.33.2.3 '*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     (defvar *standard-method-combination*)
291    
292    
293    
294 ram 1.6 (defun make-class-predicate-name (name)
295 gerd 1.33.2.1 `(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.33.2.4 (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.33.2.4 (kernel:%class-layout class))))
354 pw 1.11 (list (svref inherits (1- (length inherits)))))))
355     (direct-subs (class)
356     (ext:collect ((res))
357 gerd 1.33.2.4 (let ((subs (kernel:%class-subclasses class)))
358 pw 1.11 (when subs
359     (ext:do-hash (sub v subs)
360     (declare (ignore v))
361     (when (member class (direct-supers sub))
362     (res sub)))))
363     (res))))
364     (ext:collect ((res))
365     (dolist (bic kernel::built-in-classes)
366     (let* ((name (car bic))
367 gerd 1.33.2.4 (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.33.2.4 ,(mapcar #'kernel:%class-name (direct-supers class))
372     ,(mapcar #'kernel:%class-name (direct-subs class))
373 pmai 1.23 ,(map 'list (lambda (x)
374 gerd 1.33.2.4 (kernel:%class-name (kernel:layout-class x)))
375 pw 1.11 (reverse
376     (kernel:layout-inherits
377 gerd 1.33.2.4 (kernel:%class-layout class))))
378 pw 1.11 ,(let ((found (assoc name *built-in-classes*)))
379     (if found (fifth found) 42)))))))
380     (setq *built-in-classes* (res))))
381    
382 wlott 1.1
383     ;;;
384     ;;; The classes that define the kernel of the metabraid.
385     ;;;
386     (defclass t () ()
387     (:metaclass built-in-class))
388    
389 pw 1.17 (defclass kernel:instance (t) ()
390     (:metaclass built-in-class))
391 pw 1.11
392 pw 1.17 (defclass function (t) ()
393     (:metaclass built-in-class))
394 dtc 1.12
395 pw 1.17 (defclass kernel:funcallable-instance (function) ()
396     (:metaclass built-in-class))
397    
398 dtc 1.19 (defclass stream (kernel:instance) ()
399 pw 1.17 (:metaclass built-in-class))
400 pw 1.11
401 dtc 1.14 (defclass slot-object (t) ()
402 ram 1.6 (:metaclass slot-class))
403 wlott 1.1
404 gerd 1.33.2.1 ;;;
405     ;;; In a host Lisp with intact PCL, the DEFCLASS below would normally
406     ;;; generate a DEFSTRUCT with :INCLUDE SLOT-OBJECT. SLOT-OBJECT is
407     ;;; not a structure, so this would give an error. Likewise,
408     ;;; KERNEL:INSTANCE is a BUILT-IN-CLASS, not a structure class, so
409     ;;; this would give an error, too.
410     ;;;
411     ;;; When PCL is bootstrapped normally, *BOOT-STATE* is not COMPLETE at
412     ;;; this point, which means that a DEFSTRUCT is not done, because
413     ;;; EXPAND-DEFCLASS looks at the boot state.
414     ;;;
415     ;;; I've modified EXPAND-DEFCLASS accordingly to not do a DEFSTRUCT
416     ;;; when a loadable or bootable PCL is built.
417     ;;;
418 pw 1.17 (defclass structure-object (slot-object kernel:instance) ()
419 ram 1.6 (:metaclass structure-class))
420    
421 pw 1.15 (defstruct (dead-beef-structure-object
422 ram 1.6 (:constructor |STRUCTURE-OBJECT class constructor|)))
423    
424 pw 1.11
425 dtc 1.14 (defclass std-object (slot-object) ()
426     (:metaclass std-class))
427    
428 pw 1.17 (defclass standard-object (std-object kernel:instance) ())
429 ram 1.6
430 gerd 1.33.2.1 (defclass funcallable-standard-object (std-object
431     kernel:funcallable-instance)
432     ()
433 dtc 1.14 (:metaclass funcallable-standard-class))
434 wlott 1.1
435 dtc 1.14 (defclass specializer (standard-object)
436 gerd 1.33.2.1 ((type
437     :initform nil
438     :reader specializer-type)))
439 wlott 1.1
440 dtc 1.14 (defclass definition-source-mixin (std-object)
441 gerd 1.33.2.1 ((source
442     :initform *load-pathname*
443     :reader definition-source
444     :initarg :definition-source))
445 dtc 1.14 (:metaclass std-class))
446 wlott 1.1
447 dtc 1.14 (defclass plist-mixin (std-object)
448 gerd 1.33.2.1 ((plist
449     :initform ()
450     :accessor object-plist))
451 dtc 1.14 (:metaclass std-class))
452 wlott 1.1
453 ram 1.8 (defclass documentation-mixin (plist-mixin)
454 gerd 1.33.2.1 ()
455 dtc 1.14 (:metaclass std-class))
456 wlott 1.1
457     (defclass dependent-update-mixin (plist-mixin)
458 gerd 1.33.2.1 ()
459 dtc 1.14 (:metaclass std-class))
460 wlott 1.1
461     ;;;
462     ;;; The class CLASS is a specified basic class. It is the common superclass
463 ram 1.8 ;;; of any kind of class. That is any class that can be a metaclass must
464     ;;; have the class CLASS in its class precedence list.
465 wlott 1.1 ;;;
466 gerd 1.33.2.1 (defclass class (documentation-mixin dependent-update-mixin
467     definition-source-mixin
468     specializer)
469     ((name
470     :initform nil
471     :initarg :name
472     :accessor class-name)
473     (class-eq-specializer
474     :initform nil
475     :reader class-eq-specializer)
476     (direct-superclasses
477     :initform ()
478     :reader class-direct-superclasses)
479     (direct-subclasses
480     :initform ()
481     :reader class-direct-subclasses)
482     (direct-methods
483     :initform (cons nil nil))
484     (predicate-name
485     :initform nil
486     :reader class-predicate-name)))
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.33.2.1 ((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.33.2.1 ((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.33.2.1 (defclass std-class (slot-class) ())
524 wlott 1.1
525 gerd 1.33.2.1 (defclass standard-class (std-class) ())
526 wlott 1.1
527 gerd 1.33.2.1 (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.33.2.1 ((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.33.2.5 (defclass condition-class (pcl-class) ())
545 ram 1.6
546     (defclass specializer-with-object (specializer) ())
547    
548     (defclass exact-class-specializer (specializer) ())
549    
550 gerd 1.33.2.1 ;;;
551     ;;; Extension specializing on the exact specified class. You must set
552     ;;; pcl::*allow-experimental-specializers-p* to use this extension.
553     ;;;
554     ;;; (defclass foo () ())
555     ;;; (defclass bar (foo) ())
556     ;;;
557     ;;; (setq pcl::*allow-experimental-specializers-p* t)
558     ;;; (defmethod m (x) nil)
559     ;;; (defmethod m ((x (pcl::class-eq 'foo))) t)
560     ;;;
561     ;;; (m (make-instance 'foo)) => t
562     ;;; (m (make-instance 'bar)) => nil
563     ;;;
564    
565     (defclass class-eq-specializer (exact-class-specializer
566     specializer-with-object)
567     ((object
568     :initarg :class
569     :reader specializer-class
570     :reader specializer-object)))
571 ram 1.8
572 ram 1.6 (defclass eql-specializer (exact-class-specializer specializer-with-object)
573 gerd 1.33.2.1 ((object
574     :initarg :object
575     :reader specializer-object
576     :reader eql-specializer-object)))
577 ram 1.6
578     (defvar *eql-specializer-table* (make-hash-table :test 'eql))
579    
580 gerd 1.33.2.1 ;;;
581     ;;; When compiled with an intact PCL, the MAKE-INSTANCE in the function
582     ;;; below will generate an optimized constructor, and a LOAD-TIME-VALUE
583     ;;; creating it. That means CTOR must be initialized before this file
584     ;;; is.
585     ;;;
586 ram 1.6 (defun intern-eql-specializer (object)
587     (or (gethash object *eql-specializer-table*)
588     (setf (gethash object *eql-specializer-table*)
589     (make-instance 'eql-specializer :object object))))
590    
591 wlott 1.1
592     ;;;
593     ;;; Slot definitions.
594     ;;;
595 dtc 1.14 (defclass slot-definition (standard-object)
596 gerd 1.33.2.1 ((name
597     :initform nil
598     :initarg :name
599     :accessor slot-definition-name)
600     (initform
601     :initform nil
602     :initarg :initform
603     :accessor slot-definition-initform)
604     (initfunction
605     :initform nil
606     :initarg :initfunction
607     :accessor slot-definition-initfunction)
608     (readers
609     :initform nil
610     :initarg :readers
611     :accessor slot-definition-readers)
612     (writers
613     :initform nil
614     :initarg :writers
615     :accessor slot-definition-writers)
616     (initargs
617     :initform nil
618     :initarg :initargs
619     :accessor slot-definition-initargs)
620     (type
621     :initform t
622     :initarg :type
623     :accessor slot-definition-type)
624     (documentation
625     :initform ""
626     :initarg :documentation)
627     (class
628     :initform nil
629     :initarg :class
630     :accessor slot-definition-class)))
631 wlott 1.1
632 ram 1.6 (defclass standard-slot-definition (slot-definition)
633     ((allocation
634     :initform :instance
635     :initarg :allocation
636 pmai 1.30 :accessor slot-definition-allocation)
637     (allocation-class
638 gerd 1.33.2.1 :documentation "For class slots, the class defininig the slot.
639     For inherited class slots, this is the superclass from which the slot
640     was inherited."
641 pmai 1.30 :initform nil
642     :initarg :allocation-class
643     :accessor slot-definition-allocation-class)))
644 ram 1.6
645     (defclass structure-slot-definition (slot-definition)
646     ((defstruct-accessor-symbol
647     :initform nil
648     :initarg :defstruct-accessor-symbol
649     :accessor slot-definition-defstruct-accessor-symbol)
650     (internal-reader-function
651     :initform nil
652     :initarg :internal-reader-function
653     :accessor slot-definition-internal-reader-function)
654     (internal-writer-function
655     :initform nil
656     :initarg :internal-writer-function
657     :accessor slot-definition-internal-writer-function)))
658    
659     (defclass direct-slot-definition (slot-definition)
660     ())
661    
662     (defclass effective-slot-definition (slot-definition)
663 pmai 1.23 ((reader-function ; (lambda (object) ...)
664 ram 1.6 :accessor slot-definition-reader-function)
665 pmai 1.23 (writer-function ; (lambda (new-value object) ...)
666 ram 1.6 :accessor slot-definition-writer-function)
667 pmai 1.23 (boundp-function ; (lambda (object) ...)
668 ram 1.6 :accessor slot-definition-boundp-function)
669     (accessor-flags
670 ram 1.8 :initform 0)))
671 ram 1.6
672 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
673     direct-slot-definition)
674 ram 1.6 ())
675 wlott 1.1
676     (defclass standard-effective-slot-definition (standard-slot-definition
677     effective-slot-definition)
678 ram 1.8 ((location ; nil, a fixnum, a cons: (slot-name . value)
679     :initform nil
680     :accessor slot-definition-location)))
681 wlott 1.1
682 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
683     direct-slot-definition)
684     ())
685 wlott 1.1
686 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
687     effective-slot-definition)
688     ())
689 wlott 1.1
690 dtc 1.14 (defclass method (standard-object) ())
691 ram 1.7
692 gerd 1.33.2.1 (defclass standard-method (definition-source-mixin documentation-mixin
693     method)
694     ((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.33.2.1 ((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 dtc 1.14 funcallable-standard-object)
733 gerd 1.33.2.1 ()
734 ram 1.8 (:metaclass funcallable-standard-class))
735    
736     (defclass standard-generic-function (generic-function)
737 gerd 1.33.2.1 ((name
738     :initform nil
739     :initarg :name
740     :accessor generic-function-name)
741     (methods
742     :initform ()
743     :accessor generic-function-methods)
744     (method-class
745     :initarg :method-class
746     :accessor generic-function-method-class)
747     (method-combination
748     :initarg :method-combination
749     :accessor generic-function-method-combination)
750     (arg-info
751     :initform (make-arg-info)
752     :reader gf-arg-info)
753     (dfun-state
754     :initform ()
755     :accessor gf-dfun-state)
756     (pretty-arglist
757     :initform ()
758     :accessor gf-pretty-arglist)
759     (declarations
760     :initform ()
761     :initarg :declarations
762     :reader generic-function-declarations))
763 ram 1.8 (:metaclass funcallable-standard-class)
764     (:default-initargs :method-class *the-class-standard-method*
765 gerd 1.33.2.1 :method-combination *standard-method-combination*))
766 ram 1.7
767 dtc 1.14 (defclass method-combination (standard-object) ())
768 ram 1.7
769 ram 1.8 (defclass standard-method-combination
770 gerd 1.33.2.1 (definition-source-mixin method-combination)
771     ((type
772     :reader method-combination-type
773     :initarg :type)
774     (documentation
775     :reader method-combination-documentation
776     :initarg :documentation)
777     (options
778     :reader method-combination-options
779     :initarg :options)))
780 ram 1.7
781 pmai 1.31 (defclass long-method-combination (standard-method-combination)
782     ((function
783     :initarg :function
784     :reader long-method-combination-function)
785 gerd 1.33.2.1 (args-lambda-list
786     :initarg :args-lambda-list
787     :reader long-method-combination-args-lambda-list)))
788    
789     (defclass seal (standard-object)
790     ((quality
791     :initarg :quality
792     :reader seal-quality)))
793 pmai 1.31
794 ram 1.6 (defparameter *early-class-predicates*
795     '((specializer specializerp)
796     (exact-class-specializer exact-class-specializer-p)
797     (class-eq-specializer class-eq-specializer-p)
798     (eql-specializer eql-specializer-p)
799     (class classp)
800 ram 1.8 (slot-class slot-class-p)
801 dtc 1.14 (std-class std-class-p)
802 ram 1.6 (standard-class standard-class-p)
803     (funcallable-standard-class funcallable-standard-class-p)
804     (structure-class structure-class-p)
805 ram 1.8 (forward-referenced-class forward-referenced-class-p)
806     (method method-p)
807     (standard-method standard-method-p)
808     (standard-accessor-method standard-accessor-method-p)
809     (standard-reader-method standard-reader-method-p)
810     (standard-writer-method standard-writer-method-p)
811     (standard-boundp-method standard-boundp-method-p)
812     (generic-function generic-function-p)
813     (standard-generic-function standard-generic-function-p)
814 pmai 1.31 (method-combination method-combination-p)
815     (long-method-combination long-method-combination-p)))
816 gerd 1.33.2.1
817 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5