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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Thu Feb 6 15:20:12 2003 UTC (11 years, 2 months ago) by gerd
Branch: MAIN
CVS Tags: release-18e-base, release-18e-pre2, cold-pcl-base, release-18e, release-18e-pre1
Branch point for: release-18e-branch, cold-pcl
Changes since 1.32: +1 -1 lines
* pcl/defs.lisp (standard-method): Change superclass
plist-mixin to documentation-mixin so that we don't throw
away the method documentation.

* pcl/cmucl-documentation.lisp (setf documentation): Use
set-random-documentation.

* pcl/defcombin.lisp (set-random-documentation): New function.
(load-short-defcombin, load-long-defcombin): Use it.

* pcl/env.lisp (describe-object) <standard-generic-function>:
Print the generic function doc string, if any.  Print method doc
strings.
(describe-object) <class>: Print slots.

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

  ViewVC Help
Powered by ViewVC 1.1.5