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

  ViewVC Help
Powered by ViewVC 1.1.5