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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5