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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (show annotations)
Sun May 4 13:11:22 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.37: +7 -7 lines
	Code cleanup.  Use EXTENSIONS package to reduce clutter.

	* src/pcl/defsys.lisp ("PCL", "WALKER"): Use ext.
	* src/pcl/pkg.lisp ("PCL", "WALKER"): Use ext.
	* src/pcl/*.lisp: Remove ext: prefixes.

	* src/pcl/low.lisp (symbolicate*): Renamed from symbolicate.
	* src/pcl/std-class.lisp (shared-initialize):
	* src/pcl/defs.lisp (get-built-in-class-symbol)
	(get-built-in-wrapper-symbol):
	* src/pcl/braid.lisp (initial-classes-and-wrappers)
	(bootstrap-meta-braid): Use symbolicate*.

	* src/pcl/macros.lisp (dolist-carefully): Removed.
	(true, false, zero): Moved to defclass.lisp.
	(printing-random-thing-internal): Removed.
	(printing-random-thing): Removed.
	(rassq): Removed.
	(*keyword-package*): Removed.
	(make-keyword): Removed; import from cl.
	(memq, delq, assq): Macros removed, import from ext.
	(get-declaration): Moved to boot.lisp, where it's used.

	* src/pcl/boot.lisp (get-declaration): Moved here from
	macros.lisp.

	* src/pcl/methods.lisp (named-object-print-function, print-object):
	* src/pcl/low.lisp (print-std-instance):
	* src/pcl/dfun.lisp (print-dfun-info):
	* src/pcl/cache.lisp (print-cache, print-wrapper):
	* src/pcl/boot.lisp (make-early-gf):
	Use print-unreadable-object instead of printing-random-thing.

	* src/pcl/defclass.lisp (true, false, zero): Moved here from
	macros.lisp.

	* src/pcl/methods.lisp (legal-qualifiers-p)
	(legal-specializers-p): Use dolist.
1 ;;;-*-Mode:LISP; Package:PCL -*-
2 ;;;
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 (in-package :pcl)
28
29 #-(or loadable-pcl bootable-pcl)
30 (eval-when (:compile-toplevel :load-toplevel :execute)
31 (when (eq *boot-state* 'complete)
32 (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
36 (when *boot-state*
37 (cerror "Try loading (or compiling) PCL anyways."
38 "~@<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
42 ;;;
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
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 ;;; Note that FDEFINITION takes care of encapsulations. PROFILE
57 ;;; isn't using encapsulations, so it has to be treated specially.
58 ;;;
59 (declaim (inline gdefinition))
60
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
69 ;;;
70 ;;; If symbol names a function which is traced or advised, redefine
71 ;;; the `real' definition without affecting the advise.
72 ;;
73 (defun (setf gdefinition) (new-definition name)
74 (c::%%defun name new-definition nil)
75 (c::note-name-defined name :function)
76 new-definition)
77
78
79 (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
89 *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 *the-class-std-class*
98 *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
112 (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
122 ;;;; Type specifier hackery:
123
124 ;;; internal to this file.
125 (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 ;;; Interface
132 (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 ((and (null args) (typep type 'kernel::class))
142 (or (kernel:%class-pcl-class type)
143 (ensure-non-standard-class (kernel:%class-name type))))
144 ((specializerp type) type)))
145
146 ;;; interface
147 (defun type-from-specializer (specl)
148 (cond ((eq specl t)
149 t)
150 ((consp specl)
151 (unless (member (car specl) '(class class-eq eql))
152 (error "~@<~S is not a legal specializer type.~@:>" specl))
153 specl)
154 ((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 (t
162 (error "~@<~s is neither a type nor a specializer.~@:>" specl))))
163
164 (defun type-class (type)
165 (declare (special *the-class-t*))
166 (setq type (type-from-specializer type))
167 (if (atom type)
168 (if (eq type t)
169 *the-class-t*
170 (internal-error "Bad argument to type-class."))
171 (case (car type)
172 (eql (class-of (cadr type)))
173 (class-eq (cadr type))
174 (class (cadr type)))))
175
176 (defun class-eq-type (class)
177 (specializer-type (class-eq-specializer class)))
178
179 (defun inform-type-system-about-std-class (name)
180 ;; 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 (declare (ignorable name))
191 (when (and (eq *boot-state* 'complete)
192 (null (kernel::find-class name nil)))
193 (setf (kernel::find-class name)
194 (kernel::make-standard-class :name name))))
195
196 ;;; Internal to this file.
197 ;;;
198 ;;; These functions are a pale imitiation of their namesake. They accept
199 ;;; class objects or types where they should.
200 ;;;
201 (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 ((or (not (eq *boot-state* 'complete))
215 (specializerp type))
216 (specializer-type type))
217 (t
218 (error "~s is not a type." type))))
219
220 ;;; internal to this file...
221 (defun convert-to-system-type (type)
222 (case (car type)
223 ((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 (kernel:layout-class (class-wrapper (cadr type))))
227 (eql type)
228 (t (if (null (cdr type))
229 (car type)
230 type))))
231
232
233 ;;; *SUBTYPEP -- Interface
234 ;;;
235 ;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 (defun *subtypep (type1 type2)
240 (if (equal type1 type2)
241 (values t t)
242 (if (eq *boot-state* 'early)
243 (values (eq type1 type2) t)
244 (let ((*in-precompute-effective-methods-p* t))
245 (declare (special *in-precompute-effective-methods-p*))
246 ;; *in-precompute-effective-methods-p* is not a good name.
247 ;; It changes the way class-applicable-using-class-p works.
248 (setq type1 (*normalize-type type1))
249 (setq type2 (*normalize-type type2))
250 (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
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 (let ((symbol (symbolicate* *the-pcl-package*
270 '*the-class- class-name '*)))
271 (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 (let ((symbol (symbolicate* *the-pcl-package*
277 '*the-wrapper-of- class-name '*)))
278 (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 (defvar *name->class->slotd-table* (make-hash-table))
288
289 (defvar *standard-method-combination*)
290
291
292
293 (defun make-class-predicate-name (name)
294 `(class-predicate ,name))
295
296 (defun plist-value (object name)
297 (getf (object-plist object) name))
298
299 (defun (setf plist-value) (new-value object name)
300 (if new-value
301 (setf (getf (object-plist object) name) new-value)
302 (progn
303 (remf (object-plist object) name)
304 nil)))
305
306
307
308 (defvar *built-in-classes*
309 ;;
310 ;; name supers subs cdr of cpl
311 ;; prototype
312 '(;(t () (number sequence array character symbol) ())
313 (number (t) (complex float rational) (t))
314 (complex (number) () (number t)
315 #c(1 1))
316 (float (number) () (number t)
317 1.0)
318 (rational (number) (integer ratio) (number t))
319 (integer (rational) () (rational number t)
320 1)
321 (ratio (rational) () (rational number t)
322 1/2)
323
324 (sequence (t) (list vector) (t))
325 (list (sequence) (cons null) (sequence t))
326 (cons (list) () (list sequence t)
327 (nil))
328
329
330 (array (t) (vector) (t)
331 #2A((NIL)))
332 (vector (array
333 sequence) (string bit-vector) (array sequence t)
334 #())
335 (string (vector) () (vector array sequence t)
336 "")
337 (bit-vector (vector) () (vector array sequence t)
338 #*1)
339 (character (t) () (t)
340 #\c)
341
342 (symbol (t) (null) (t)
343 symbol)
344 (null (symbol
345 list) () (symbol list sequence t)
346 nil)))
347
348 (labels ((direct-supers (class)
349 (if (typep class 'kernel::built-in-class)
350 (kernel:built-in-class-direct-superclasses class)
351 (let ((inherits (kernel:layout-inherits
352 (kernel:%class-layout class))))
353 (list (svref inherits (1- (length inherits)))))))
354 (direct-subs (class)
355 (collect ((res))
356 (let ((subs (kernel:%class-subclasses class)))
357 (when subs
358 (do-hash (sub v subs)
359 (declare (ignore v))
360 (when (member class (direct-supers sub))
361 (res sub)))))
362 (res))))
363 (collect ((res))
364 (dolist (bic kernel::built-in-classes)
365 (let* ((name (car bic))
366 (class (kernel::find-class name)))
367 (unless (member name '(t kernel:instance kernel:funcallable-instance
368 function stream))
369 (res `(,name
370 ,(mapcar #'kernel:%class-name (direct-supers class))
371 ,(mapcar #'kernel:%class-name (direct-subs class))
372 ,(map 'list (lambda (x)
373 (kernel:%class-name (kernel:layout-class x)))
374 (reverse
375 (kernel:layout-inherits
376 (kernel:%class-layout class))))
377 ,(let ((found (assoc name *built-in-classes*)))
378 (if found (fifth found) 42)))))))
379 (setq *built-in-classes* (res))))
380
381
382 ;;;
383 ;;; The classes that define the kernel of the metabraid.
384 ;;;
385 (defclass t () ()
386 (:metaclass built-in-class))
387
388 (defclass kernel:instance (t) ()
389 (:metaclass built-in-class))
390
391 (defclass function (t) ()
392 (:metaclass built-in-class))
393
394 (defclass kernel:funcallable-instance (function) ()
395 (:metaclass built-in-class))
396
397 (defclass stream (kernel:instance) ()
398 (:metaclass built-in-class))
399
400 (defclass slot-object (t) ()
401 (:metaclass slot-class))
402
403 ;;;
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 (defclass structure-object (slot-object kernel:instance) ()
418 (:metaclass structure-class))
419
420 (defstruct (dead-beef-structure-object
421 (:constructor |STRUCTURE-OBJECT class constructor|)))
422
423 (defclass standard-object (slot-object) ())
424 (defclass metaobject (standard-object) ())
425
426 (defclass funcallable-standard-object (standard-object
427 kernel:funcallable-instance)
428 ()
429 (:metaclass funcallable-standard-class))
430
431 (defclass specializer (metaobject)
432 ((type
433 :initform nil
434 :reader specializer-type)))
435
436 (defclass definition-source-mixin (standard-object)
437 ((source
438 :initform *load-pathname*
439 :reader definition-source
440 :initarg :definition-source)))
441
442 (defclass plist-mixin (standard-object)
443 ((plist
444 :initform ()
445 :accessor object-plist)))
446
447 (defclass documentation-mixin (plist-mixin) ())
448
449 (defclass dependent-update-mixin (plist-mixin) ())
450
451 ;;;
452 ;;; The class CLASS is a specified basic class. It is the common superclass
453 ;;; 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 ;;;
456 (defclass class (documentation-mixin dependent-update-mixin
457 definition-source-mixin
458 specializer
459 kernel:instance)
460 ((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 (finalized-p
479 :initform nil
480 :reader class-finalized-p)))
481
482 ;;;
483 ;;; The class PCL-CLASS is an implementation-specific common superclass of
484 ;;; all specified subclasses of the class CLASS.
485 ;;;
486 (defclass pcl-class (class)
487 ((class-precedence-list
488 :reader class-precedence-list)
489 (can-precede-list
490 :initform ()
491 :reader class-can-precede-list)
492 (incompatible-superclass-list
493 :initform ()
494 :accessor class-incompatible-superclass-list)
495 (wrapper
496 :initform nil
497 :reader class-wrapper)
498 (prototype
499 :initform nil
500 :reader class-prototype)))
501
502 (defclass slot-class (pcl-class)
503 ((direct-slots
504 :initform ()
505 :accessor class-direct-slots)
506 (slots
507 :initform ()
508 :accessor class-slots)
509 (initialize-info
510 :initform nil
511 :accessor class-initialize-info)))
512
513 ;;;
514 ;;; The class STD-CLASS is an implementation-specific common superclass of
515 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
516 ;;;
517 (defclass std-class (slot-class) ())
518
519 (defclass standard-class (std-class) ())
520
521 (defclass funcallable-standard-class (std-class) ())
522
523 (defclass forward-referenced-class (pcl-class) ())
524
525 (defclass built-in-class (pcl-class) ())
526
527 (defclass structure-class (slot-class)
528 ((defstruct-form
529 :initform ()
530 :accessor class-defstruct-form)
531 (defstruct-constructor
532 :initform nil
533 :accessor class-defstruct-constructor)
534 (from-defclass-p
535 :initform nil
536 :initarg :from-defclass-p)))
537
538 (defclass condition-class (pcl-class) ())
539
540 (defclass specializer-with-object (specializer) ())
541
542 (defclass exact-class-specializer (specializer) ())
543
544 ;;;
545 ;;; Extension specializing on the exact specified class. You must set
546 ;;; pcl::*allow-experimental-specializers-p* to use this extension.
547 ;;;
548 ;;; (defclass foo () ())
549 ;;; (defclass bar (foo) ())
550 ;;;
551 ;;; (setq pcl::*allow-experimental-specializers-p* t)
552 ;;; (defmethod m (x) nil)
553 ;;; (defmethod m ((x (pcl::class-eq 'foo))) t)
554 ;;;
555 ;;; (m (make-instance 'foo)) => t
556 ;;; (m (make-instance 'bar)) => nil
557 ;;;
558
559 (defclass class-eq-specializer (exact-class-specializer
560 specializer-with-object)
561 ((object
562 :initarg :class
563 :reader specializer-class
564 :reader specializer-object)))
565
566 (defclass eql-specializer (exact-class-specializer specializer-with-object)
567 ((object
568 :initarg :object
569 :reader specializer-object
570 :reader eql-specializer-object)))
571
572 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
573
574 ;;;
575 ;;; When compiled with an intact PCL, the MAKE-INSTANCE in the function
576 ;;; below will generate an optimized constructor, and a LOAD-TIME-VALUE
577 ;;; creating it. That means CTOR must be initialized before this file
578 ;;; is.
579 ;;;
580 (defun intern-eql-specializer (object)
581 (or (gethash object *eql-specializer-table*)
582 (setf (gethash object *eql-specializer-table*)
583 (make-instance 'eql-specializer :object object))))
584
585
586 ;;;
587 ;;; Slot definitions.
588 ;;;
589 (defclass slot-definition (metaobject)
590 ((name
591 :initform nil
592 :initarg :name
593 :accessor slot-definition-name)
594 (initform
595 :initform nil
596 :initarg :initform
597 :accessor slot-definition-initform)
598 (initfunction
599 :initform nil
600 :initarg :initfunction
601 :accessor slot-definition-initfunction)
602 (readers
603 :initform nil
604 :initarg :readers
605 :accessor slot-definition-readers)
606 (writers
607 :initform nil
608 :initarg :writers
609 :accessor slot-definition-writers)
610 (initargs
611 :initform nil
612 :initarg :initargs
613 :accessor slot-definition-initargs)
614 (type
615 :initform t
616 :initarg :type
617 :accessor slot-definition-type)
618 (documentation
619 :initform ""
620 :initarg :documentation)
621 (class
622 :initform nil
623 :initarg :class
624 :accessor slot-definition-class)))
625
626 (defclass standard-slot-definition (slot-definition)
627 ((allocation
628 :initform :instance
629 :initarg :allocation
630 :accessor slot-definition-allocation)
631 (allocation-class
632 :documentation "For class slots, the class defininig the slot.
633 For inherited class slots, this is the superclass from which the slot
634 was inherited."
635 :initform nil
636 :initarg :allocation-class
637 :accessor slot-definition-allocation-class)))
638
639 (defclass structure-slot-definition (slot-definition)
640 ((defstruct-accessor-symbol
641 :initform nil
642 :initarg :defstruct-accessor-symbol
643 :accessor slot-definition-defstruct-accessor-symbol)
644 (internal-reader-function
645 :initform nil
646 :initarg :internal-reader-function
647 :accessor slot-definition-internal-reader-function)
648 (internal-writer-function
649 :initform nil
650 :initarg :internal-writer-function
651 :accessor slot-definition-internal-writer-function)))
652
653 (defclass direct-slot-definition (slot-definition)
654 ())
655
656 (defclass effective-slot-definition (slot-definition)
657 ((reader-function ; (lambda (object) ...)
658 :accessor slot-definition-reader-function)
659 (writer-function ; (lambda (new-value object) ...)
660 :accessor slot-definition-writer-function)
661 (boundp-function ; (lambda (object) ...)
662 :accessor slot-definition-boundp-function)
663 (accessor-flags
664 :initform 0)))
665
666 (defclass standard-direct-slot-definition (standard-slot-definition
667 direct-slot-definition)
668 ())
669
670 (defclass standard-effective-slot-definition (standard-slot-definition
671 effective-slot-definition)
672 ((location ; nil, a fixnum, a cons: (slot-name . value)
673 :initform nil
674 :accessor slot-definition-location)))
675
676 (defclass structure-direct-slot-definition (structure-slot-definition
677 direct-slot-definition)
678 ())
679
680 (defclass structure-effective-slot-definition (structure-slot-definition
681 effective-slot-definition)
682 ())
683
684 (defclass method (metaobject) ())
685
686 (defclass standard-method (definition-source-mixin documentation-mixin
687 method)
688 ((generic-function
689 :initform nil
690 :accessor method-generic-function)
691 (specializers
692 :initform ()
693 :initarg :specializers
694 :reader method-specializers)
695 (lambda-list
696 :initform ()
697 :initarg :lambda-list
698 :reader method-lambda-list)
699 (function
700 :initform nil
701 :initarg :function)
702 (fast-function
703 :initform nil
704 :initarg :fast-function
705 :reader method-fast-function)))
706
707 (defclass standard-accessor-method (standard-method)
708 ((slot-name
709 :initform nil
710 :initarg :slot-name
711 :reader accessor-method-slot-name)
712 (slot-definition
713 :initform nil
714 :initarg :slot-definition
715 :reader accessor-method-slot-definition)))
716
717 (defclass standard-reader-method (standard-accessor-method) ())
718
719 (defclass standard-writer-method (standard-accessor-method) ())
720
721 (defclass standard-boundp-method (standard-accessor-method) ())
722
723 (defclass generic-function (dependent-update-mixin
724 definition-source-mixin
725 documentation-mixin
726 metaobject
727 funcallable-standard-object)
728 ()
729 (:metaclass funcallable-standard-class))
730
731 (defclass standard-generic-function (generic-function)
732 ((name
733 :initform nil
734 :initarg :name
735 :accessor generic-function-name)
736 (methods
737 :initform ()
738 :accessor generic-function-methods)
739 (method-class
740 :initarg :method-class
741 :accessor generic-function-method-class)
742 (method-combination
743 :initarg :method-combination
744 :accessor generic-function-method-combination)
745 (arg-info
746 :initform (make-arg-info)
747 :reader gf-arg-info)
748 (dfun-state
749 :initform ()
750 :accessor gf-dfun-state)
751 (pretty-arglist
752 :initform ()
753 :accessor gf-pretty-arglist)
754 (declarations
755 :initform ()
756 :initarg :declarations
757 :reader generic-function-declarations))
758 (:metaclass funcallable-standard-class)
759 (:default-initargs :method-class *the-class-standard-method*
760 :method-combination *standard-method-combination*))
761
762 (defclass method-combination (metaobject) ())
763
764 (defclass standard-method-combination
765 (definition-source-mixin method-combination)
766 ((type
767 :reader method-combination-type
768 :initarg :type)
769 (documentation
770 :reader method-combination-documentation
771 :initarg :documentation)
772 (options
773 :reader method-combination-options
774 :initarg :options)))
775
776 (defclass long-method-combination (standard-method-combination)
777 ((function
778 :initarg :function
779 :reader long-method-combination-function)
780 (args-lambda-list
781 :initarg :args-lambda-list
782 :reader long-method-combination-args-lambda-list)))
783
784 (defclass seal (standard-object)
785 ((quality
786 :initarg :quality
787 :reader seal-quality)))
788
789 (defparameter *early-class-predicates*
790 '((specializer specializerp)
791 (exact-class-specializer exact-class-specializer-p)
792 (class-eq-specializer class-eq-specializer-p)
793 (eql-specializer eql-specializer-p)
794 (class classp)
795 (slot-class slot-class-p)
796 (std-class std-class-p)
797 (standard-class standard-class-p)
798 (funcallable-standard-class funcallable-standard-class-p)
799 (structure-class structure-class-p)
800 (forward-referenced-class forward-referenced-class-p)
801 (method method-p)
802 (standard-method standard-method-p)
803 (standard-accessor-method standard-accessor-method-p)
804 (standard-reader-method standard-reader-method-p)
805 (standard-writer-method standard-writer-method-p)
806 (standard-boundp-method standard-boundp-method-p)
807 (generic-function generic-function-p)
808 (standard-generic-function standard-generic-function-p)
809 (method-combination method-combination-p)
810 (long-method-combination long-method-combination-p)))
811
812

  ViewVC Help
Powered by ViewVC 1.1.5