0.9.1.7: "fix" SB-SPROF on non-gencgc platforms
[sbcl.git] / src / pcl / defs.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 ;;; (These are left over from the days when PCL was an add-on package
27 ;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal
28 ;;; build, of course, but they might happen if someone is experimenting
29 ;;; and debugging, and it's probably worth complaining if they do,
30 ;;; so we've left 'em in.)
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 (when *boot-state*
36   (cerror "Try loading (or compiling) PCL anyways."
37           "Trying to load (or compile) PCL in an environment in which it~%~
38            has already been partially loaded. This may not work, you may~%~
39            need to get a fresh lisp (reboot) and then load PCL."))
40 \f
41 ;;; comments from CMU CL version of PCL:
42 ;;;     This is like fdefinition on the Lispm. If Common Lisp had
43 ;;;   something like function specs I wouldn't need this. On the other
44 ;;;   hand, I don't like the way this really works so maybe function
45 ;;;   specs aren't really right either?
46 ;;;     I also don't understand the real implications of a Lisp-1 on this
47 ;;;   sort of thing. Certainly some of the lossage in all of this is
48 ;;;   because these SPECs name global definitions.
49 ;;;     Note that this implementation is set up so that an implementation
50 ;;;   which has a 'real' function spec mechanism can use that instead
51 ;;;   and in that way get rid of setf generic function names.
52 (defmacro parse-gspec (spec
53                        (non-setf-var . non-setf-case))
54   `(let ((,non-setf-var ,spec)) ,@non-setf-case))
55
56 ;;; If symbol names a function which is traced, return the untraced
57 ;;; definition. This lets us get at the generic function object even
58 ;;; when it is traced.
59 (defun unencapsulated-fdefinition (symbol)
60   (fdefinition symbol))
61
62 ;;; If symbol names a function which is traced, redefine the `real'
63 ;;; definition without affecting the trace.
64 (defun fdefine-carefully (name new-definition)
65   (progn
66     (sb-c::note-name-defined name :function)
67     new-definition)
68   (setf (fdefinition name) new-definition))
69
70 (defun gboundp (spec)
71   (parse-gspec spec
72     (name (fboundp name))))
73
74 (defun gmakunbound (spec)
75   (parse-gspec spec
76     (name (fmakunbound name))))
77
78 (defun gdefinition (spec)
79   (parse-gspec spec
80     (name (unencapsulated-fdefinition name))))
81
82 (defun (setf gdefinition) (new-value spec)
83   (parse-gspec spec
84     (name (fdefine-carefully name new-value))))
85 \f
86 ;;;; type specifier hackery
87
88 ;;; internal to this file
89 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
90   (if (symbolp class)
91       (or (find-class class (not make-forward-referenced-class-p))
92           (ensure-class class))
93       class))
94
95 ;;; interface
96 (defun specializer-from-type (type &aux args)
97   (when (consp type)
98     (setq args (cdr type) type (car type)))
99   (cond ((symbolp type)
100          (or (and (null args) (find-class type))
101              (ecase type
102                (class    (coerce-to-class (car args)))
103                (prototype (make-instance 'class-prototype-specializer
104                                          :object (coerce-to-class (car args))))
105                (class-eq (class-eq-specializer (coerce-to-class (car args))))
106                (eql      (intern-eql-specializer (car args))))))
107         ;; FIXME: do we still need this?
108         ((and (null args) (typep type 'classoid))
109          (or (classoid-pcl-class type)
110              (ensure-non-standard-class (classoid-name type))))
111         ((specializerp type) type)))
112
113 ;;; interface
114 (defun type-from-specializer (specl)
115   (cond ((eq specl t)
116          t)
117         ((consp specl)
118          (unless (member (car specl) '(class prototype class-eq eql))
119            (error "~S is not a legal specializer type." specl))
120          specl)
121         ((progn
122            (when (symbolp specl)
123              ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
124              (setq specl (find-class specl)))
125            (or (not (eq *boot-state* 'complete))
126                (specializerp specl)))
127          (specializer-type specl))
128         (t
129          (error "~S is neither a type nor a specializer." specl))))
130
131 (defun type-class (type)
132   (declare (special *the-class-t*))
133   (setq type (type-from-specializer type))
134   (if (atom type)
135       (if (eq type t)
136           *the-class-t*
137           (error "bad argument to TYPE-CLASS"))
138       (case (car type)
139         (eql (class-of (cadr type)))
140         (prototype (class-of (cadr type))) ;?
141         (class-eq (cadr type))
142         (class (cadr type)))))
143
144 (defun class-eq-type (class)
145   (specializer-type (class-eq-specializer class)))
146
147 ;;; internal to this file..
148 ;;;
149 ;;; These functions are a pale imitation of their namesake. They accept
150 ;;; class objects or types where they should.
151 (defun *normalize-type (type)
152   (cond ((consp type)
153          (if (member (car type) '(not and or))
154              `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
155              (if (null (cdr type))
156                  (*normalize-type (car type))
157                  type)))
158         ((symbolp type)
159          (let ((class (find-class type nil)))
160            (if class
161                (let ((type (specializer-type class)))
162                  (if (listp type) type `(,type)))
163                `(,type))))
164         ((or (not (eq *boot-state* 'complete))
165              (specializerp type))
166          (specializer-type type))
167         (t
168          (error "~S is not a type." type))))
169
170 ;;; internal to this file...
171 (defun convert-to-system-type (type)
172   (case (car type)
173     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
174                                           (cdr type))))
175     ((class class-eq) ; class-eq is impossible to do right
176      (layout-classoid (class-wrapper (cadr type))))
177     (eql type)
178     (t (if (null (cdr type))
179            (car type)
180            type))))
181
182 ;;; Writing the missing NOT and AND clauses will improve the quality
183 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
184 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
185 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
186 ;;;
187 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
188 ;;; in the compiler. Could we share some of it here? 
189 (defun *subtypep (type1 type2)
190   (if (equal type1 type2)
191       (values t t)
192       (if (eq *boot-state* 'early)
193           (values (eq type1 type2) t)
194           (let ((*in-precompute-effective-methods-p* t))
195             (declare (special *in-precompute-effective-methods-p*))
196             ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
197             ;; good name. It changes the way
198             ;; CLASS-APPLICABLE-USING-CLASS-P works.
199             (setq type1 (*normalize-type type1))
200             (setq type2 (*normalize-type type2))
201             (case (car type2)
202               (not
203                (values nil nil)) ; XXX We should improve this.
204               (and
205                (values nil nil)) ; XXX We should improve this.
206               ((eql wrapper-eq class-eq class)
207                (multiple-value-bind (app-p maybe-app-p)
208                    (specializer-applicable-using-type-p type2 type1)
209                  (values app-p (or app-p (not maybe-app-p)))))
210               (t
211                (subtypep (convert-to-system-type type1)
212                          (convert-to-system-type type2))))))))
213 \f
214 (defvar *built-in-class-symbols* ())
215 (defvar *built-in-wrapper-symbols* ())
216
217 (defun get-built-in-class-symbol (class-name)
218   (or (cadr (assq class-name *built-in-class-symbols*))
219       (let ((symbol (make-class-symbol class-name)))
220         (push (list class-name symbol) *built-in-class-symbols*)
221         symbol)))
222
223 (defun get-built-in-wrapper-symbol (class-name)
224   (or (cadr (assq class-name *built-in-wrapper-symbols*))
225       (let ((symbol (make-wrapper-symbol class-name)))
226         (push (list class-name symbol) *built-in-wrapper-symbols*)
227         symbol)))
228 \f
229 (pushnew '%class *var-declarations*)
230 (pushnew '%variable-rebinding *var-declarations*)
231
232 (defun variable-class (var env)
233   (caddr (var-declaration 'class var env)))
234
235 (defvar *name->class->slotd-table* (make-hash-table))
236
237 (defvar *standard-method-combination*)
238 \f
239 (defun make-class-predicate-name (name)
240   (list 'class-predicate name))
241   
242 (defun plist-value (object name)
243   (getf (object-plist object) name))
244
245 (defun (setf plist-value) (new-value object name)
246   (if new-value
247       (setf (getf (object-plist object) name) new-value)
248       (progn
249         (remf (object-plist object) name)
250         nil)))
251 \f
252 ;;;; built-in classes
253
254 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
255 ;;; SB-PCL:*BUILT-IN-CLASSES*.
256 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
257 (defvar *built-in-classes*
258   (labels ((direct-supers (class)
259              (/noshow "entering DIRECT-SUPERS" (classoid-name class))
260              (if (typep class 'built-in-classoid)
261                  (built-in-classoid-direct-superclasses class)
262                  (let ((inherits (layout-inherits
263                                   (classoid-layout class))))
264                    (/noshow inherits)
265                    (list (svref inherits (1- (length inherits)))))))
266            (direct-subs (class)
267              (/noshow "entering DIRECT-SUBS" (classoid-name class))
268              (collect ((res))
269                (let ((subs (classoid-subclasses class)))
270                  (/noshow subs)
271                  (when subs
272                    (dohash (sub v subs)
273                      (declare (ignore v))
274                      (/noshow sub)
275                      (when (member class (direct-supers sub))
276                        (res sub)))))
277                (res))))
278     (mapcar (lambda (kernel-bic-entry)
279               (/noshow "setting up" kernel-bic-entry)
280               (let* ((name (car kernel-bic-entry))
281                      (class (find-classoid name))
282                      (prototype-form
283                       (getf (cdr kernel-bic-entry) :prototype-form)))
284                 (/noshow name class)
285                 `(,name
286                   ,(mapcar #'classoid-name (direct-supers class))
287                   ,(mapcar #'classoid-name (direct-subs class))
288                   ,(map 'list
289                         (lambda (x)
290                           (classoid-name
291                            (layout-classoid x)))
292                         (reverse
293                          (layout-inherits
294                           (classoid-layout class))))
295                   ,(if prototype-form
296                        (eval prototype-form)
297                        ;; This is the default prototype value which
298                        ;; was used, without explanation, by the CMU CL
299                        ;; code we're derived from. Evidently it's safe
300                        ;; in all relevant cases.
301                        42))))
302             (remove-if (lambda (kernel-bic-entry)
303                          (member (first kernel-bic-entry)
304                                  ;; I'm not sure why these are removed from
305                                  ;; the list, but that's what the original
306                                  ;; CMU CL code did. -- WHN 20000715
307                                  '(t instance
308                                      funcallable-instance
309                                      function stream 
310                                      file-stream string-stream)))
311                        sb-kernel::*built-in-classes*))))
312 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
313 \f
314 ;;;; the classes that define the kernel of the metabraid
315
316 (defclass t () ()
317   (:metaclass built-in-class))
318
319 (defclass instance (t) ()
320   (:metaclass built-in-class))
321
322 (defclass function (t) ()
323   (:metaclass built-in-class))
324
325 (defclass funcallable-instance (function) ()
326   (:metaclass built-in-class))
327
328 (defclass stream (instance) ()
329   (:metaclass built-in-class))
330
331 (defclass file-stream (stream) ()
332   (:metaclass built-in-class))
333
334 (defclass string-stream (stream) ()
335   (:metaclass built-in-class))
336
337 (defclass slot-object (t) ()
338   (:metaclass slot-class))
339
340 (defclass condition (slot-object instance) ()
341   (:metaclass condition-class))
342
343 (defclass structure-object (slot-object instance) ()
344   (:metaclass structure-class))
345
346 (defstruct (dead-beef-structure-object
347             (:constructor |STRUCTURE-OBJECT class constructor|)
348             (:copier nil)))
349
350 (defclass std-object (slot-object) ()
351   (:metaclass std-class))
352
353 (defclass standard-object (std-object instance) ())
354
355 (defclass funcallable-standard-object (std-object funcallable-instance)
356   ()
357   (:metaclass funcallable-standard-class))
358
359 (defclass specializer (standard-object)
360   ((type
361     :initform nil
362     :reader specializer-type)))
363
364 (defclass definition-source-mixin (std-object)
365   ((source
366     :initform *load-pathname*
367     :reader definition-source
368     :initarg :definition-source))
369   (:metaclass std-class))
370
371 (defclass plist-mixin (std-object)
372   ((plist
373     :initform ()
374     :accessor object-plist))
375   (:metaclass std-class))
376
377 (defclass dependent-update-mixin (plist-mixin)
378   ()
379   (:metaclass std-class))
380
381 ;;; The class CLASS is a specified basic class. It is the common
382 ;;; superclass of any kind of class. That is, any class that can be a
383 ;;; metaclass must have the class CLASS in its class precedence list.
384 (defclass class (dependent-update-mixin
385                  definition-source-mixin
386                  specializer)
387   ((name
388     :initform nil
389     :initarg  :name
390     :accessor class-name)
391    (class-eq-specializer
392     :initform nil
393     :reader class-eq-specializer)
394    (direct-superclasses
395     :initform ()
396     :reader class-direct-superclasses)
397    ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
398    ;; CONDITION-CLASSes are lazily computed whenever the subclass info
399    ;; becomes available, i.e. when the PCL class is created.
400    (direct-subclasses
401     :initform ()
402     :reader class-direct-subclasses)
403    (direct-methods
404     :initform (cons nil nil))
405    (predicate-name
406     :initform nil
407     :reader class-predicate-name)
408    (documentation
409     :initform nil
410     :initarg :documentation)
411    (finalized-p
412     :initform nil
413     :reader class-finalized-p)))
414
415 (def!method make-load-form ((class class) &optional env)
416   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
417   ;; doesn't matter while all our environments are the same...
418   (declare (ignore env))
419   (let ((name (class-name class)))
420     (unless (and name (eq (find-class name nil) class))
421       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
422              class))
423     `(find-class ',name)))
424
425 ;;; The class PCL-CLASS is an implementation-specific common
426 ;;; superclass of all specified subclasses of the class CLASS.
427 (defclass pcl-class (class)
428   ((class-precedence-list
429     :reader class-precedence-list)
430    ;; KLUDGE: see note in CPL-OR-NIL
431    (cpl-available-p
432     :reader cpl-available-p
433     :initform nil)
434    (can-precede-list
435     :initform ()
436     :reader class-can-precede-list)
437    (incompatible-superclass-list
438     :initform ()
439     :accessor class-incompatible-superclass-list)
440    (wrapper
441     :initform nil
442     :reader class-wrapper)
443    (prototype
444     :initform nil
445     :reader class-prototype)))
446
447 (defclass slot-class (pcl-class)
448   ((direct-slots
449     :initform ()
450     :accessor class-direct-slots)
451    (slots
452     :initform ()
453     :accessor class-slots)))
454
455 ;;; The class STD-CLASS is an implementation-specific common
456 ;;; superclass of the classes STANDARD-CLASS and
457 ;;; FUNCALLABLE-STANDARD-CLASS.
458 (defclass std-class (slot-class)
459   ())
460
461 (defclass standard-class (std-class)
462   ())
463
464 (defclass funcallable-standard-class (std-class)
465   ())
466
467 (defclass forward-referenced-class (pcl-class) ())
468
469 (defclass built-in-class (pcl-class) ())
470
471 (defclass condition-class (slot-class) ())
472
473 (defclass structure-class (slot-class)
474   ((defstruct-form
475      :initform ()
476      :accessor class-defstruct-form)
477    (defstruct-constructor
478      :initform nil
479      :accessor class-defstruct-constructor)
480    (from-defclass-p
481     :initform nil
482     :initarg :from-defclass-p)))
483
484 (defclass specializer-with-object (specializer) ())
485
486 (defclass exact-class-specializer (specializer) ())
487
488 (defclass class-eq-specializer (exact-class-specializer
489                                 specializer-with-object)
490   ((object :initarg :class
491            :reader specializer-class
492            :reader specializer-object)))
493
494 (defclass class-prototype-specializer (specializer-with-object)
495   ((object :initarg :class
496            :reader specializer-class
497            :reader specializer-object)))
498
499 (defclass eql-specializer (exact-class-specializer specializer-with-object)
500   ((object :initarg :object :reader specializer-object
501            :reader eql-specializer-object)))
502
503 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
504
505 (defun intern-eql-specializer (object)
506   (or (gethash object *eql-specializer-table*)
507       (setf (gethash object *eql-specializer-table*)
508             (make-instance 'eql-specializer :object object))))
509 \f
510 ;;;; slot definitions
511
512 (defclass slot-definition (standard-object)
513   ((name
514     :initform nil
515     :initarg :name
516     :accessor slot-definition-name)
517    (initform
518     :initform nil
519     :initarg :initform
520     :accessor slot-definition-initform)
521    (initfunction
522     :initform nil
523     :initarg :initfunction
524     :accessor slot-definition-initfunction)
525    (readers
526     :initform nil
527     :initarg :readers
528     :accessor slot-definition-readers)
529    (writers
530     :initform nil
531     :initarg :writers
532     :accessor slot-definition-writers)
533    (initargs
534     :initform nil
535     :initarg :initargs
536     :accessor slot-definition-initargs)
537    (type
538     :initform t
539     :initarg :type
540     :accessor slot-definition-type)
541    (documentation
542     :initform nil
543     :initarg :documentation)
544    (class
545     :initform nil
546     :initarg :class
547     :accessor slot-definition-class)))
548
549 (defclass standard-slot-definition (slot-definition)
550   ((allocation
551     :initform :instance
552     :initarg :allocation
553     :accessor slot-definition-allocation)
554    (allocation-class
555     :initform nil
556     :initarg :allocation-class
557     :accessor slot-definition-allocation-class)))
558
559 (defclass condition-slot-definition (slot-definition)
560   ((allocation
561     :initform :instance
562     :initarg :allocation
563     :accessor slot-definition-allocation)
564    (allocation-class
565     :initform nil
566     :initarg :allocation-class
567     :accessor slot-definition-allocation-class)))
568
569 (defclass structure-slot-definition (slot-definition)
570   ((defstruct-accessor-symbol
571      :initform nil
572      :initarg :defstruct-accessor-symbol
573      :accessor slot-definition-defstruct-accessor-symbol)
574    (internal-reader-function
575      :initform nil
576      :initarg :internal-reader-function
577      :accessor slot-definition-internal-reader-function)
578    (internal-writer-function
579      :initform nil
580      :initarg :internal-writer-function
581      :accessor slot-definition-internal-writer-function)))
582
583 (defclass direct-slot-definition (slot-definition)
584   ())
585
586 (defclass effective-slot-definition (slot-definition)
587   ((reader-function ; (lambda (object) ...)
588     :accessor slot-definition-reader-function)
589    (writer-function ; (lambda (new-value object) ...)
590     :accessor slot-definition-writer-function)
591    (boundp-function ; (lambda (object) ...)
592     :accessor slot-definition-boundp-function)
593    (accessor-flags
594     :initform 0)))
595
596 (defclass standard-direct-slot-definition (standard-slot-definition
597                                            direct-slot-definition)
598   ())
599
600 (defclass standard-effective-slot-definition (standard-slot-definition
601                                               effective-slot-definition)
602   ((location ; nil, a fixnum, a cons: (slot-name . value)
603     :initform nil
604     :accessor slot-definition-location)))
605
606 (defclass condition-direct-slot-definition (condition-slot-definition
607                                             direct-slot-definition)
608   ())
609
610 (defclass condition-effective-slot-definition (condition-slot-definition
611                                                effective-slot-definition)
612   ())
613
614 (defclass structure-direct-slot-definition (structure-slot-definition
615                                             direct-slot-definition)
616   ())
617
618 (defclass structure-effective-slot-definition (structure-slot-definition
619                                                effective-slot-definition)
620   ())
621
622 (defclass method (standard-object) ())
623
624 (defclass standard-method (definition-source-mixin plist-mixin method)
625   ((generic-function
626     :initform nil       
627     :accessor method-generic-function)
628 ;;;     (qualifiers
629 ;;;     :initform ()
630 ;;;     :initarg  :qualifiers
631 ;;;     :reader method-qualifiers)
632    (specializers
633     :initform ()
634     :initarg  :specializers
635     :reader method-specializers)
636    (lambda-list
637     :initform ()
638     :initarg  :lambda-list
639     :reader method-lambda-list)
640    (function
641     :initform nil
642     :initarg :function)                 ;no writer
643    (fast-function
644     :initform nil
645     :initarg :fast-function             ;no writer
646     :reader method-fast-function)
647    (documentation
648     :initform nil
649     :initarg :documentation)))
650
651 (defclass standard-accessor-method (standard-method)
652   ((slot-name :initform nil
653               :initarg :slot-name
654               :reader accessor-method-slot-name)
655    (slot-definition :initform nil
656                     :initarg :slot-definition
657                     :reader accessor-method-slot-definition)))
658
659 (defclass standard-reader-method (standard-accessor-method) ())
660
661 (defclass standard-writer-method (standard-accessor-method) ())
662
663 (defclass standard-boundp-method (standard-accessor-method) ())
664
665 (defclass generic-function (dependent-update-mixin
666                             definition-source-mixin
667                             funcallable-standard-object)
668   ((documentation
669     :initform nil
670     :initarg :documentation)
671    ;; We need to make a distinction between the methods initially set
672    ;; up by :METHOD options to DEFGENERIC and the ones set up later by
673    ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
674    ;; an already-DEFGENERICed function clears the methods set by the
675    ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
676    ;; this distinction seems a little kludgy, but it has the positive
677    ;; effect of making it so that loading a file a.lisp containing
678    ;; DEFGENERIC, then loading a second file b.lisp containing
679    ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
680    ;; tends to leave the generic function in a state consistent with
681    ;; the most-recently-loaded state of a.lisp and b.lisp.)
682    (initial-methods
683     :initform ()
684     :accessor generic-function-initial-methods))
685   (:metaclass funcallable-standard-class))
686
687 (defclass standard-generic-function (generic-function)
688   ((name
689     :initform nil
690     :initarg :name
691     :accessor generic-function-name)
692    (methods
693     :initform ()
694     :accessor generic-function-methods
695     :type list)
696    (method-class
697     :initarg :method-class
698     :accessor generic-function-method-class)
699    (method-combination
700     :initarg :method-combination
701     :accessor generic-function-method-combination)
702    (declarations
703     :initarg :declarations
704     :initform ()
705     :accessor generic-function-declarations)
706    (arg-info
707     :initform (make-arg-info)
708     :reader gf-arg-info)
709    (dfun-state
710     :initform ()
711     :accessor gf-dfun-state))
712   (:metaclass funcallable-standard-class)
713   (:default-initargs :method-class *the-class-standard-method*
714                      :method-combination *standard-method-combination*))
715
716 (defclass method-combination (standard-object)
717   ((documentation
718     :reader method-combination-documentation
719     :initform nil
720     :initarg :documentation)))
721
722 (defclass standard-method-combination (definition-source-mixin
723                                        method-combination)
724   ((type
725     :reader method-combination-type
726     :initarg :type)
727    (options
728     :reader method-combination-options
729     :initarg :options)))
730
731 (defclass long-method-combination (standard-method-combination)
732   ((function
733     :initarg :function
734     :reader long-method-combination-function)
735    (args-lambda-list
736     :initarg :args-lambda-list
737     :reader long-method-combination-args-lambda-list)))
738
739 (defparameter *early-class-predicates*
740   '((specializer specializerp)
741     (exact-class-specializer exact-class-specializer-p)
742     (class-eq-specializer class-eq-specializer-p)
743     (eql-specializer eql-specializer-p)
744     (class classp)
745     (slot-class slot-class-p)
746     (std-class std-class-p)
747     (standard-class standard-class-p)
748     (funcallable-standard-class funcallable-standard-class-p)
749     (condition-class condition-class-p)
750     (structure-class structure-class-p)
751     (forward-referenced-class forward-referenced-class-p)
752     (method method-p)
753     (standard-method standard-method-p)
754     (standard-accessor-method standard-accessor-method-p)
755     (standard-reader-method standard-reader-method-p)
756     (standard-writer-method standard-writer-method-p)
757     (standard-boundp-method standard-boundp-method-p)
758     (generic-function generic-function-p)
759     (standard-generic-function standard-generic-function-p)
760     (method-combination method-combination-p)
761     (long-method-combination long-method-combination-p)))
762