/[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.3 - (hide annotations)
Sun Mar 16 13:10:16 2003 UTC (11 years, 1 month ago) by gerd
Branch: cold-pcl
Changes since 1.33.2.2: +2 -2 lines
* low.lisp (symbolicate): Use ext:symbolicate.

* braid.lisp (initial-classes-and-wrappers): Use symbols
instead of strings as arguments to symbolicate.
(bootstrap-meta-braid): Likewise.

* defs.lisp (get-built-in-class-symbol)
(get-built-in-wrapper-symbol): Likewise.
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 pw 1.11 ((and (null args) (typep type 'lisp:class))
143     (or (kernel:class-pcl-class type)
144     (find-structure-class (lisp: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     (null (lisp:find-class name nil)))
194     (setf (lisp:find-class name)
195     (lisp::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     (if (typep class 'lisp:built-in-class)
351     (kernel:built-in-class-direct-superclasses class)
352     (let ((inherits (kernel:layout-inherits
353     (kernel:class-layout class))))
354     (list (svref inherits (1- (length inherits)))))))
355     (direct-subs (class)
356     (ext:collect ((res))
357     (let ((subs (kernel:class-subclasses class)))
358     (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     (class (lisp:find-class name)))
368     (unless (member name '(t kernel:instance kernel:funcallable-instance
369 dtc 1.12 function stream))
370 pw 1.11 (res `(,name
371     ,(mapcar #'lisp:class-name (direct-supers class))
372     ,(mapcar #'lisp:class-name (direct-subs class))
373 pmai 1.23 ,(map 'list (lambda (x)
374     (lisp:class-name (kernel:layout-class x)))
375 pw 1.11 (reverse
376     (kernel:layout-inherits
377     (kernel:class-layout class))))
378     ,(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 ram 1.6
545     (defclass specializer-with-object (specializer) ())
546    
547     (defclass exact-class-specializer (specializer) ())
548    
549 gerd 1.33.2.1 ;;;
550     ;;; Extension specializing on the exact specified class. You must set
551     ;;; pcl::*allow-experimental-specializers-p* to use this extension.
552     ;;;
553     ;;; (defclass foo () ())
554     ;;; (defclass bar (foo) ())
555     ;;;
556     ;;; (setq pcl::*allow-experimental-specializers-p* t)
557     ;;; (defmethod m (x) nil)
558     ;;; (defmethod m ((x (pcl::class-eq 'foo))) t)
559     ;;;
560     ;;; (m (make-instance 'foo)) => t
561     ;;; (m (make-instance 'bar)) => nil
562     ;;;
563    
564     (defclass class-eq-specializer (exact-class-specializer
565     specializer-with-object)
566     ((object
567     :initarg :class
568     :reader specializer-class
569     :reader specializer-object)))
570 ram 1.8
571 ram 1.6 (defclass eql-specializer (exact-class-specializer specializer-with-object)
572 gerd 1.33.2.1 ((object
573     :initarg :object
574     :reader specializer-object
575     :reader eql-specializer-object)))
576 ram 1.6
577     (defvar *eql-specializer-table* (make-hash-table :test 'eql))
578    
579 gerd 1.33.2.1 ;;;
580     ;;; When compiled with an intact PCL, the MAKE-INSTANCE in the function
581     ;;; below will generate an optimized constructor, and a LOAD-TIME-VALUE
582     ;;; creating it. That means CTOR must be initialized before this file
583     ;;; is.
584     ;;;
585 ram 1.6 (defun intern-eql-specializer (object)
586     (or (gethash object *eql-specializer-table*)
587     (setf (gethash object *eql-specializer-table*)
588     (make-instance 'eql-specializer :object object))))
589    
590 wlott 1.1
591     ;;;
592     ;;; Slot definitions.
593     ;;;
594 dtc 1.14 (defclass slot-definition (standard-object)
595 gerd 1.33.2.1 ((name
596     :initform nil
597     :initarg :name
598     :accessor slot-definition-name)
599     (initform
600     :initform nil
601     :initarg :initform
602     :accessor slot-definition-initform)
603     (initfunction
604     :initform nil
605     :initarg :initfunction
606     :accessor slot-definition-initfunction)
607     (readers
608     :initform nil
609     :initarg :readers
610     :accessor slot-definition-readers)
611     (writers
612     :initform nil
613     :initarg :writers
614     :accessor slot-definition-writers)
615     (initargs
616     :initform nil
617     :initarg :initargs
618     :accessor slot-definition-initargs)
619     (type
620     :initform t
621     :initarg :type
622     :accessor slot-definition-type)
623     (documentation
624     :initform ""
625     :initarg :documentation)
626     (class
627     :initform nil
628     :initarg :class
629     :accessor slot-definition-class)))
630 wlott 1.1
631 ram 1.6 (defclass standard-slot-definition (slot-definition)
632     ((allocation
633     :initform :instance
634     :initarg :allocation
635 pmai 1.30 :accessor slot-definition-allocation)
636     (allocation-class
637 gerd 1.33.2.1 :documentation "For class slots, the class defininig the slot.
638     For inherited class slots, this is the superclass from which the slot
639     was inherited."
640 pmai 1.30 :initform nil
641     :initarg :allocation-class
642     :accessor slot-definition-allocation-class)))
643 ram 1.6
644     (defclass structure-slot-definition (slot-definition)
645     ((defstruct-accessor-symbol
646     :initform nil
647     :initarg :defstruct-accessor-symbol
648     :accessor slot-definition-defstruct-accessor-symbol)
649     (internal-reader-function
650     :initform nil
651     :initarg :internal-reader-function
652     :accessor slot-definition-internal-reader-function)
653     (internal-writer-function
654     :initform nil
655     :initarg :internal-writer-function
656     :accessor slot-definition-internal-writer-function)))
657    
658     (defclass direct-slot-definition (slot-definition)
659     ())
660    
661     (defclass effective-slot-definition (slot-definition)
662 pmai 1.23 ((reader-function ; (lambda (object) ...)
663 ram 1.6 :accessor slot-definition-reader-function)
664 pmai 1.23 (writer-function ; (lambda (new-value object) ...)
665 ram 1.6 :accessor slot-definition-writer-function)
666 pmai 1.23 (boundp-function ; (lambda (object) ...)
667 ram 1.6 :accessor slot-definition-boundp-function)
668     (accessor-flags
669 ram 1.8 :initform 0)))
670 ram 1.6
671 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
672     direct-slot-definition)
673 ram 1.6 ())
674 wlott 1.1
675     (defclass standard-effective-slot-definition (standard-slot-definition
676     effective-slot-definition)
677 ram 1.8 ((location ; nil, a fixnum, a cons: (slot-name . value)
678     :initform nil
679     :accessor slot-definition-location)))
680 wlott 1.1
681 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
682     direct-slot-definition)
683     ())
684 wlott 1.1
685 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
686     effective-slot-definition)
687     ())
688 wlott 1.1
689 dtc 1.14 (defclass method (standard-object) ())
690 ram 1.7
691 gerd 1.33.2.1 (defclass standard-method (definition-source-mixin documentation-mixin
692     method)
693     ((generic-function
694     :initform nil
695     :accessor method-generic-function)
696     (specializers
697     :initform ()
698     :initarg :specializers
699     :reader method-specializers)
700     (lambda-list
701     :initform ()
702     :initarg :lambda-list
703     :reader method-lambda-list)
704     (function
705     :initform nil
706     :initarg :function)
707     (fast-function
708     :initform nil
709     :initarg :fast-function
710     :reader method-fast-function)))
711 ram 1.7
712 ram 1.8 (defclass standard-accessor-method (standard-method)
713 gerd 1.33.2.1 ((slot-name
714     :initform nil
715     :initarg :slot-name
716     :reader accessor-method-slot-name)
717     (slot-definition
718     :initform nil
719     :initarg :slot-definition
720     :reader accessor-method-slot-definition)))
721 ram 1.7
722 ram 1.8 (defclass standard-reader-method (standard-accessor-method) ())
723 ram 1.7
724 ram 1.8 (defclass standard-writer-method (standard-accessor-method) ())
725 ram 1.7
726 ram 1.8 (defclass standard-boundp-method (standard-accessor-method) ())
727 ram 1.7
728 ram 1.8 (defclass generic-function (dependent-update-mixin
729     definition-source-mixin
730     documentation-mixin
731 dtc 1.14 funcallable-standard-object)
732 gerd 1.33.2.1 ()
733 ram 1.8 (:metaclass funcallable-standard-class))
734    
735     (defclass standard-generic-function (generic-function)
736 gerd 1.33.2.1 ((name
737     :initform nil
738     :initarg :name
739     :accessor generic-function-name)
740     (methods
741     :initform ()
742     :accessor generic-function-methods)
743     (method-class
744     :initarg :method-class
745     :accessor generic-function-method-class)
746     (method-combination
747     :initarg :method-combination
748     :accessor generic-function-method-combination)
749     (arg-info
750     :initform (make-arg-info)
751     :reader gf-arg-info)
752     (dfun-state
753     :initform ()
754     :accessor gf-dfun-state)
755     (pretty-arglist
756     :initform ()
757     :accessor gf-pretty-arglist)
758     (declarations
759     :initform ()
760     :initarg :declarations
761     :reader generic-function-declarations))
762 ram 1.8 (:metaclass funcallable-standard-class)
763     (:default-initargs :method-class *the-class-standard-method*
764 gerd 1.33.2.1 :method-combination *standard-method-combination*))
765 ram 1.7
766 dtc 1.14 (defclass method-combination (standard-object) ())
767 ram 1.7
768 ram 1.8 (defclass standard-method-combination
769 gerd 1.33.2.1 (definition-source-mixin method-combination)
770     ((type
771     :reader method-combination-type
772     :initarg :type)
773     (documentation
774     :reader method-combination-documentation
775     :initarg :documentation)
776     (options
777     :reader method-combination-options
778     :initarg :options)))
779 ram 1.7
780 pmai 1.31 (defclass long-method-combination (standard-method-combination)
781     ((function
782     :initarg :function
783     :reader long-method-combination-function)
784 gerd 1.33.2.1 (args-lambda-list
785     :initarg :args-lambda-list
786     :reader long-method-combination-args-lambda-list)))
787    
788     (defclass seal (standard-object)
789     ((quality
790     :initarg :quality
791     :reader seal-quality)))
792 pmai 1.31
793 ram 1.6 (defparameter *early-class-predicates*
794     '((specializer specializerp)
795     (exact-class-specializer exact-class-specializer-p)
796     (class-eq-specializer class-eq-specializer-p)
797     (eql-specializer eql-specializer-p)
798     (class classp)
799 ram 1.8 (slot-class slot-class-p)
800 dtc 1.14 (std-class std-class-p)
801 ram 1.6 (standard-class standard-class-p)
802     (funcallable-standard-class funcallable-standard-class-p)
803     (structure-class structure-class-p)
804 ram 1.8 (forward-referenced-class forward-referenced-class-p)
805     (method method-p)
806     (standard-method standard-method-p)
807     (standard-accessor-method standard-accessor-method-p)
808     (standard-reader-method standard-reader-method-p)
809     (standard-writer-method standard-writer-method-p)
810     (standard-boundp-method standard-boundp-method-p)
811     (generic-function generic-function-p)
812     (standard-generic-function standard-generic-function-p)
813 pmai 1.31 (method-combination method-combination-p)
814     (long-method-combination long-method-combination-p)))
815 gerd 1.33.2.1
816 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5