1 ;;;; This software is part of the SBCL system. See the README file for
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
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
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
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
29 (eval-when (:compile-toplevel :load-toplevel :execute)
31 ;;; FIXME: These are non-ANSI hacks which it would be nice to get rid of.
32 (defvar *defclass-times* '(:load-toplevel :execute)) ; You probably have
33 ; to change this if you use
35 (defvar *defmethod-times* '(:load-toplevel :execute))
36 (defvar *defgeneric-times* '(:load-toplevel :execute))
40 (eval-when (:load-toplevel :execute)
41 (when (eq *boot-state* 'complete)
42 (error "Trying to load (or compile) PCL in an environment in which it~%~
43 has already been loaded. This doesn't work, you will have to~%~
44 get a fresh lisp (reboot) and then load PCL."))
46 (cerror "Try loading (or compiling) PCL anyways."
47 "Trying to load (or compile) PCL in an environment in which it~%~
48 has already been partially loaded. This may not work, you may~%~
49 need to get a fresh lisp (reboot) and then load PCL."))
52 ;;; This is like fdefinition on the Lispm. If Common Lisp had something like
53 ;;; function specs I wouldn't need this. On the other hand, I don't like the
54 ;;; way this really works so maybe function specs aren't really right either?
56 ;;; I also don't understand the real implications of a Lisp-1 on this sort of
57 ;;; thing. Certainly some of the lossage in all of this is because these
58 ;;; SPECs name global definitions.
60 ;;; Note that this implementation is set up so that an implementation which
61 ;;; has a 'real' function spec mechanism can use that instead and in that way
62 ;;; get rid of setf generic function names.
63 (defmacro parse-gspec (spec
64 (non-setf-var . non-setf-case)
65 (setf-var . setf-case))
66 (declare (indentation 1 1))
67 #+setf (declare (ignore setf-var setf-case))
69 `(cond (#-setf (symbolp ,spec) #+setf t
70 (let ((,non-setf-var ,spec)) ,@non-setf-case))
73 (eq (car ,spec) 'setf)
74 (symbolp (cadr ,spec)))
75 (let ((,setf-var (cadr ,spec))) ,@setf-case))
79 "Can't understand ~S as a generic function specifier.~%~
80 It must be either a symbol which can name a function or~%~
81 a list like ~S, where the car is the symbol ~S and the cadr~%~
82 is a symbol which can name a generic function."
83 ,spec '(setf <foo>) 'setf)))))
85 ;;; If symbol names a function which is traced or advised, return the
86 ;;; unadvised, traced etc. definition. This lets me get at the generic
87 ;;; function object even when it is traced.
88 (defun unencapsulated-fdefinition (symbol)
89 (symbol-function symbol))
91 ;;; If symbol names a function which is traced or advised, redefine
92 ;;; the `real' definition without affecting the advise.
93 (defun fdefine-carefully (name new-definition)
95 (sb-c::%%defun name new-definition nil)
96 (sb-c::note-name-defined name :function)
98 (setf (symbol-function name) new-definition))
100 (defun gboundp (spec)
102 (name (fboundp name))
103 (name (fboundp (get-setf-function-name name)))))
105 (defun gmakunbound (spec)
107 (name (fmakunbound name))
108 (name (fmakunbound (get-setf-function-name name)))))
110 (defun gdefinition (spec)
112 (name (or #-setf (macro-function name) ;??
113 (unencapsulated-fdefinition name)))
114 (name (unencapsulated-fdefinition (get-setf-function-name name)))))
116 (defun #-setf SETF\ SB-PCL\ GDEFINITION #+setf (setf gdefinition) (new-value
119 (name (fdefine-carefully name new-value))
120 (name (fdefine-carefully (get-setf-function-name name) new-value))))
122 (declaim (special *the-class-t*
123 *the-class-vector* *the-class-symbol*
124 *the-class-string* *the-class-sequence*
125 *the-class-rational* *the-class-ratio*
126 *the-class-number* *the-class-null* *the-class-list*
127 *the-class-integer* *the-class-float* *the-class-cons*
128 *the-class-complex* *the-class-character*
129 *the-class-bit-vector* *the-class-array*
132 *the-class-slot-object*
133 *the-class-structure-object*
134 *the-class-std-object*
135 *the-class-standard-object*
136 *the-class-funcallable-standard-object*
138 *the-class-generic-function*
139 *the-class-built-in-class*
140 *the-class-slot-class*
141 *the-class-structure-class*
142 *the-class-std-class*
143 *the-class-standard-class*
144 *the-class-funcallable-standard-class*
146 *the-class-standard-method*
147 *the-class-standard-reader-method*
148 *the-class-standard-writer-method*
149 *the-class-standard-boundp-method*
150 *the-class-standard-generic-function*
151 *the-class-standard-effective-slot-definition*
153 *the-eslotd-standard-class-slots*
154 *the-eslotd-funcallable-standard-class-slots*))
156 (declaim (special *the-wrapper-of-t*
157 *the-wrapper-of-vector* *the-wrapper-of-symbol*
158 *the-wrapper-of-string* *the-wrapper-of-sequence*
159 *the-wrapper-of-rational* *the-wrapper-of-ratio*
160 *the-wrapper-of-number* *the-wrapper-of-null*
161 *the-wrapper-of-list* *the-wrapper-of-integer*
162 *the-wrapper-of-float* *the-wrapper-of-cons*
163 *the-wrapper-of-complex* *the-wrapper-of-character*
164 *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
166 ;;;; type specifier hackery
168 ;;; internal to this file.
169 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
171 (or (find-class class (not make-forward-referenced-class-p))
172 (ensure-class class))
176 (defun specializer-from-type (type &aux args)
178 (setq args (cdr type) type (car type)))
179 (cond ((symbolp type)
180 (or (and (null args) (find-class type))
182 (class (coerce-to-class (car args)))
183 (prototype (make-instance 'class-prototype-specializer
184 :object (coerce-to-class (car args))))
185 (class-eq (class-eq-specializer (coerce-to-class (car args))))
186 (eql (intern-eql-specializer (car args))))))
187 ((and (null args) (typep type 'cl:class))
188 (or (sb-kernel:class-pcl-class type)
189 (find-structure-class (cl:class-name type))))
190 ((specializerp type) type)))
193 (defun type-from-specializer (specl)
197 (unless (member (car specl) '(class prototype class-eq eql))
198 (error "~S is not a legal specializer type." specl))
201 (when (symbolp specl)
202 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
203 (setq specl (find-class specl)))
204 (or (not (eq *boot-state* 'complete))
205 (specializerp specl)))
206 (specializer-type specl))
208 (error "~S is neither a type nor a specializer." specl))))
210 (defun type-class (type)
211 (declare (special *the-class-t*))
212 (setq type (type-from-specializer type))
216 (error "bad argument to type-class"))
218 (eql (class-of (cadr type)))
219 (prototype (class-of (cadr type))) ;?
220 (class-eq (cadr type))
221 (class (cadr type)))))
223 (defun class-eq-type (class)
224 (specializer-type (class-eq-specializer class)))
226 (defun inform-type-system-about-std-class (name)
227 (let ((predicate-name (make-type-predicate-name name)))
228 (setf (gdefinition predicate-name)
229 (make-type-predicate name))
230 (do-satisfies-deftype name predicate-name)))
232 (defun make-type-predicate (name)
233 (let ((cell (find-class-cell name)))
235 (funcall (the function (find-class-cell-predicate cell)) x))))
237 ;This stuff isn't right. Good thing it isn't used.
238 ;The satisfies predicate has to be a symbol. There is no way to
239 ;construct such a symbol from a class object if class names change.
240 (defun class-predicate (class)
241 (when (symbolp class) (setq class (find-class class)))
242 #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
244 (defun make-class-eq-predicate (class)
245 (when (symbolp class) (setq class (find-class class)))
246 #'(lambda (object) (eq class (class-of object))))
248 (defun make-eql-predicate (eql-object)
249 #'(lambda (object) (eql eql-object object)))
251 #|| ; The argument to satisfies must be a symbol.
252 (deftype class (&optional class)
254 `(satisfies ,(class-predicate class))
255 `(satisfies ,(class-predicate 'class))))
257 (deftype class-eq (class)
258 `(satisfies ,(make-class-eq-predicate class)))
261 ;;; internal to this file
263 ;;; These functions are a pale imitiation of their namesake. They accept
264 ;;; class objects or types where they should.
265 (defun *normalize-type (type)
267 (if (member (car type) '(not and or))
268 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
269 (if (null (cdr type))
270 (*normalize-type (car type))
273 (let ((class (find-class type nil)))
275 (let ((type (specializer-type class)))
276 (if (listp type) type `(,type)))
278 ((or (not (eq *boot-state* 'complete))
280 (specializer-type type))
282 (error "~S is not a type." type))))
286 (defun unparse-type-list (tlist)
287 (mapcar #'unparse-type tlist))
291 (defun unparse-type (type)
293 (if (specializerp type)
294 (unparse-type (specializer-type type))
298 (class-eq `(class-eq ,(class-name (cadr type))))
299 (class (class-name (cadr type)))
300 (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
302 ;;; internal to this file...
303 (defun convert-to-system-type (type)
305 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
307 ((class class-eq) ; class-eq is impossible to do right
308 (sb-kernel:layout-class (class-wrapper (cadr type))))
310 (t (if (null (cdr type))
316 (defun *typep (object type)
317 (setq type (*normalize-type type))
318 (cond ((member (car type) '(eql wrapper-eq class-eq class))
319 (specializer-applicable-using-type-p type `(eql ,object)))
320 ((eq (car type) 'not)
321 (not (*typep object (cadr type))))
323 (typep object (convert-to-system-type type)))))
325 ;;; Writing the missing NOT and AND clauses will improve
326 ;;; the quality of code generated by generate-discrimination-net, but
327 ;;; calling subtypep in place of just returning (values nil nil) can be
328 ;;; very slow. *SUBTYPEP is used by PCL itself, and must be fast.
329 (defun *subtypep (type1 type2)
330 (if (equal type1 type2)
332 (if (eq *boot-state* 'early)
333 (values (eq type1 type2) t)
334 (let ((*in-precompute-effective-methods-p* t))
335 (declare (special *in-precompute-effective-methods-p*))
336 ;; *in-precompute-effective-methods-p* is not a good name.
337 ;; It changes the way class-applicable-using-class-p works.
338 (setq type1 (*normalize-type type1))
339 (setq type2 (*normalize-type type2))
342 (values nil nil)) ; Should improve this.
344 (values nil nil)) ; Should improve this.
345 ((eql wrapper-eq class-eq class)
346 (multiple-value-bind (app-p maybe-app-p)
347 (specializer-applicable-using-type-p type2 type1)
348 (values app-p (or app-p (not maybe-app-p)))))
350 (subtypep (convert-to-system-type type1)
351 (convert-to-system-type type2))))))))
353 (defun do-satisfies-deftype (name predicate)
354 (declare (ignore name predicate)))
356 (defun make-type-predicate-name (name &optional kind)
357 (if (symbol-package name)
359 "~@[~A ~]TYPE-PREDICATE ~A ~A"
361 (package-name (symbol-package name))
364 (make-symbol (format nil
365 "~@[~A ~]TYPE-PREDICATE ~A"
367 (symbol-name name)))))
369 (defvar *built-in-class-symbols* ())
370 (defvar *built-in-wrapper-symbols* ())
372 (defun get-built-in-class-symbol (class-name)
373 (or (cadr (assq class-name *built-in-class-symbols*))
374 (let ((symbol (intern (format nil
376 (symbol-name class-name))
378 (push (list class-name symbol) *built-in-class-symbols*)
381 (defun get-built-in-wrapper-symbol (class-name)
382 (or (cadr (assq class-name *built-in-wrapper-symbols*))
383 (let ((symbol (intern (format nil
384 "*THE-WRAPPER-OF-~A*"
385 (symbol-name class-name))
387 (push (list class-name symbol) *built-in-wrapper-symbols*)
390 (pushnew 'class *variable-declarations*)
391 (pushnew 'variable-rebinding *variable-declarations*)
393 (defun variable-class (var env)
394 (caddr (variable-declaration 'class var env)))
396 (defvar *name->class->slotd-table* (make-hash-table))
398 ;;; This is used by combined methods to communicate the next methods to
399 ;;; the methods they call. This variable is captured by a lexical variable
400 ;;; of the methods to give it the proper lexical scope.
401 (defvar *next-methods* nil)
403 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
406 (defvar *umi-complete-classes*)
407 (defvar *umi-reorder*)
409 (defvar *invalidate-discriminating-function-force-p* ())
410 (defvar *invalid-dfuns-on-stack* ())
412 (defvar *standard-method-combination*)
414 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
416 (defmacro define-gf-predicate (predicate-name &rest classes)
418 (defmethod ,predicate-name ((x t)) nil)
419 ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
422 (defun make-class-predicate-name (name)
423 (intern (format nil "~A::~A class predicate"
424 (package-name (symbol-package name))
428 (defun plist-value (object name)
429 (getf (object-plist object) name))
431 (defun #-setf SETF\ SB-PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value
435 (setf (getf (object-plist object) name) new-value)
437 (remf (object-plist object) name)
440 ;;;; built-in classes
442 ;;; FIXME: This was the portable PCL way of setting up
443 ;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost
444 ;;; entirely wasted motion, since it's immediately overwritten by a
445 ;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However,
446 ;;; we can't just delete it, since the fifth element from each entry
447 ;;; (a prototype of the class) is still in the final result. It would
448 ;;; be nice to clean this up so that the other, never-used stuff is
449 ;;; gone, perhaps finding a tidier way to represent examples of each
452 ;;; FIXME: This can probably be blown away after bootstrapping.
453 ;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too..
455 (defvar *built-in-classes*
456 ;; name supers subs cdr of cpl
458 '(;(t () (number sequence array character symbol) ())
459 (number (t) (complex float rational) (t))
460 (complex (number) () (number t)
462 (float (number) () (number t)
464 (rational (number) (integer ratio) (number t))
465 (integer (rational) () (rational number t)
467 (ratio (rational) () (rational number t)
470 (sequence (t) (list vector) (t))
471 (list (sequence) (cons null) (sequence t))
472 (cons (list) () (list sequence t)
475 (array (t) (vector) (t)
478 sequence) (string bit-vector) (array sequence t)
480 (string (vector) () (vector array sequence t)
482 (bit-vector (vector) () (vector array sequence t)
484 (character (t) () (t)
487 (symbol (t) (null) (t)
490 list) () (symbol list sequence t)
494 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
495 ;;; SB-PCL:*BUILT-IN-CLASSES*.
496 (sb-int:/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
497 (defvar *built-in-classes*
498 (labels ((direct-supers (class)
499 (sb-int:/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
500 (if (typep class 'cl:built-in-class)
501 (sb-kernel:built-in-class-direct-superclasses class)
502 (let ((inherits (sb-kernel:layout-inherits
503 (sb-kernel:class-layout class))))
504 (sb-int:/show inherits)
505 (list (svref inherits (1- (length inherits)))))))
507 (sb-int:/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
508 (sb-int:collect ((res))
509 (let ((subs (sb-kernel:class-subclasses class)))
512 (sb-int:dohash (sub v subs)
515 (when (member class (direct-supers sub))
518 (prototype (class-name)
519 (let ((assoc (assoc class-name
520 '((complex . #c(1 1))
536 ;; This is the default prototype value which was
537 ;; used, without explanation, by the CMU CL code
538 ;; we're derived from. Evidently it's safe in all
541 (mapcar (lambda (kernel-bic-entry)
542 (sb-int:/show "setting up" kernel-bic-entry)
543 (let* ((name (car kernel-bic-entry))
544 (class (cl:find-class name)))
545 (sb-int:/show name class)
547 ,(mapcar #'cl:class-name (direct-supers class))
548 ,(mapcar #'cl:class-name (direct-subs class))
551 (cl:class-name (sb-kernel:layout-class x)))
553 (sb-kernel:layout-inherits
554 (sb-kernel:class-layout class))))
556 (remove-if (lambda (kernel-bic-entry)
557 (member (first kernel-bic-entry)
558 ;; I'm not sure why these are removed from
559 ;; the list, but that's what the original
560 ;; CMU CL code did. -- WHN 20000715
561 '(t sb-kernel:instance
562 sb-kernel:funcallable-instance
564 sb-kernel::*built-in-classes*))))
565 (sb-int:/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
567 ;;;; the classes that define the kernel of the metabraid
570 (:metaclass built-in-class))
572 (defclass sb-kernel:instance (t) ()
573 (:metaclass built-in-class))
575 (defclass function (t) ()
576 (:metaclass built-in-class))
578 (defclass sb-kernel:funcallable-instance (function) ()
579 (:metaclass built-in-class))
581 (defclass stream (t) ()
582 (:metaclass built-in-class))
584 (defclass slot-object (t) ()
585 (:metaclass slot-class))
587 (defclass structure-object (slot-object sb-kernel:instance) ()
588 (:metaclass structure-class))
590 (defstruct (dead-beef-structure-object
591 (:constructor |STRUCTURE-OBJECT class constructor|)))
593 (defclass std-object (slot-object) ()
594 (:metaclass std-class))
596 (defclass standard-object (std-object sb-kernel:instance) ())
598 (defclass funcallable-standard-object (std-object
599 sb-kernel:funcallable-instance)
601 (:metaclass funcallable-standard-class))
603 (defclass specializer (standard-object)
606 :reader specializer-type)))
608 (defclass definition-source-mixin (std-object)
610 :initform *load-truename*
611 :reader definition-source
612 :initarg :definition-source))
613 (:metaclass std-class))
615 (defclass plist-mixin (std-object)
618 :accessor object-plist))
619 (:metaclass std-class))
621 (defclass documentation-mixin (plist-mixin)
623 (:metaclass std-class))
625 (defclass dependent-update-mixin (plist-mixin)
627 (:metaclass std-class))
629 ;;; The class CLASS is a specified basic class. It is the common superclass
630 ;;; of any kind of class. That is any class that can be a metaclass must
631 ;;; have the class CLASS in its class precedence list.
632 (defclass class (documentation-mixin dependent-update-mixin
633 definition-source-mixin specializer)
637 :accessor class-name)
638 (class-eq-specializer
640 :reader class-eq-specializer)
643 :reader class-direct-superclasses)
646 :reader class-direct-subclasses)
648 :initform (cons nil nil))
651 :reader class-predicate-name)))
653 ;;; The class PCL-CLASS is an implementation-specific common superclass of
654 ;;; all specified subclasses of the class CLASS.
655 (defclass pcl-class (class)
656 ((class-precedence-list
657 :reader class-precedence-list)
660 :reader class-can-precede-list)
661 (incompatible-superclass-list
663 :accessor class-incompatible-superclass-list)
666 :reader class-wrapper)
669 :reader class-prototype)))
671 (defclass slot-class (pcl-class)
674 :accessor class-direct-slots)
677 :accessor class-slots)
680 :accessor class-initialize-info)))
682 ;;; The class STD-CLASS is an implementation-specific common superclass of
683 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
684 (defclass std-class (slot-class)
687 (defclass standard-class (std-class)
690 (defclass funcallable-standard-class (std-class)
693 (defclass forward-referenced-class (pcl-class) ())
695 (defclass built-in-class (pcl-class) ())
697 (defclass structure-class (slot-class)
700 :accessor class-defstruct-form)
701 (defstruct-constructor
703 :accessor class-defstruct-constructor)
706 :initarg :from-defclass-p)))
708 (defclass specializer-with-object (specializer) ())
710 (defclass exact-class-specializer (specializer) ())
712 (defclass class-eq-specializer (exact-class-specializer
713 specializer-with-object)
714 ((object :initarg :class
715 :reader specializer-class
716 :reader specializer-object)))
718 (defclass class-prototype-specializer (specializer-with-object)
719 ((object :initarg :class
720 :reader specializer-class
721 :reader specializer-object)))
723 (defclass eql-specializer (exact-class-specializer specializer-with-object)
724 ((object :initarg :object :reader specializer-object
725 :reader eql-specializer-object)))
727 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
729 (defun intern-eql-specializer (object)
730 (or (gethash object *eql-specializer-table*)
731 (setf (gethash object *eql-specializer-table*)
732 (make-instance 'eql-specializer :object object))))
734 ;;;; slot definitions
736 (defclass slot-definition (standard-object)
740 :accessor slot-definition-name)
744 :accessor slot-definition-initform)
747 :initarg :initfunction
748 :accessor slot-definition-initfunction)
752 :accessor slot-definition-readers)
756 :accessor slot-definition-writers)
760 :accessor slot-definition-initargs)
764 :accessor slot-definition-type)
767 :initarg :documentation)
771 :accessor slot-definition-class)))
773 (defclass standard-slot-definition (slot-definition)
777 :accessor slot-definition-allocation)))
779 (defclass structure-slot-definition (slot-definition)
780 ((defstruct-accessor-symbol
782 :initarg :defstruct-accessor-symbol
783 :accessor slot-definition-defstruct-accessor-symbol)
784 (internal-reader-function
786 :initarg :internal-reader-function
787 :accessor slot-definition-internal-reader-function)
788 (internal-writer-function
790 :initarg :internal-writer-function
791 :accessor slot-definition-internal-writer-function)))
793 (defclass direct-slot-definition (slot-definition)
796 (defclass effective-slot-definition (slot-definition)
797 ((reader-function ; #'(lambda (object) ...)
798 :accessor slot-definition-reader-function)
799 (writer-function ; #'(lambda (new-value object) ...)
800 :accessor slot-definition-writer-function)
801 (boundp-function ; #'(lambda (object) ...)
802 :accessor slot-definition-boundp-function)
806 (defclass standard-direct-slot-definition (standard-slot-definition
807 direct-slot-definition)
810 (defclass standard-effective-slot-definition (standard-slot-definition
811 effective-slot-definition)
812 ((location ; nil, a fixnum, a cons: (slot-name . value)
814 :accessor slot-definition-location)))
816 (defclass structure-direct-slot-definition (structure-slot-definition
817 direct-slot-definition)
820 (defclass structure-effective-slot-definition (structure-slot-definition
821 effective-slot-definition)
824 (defclass method (standard-object) ())
826 (defclass standard-method (definition-source-mixin plist-mixin method)
829 :accessor method-generic-function)
832 ; :initarg :qualifiers
833 ; :reader method-qualifiers)
836 :initarg :specializers
837 :reader method-specializers)
840 :initarg :lambda-list
841 :reader method-lambda-list)
844 :initarg :function) ;no writer
847 :initarg :fast-function ;no writer
848 :reader method-fast-function)
851 ; :initarg :documentation
852 ; :reader method-documentation)
855 (defclass standard-accessor-method (standard-method)
856 ((slot-name :initform nil
858 :reader accessor-method-slot-name)
859 (slot-definition :initform nil
860 :initarg :slot-definition
861 :reader accessor-method-slot-definition)))
863 (defclass standard-reader-method (standard-accessor-method) ())
865 (defclass standard-writer-method (standard-accessor-method) ())
867 (defclass standard-boundp-method (standard-accessor-method) ())
869 (defclass generic-function (dependent-update-mixin
870 definition-source-mixin
872 funcallable-standard-object)
874 (:metaclass funcallable-standard-class))
876 (defclass standard-generic-function (generic-function)
880 :accessor generic-function-name)
883 :accessor generic-function-methods
886 :initarg :method-class
887 :accessor generic-function-method-class)
889 :initarg :method-combination
890 :accessor generic-function-method-combination)
892 :initform (make-arg-info)
896 :accessor gf-dfun-state)
899 :accessor gf-pretty-arglist))
900 (:metaclass funcallable-standard-class)
901 (:default-initargs :method-class *the-class-standard-method*
902 :method-combination *standard-method-combination*))
904 (defclass method-combination (standard-object) ())
906 (defclass standard-method-combination
907 (definition-source-mixin method-combination)
908 ((type :reader method-combination-type
910 (documentation :reader method-combination-documentation
911 :initarg :documentation)
912 (options :reader method-combination-options
915 (defparameter *early-class-predicates*
916 '((specializer specializerp)
917 (exact-class-specializer exact-class-specializer-p)
918 (class-eq-specializer class-eq-specializer-p)
919 (eql-specializer eql-specializer-p)
921 (slot-class slot-class-p)
922 (std-class std-class-p)
923 (standard-class standard-class-p)
924 (funcallable-standard-class funcallable-standard-class-p)
925 (structure-class structure-class-p)
926 (forward-referenced-class forward-referenced-class-p)
928 (standard-method standard-method-p)
929 (standard-accessor-method standard-accessor-method-p)
930 (standard-reader-method standard-reader-method-p)
931 (standard-writer-method standard-writer-method-p)
932 (standard-boundp-method standard-boundp-method-p)
933 (generic-function generic-function-p)
934 (standard-generic-function standard-generic-function-p)
935 (method-combination method-combination-p)))