(in-package "SB-PCL")
\f
-
-(eval-when (:load-toplevel :execute)
- (when (eq *boot-state* 'complete)
- (error "Trying to load (or compile) PCL in an environment in which it~%~
- has already been loaded. This doesn't work, you will have to~%~
- get a fresh lisp (reboot) and then load PCL."))
- (when *boot-state*
- (cerror "Try loading (or compiling) PCL anyways."
- "Trying to load (or compile) PCL in an environment in which it~%~
- has already been partially loaded. This may not work, you may~%~
- need to get a fresh lisp (reboot) and then load PCL."))
- ) ; EVAL-WHEN
+;;; (These are left over from the days when PCL was an add-on package
+;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal
+;;; build, of course, but they might happen if someone is experimenting
+;;; and debugging, and it's probably worth complaining if they do,
+;;; so we've left 'em in.)
+(when (eq *boot-state* 'complete)
+ (error "Trying to load (or compile) PCL in an environment in which it~%~
+ has already been loaded. This doesn't work, you will have to~%~
+ get a fresh lisp (reboot) and then load PCL."))
+(when *boot-state*
+ (cerror "Try loading (or compiling) PCL anyways."
+ "Trying to load (or compile) PCL in an environment in which it~%~
+ has already been partially loaded. This may not work, you may~%~
+ need to get a fresh lisp (reboot) and then load PCL."))
\f
;;; comments from CMU CL version of PCL:
;;; This is like fdefinition on the Lispm. If Common Lisp had
(non-setf-var . non-setf-case))
`(let ((,non-setf-var ,spec)) ,@non-setf-case))
-;;; If symbol names a function which is traced or advised, return the
-;;; unadvised, traced etc. definition. This lets me get at the generic
-;;; function object even when it is traced.
+;;; If symbol names a function which is traced, return the untraced
+;;; definition. This lets us get at the generic function object even
+;;; when it is traced.
(defun unencapsulated-fdefinition (symbol)
(fdefinition symbol))
-;;; If symbol names a function which is traced or advised, redefine
-;;; the `real' definition without affecting the advise.
+;;; If symbol names a function which is traced, redefine the `real'
+;;; definition without affecting the trace.
(defun fdefine-carefully (name new-definition)
(progn
- (sb-c::%%defun name new-definition nil)
(sb-c::note-name-defined name :function)
new-definition)
(setf (fdefinition name) new-definition))
\f
;;;; type specifier hackery
-;;; internal to this file.
+;;; internal to this file
(defun coerce-to-class (class &optional make-forward-referenced-class-p)
(if (symbolp class)
(or (find-class class (not make-forward-referenced-class-p))
(ensure-class class))
class))
-;;; Interface
+;;; interface
(defun specializer-from-type (type &aux args)
(when (consp type)
(setq args (cdr type) type (car type)))
:object (coerce-to-class (car args))))
(class-eq (class-eq-specializer (coerce-to-class (car args))))
(eql (intern-eql-specializer (car args))))))
- ((and (null args) (typep type 'cl:class))
- (or (sb-kernel:class-pcl-class type)
- (find-structure-class (cl:class-name type))))
+ ;; FIXME: do we still need this?
+ ((and (null args) (typep type 'sb-kernel:classoid))
+ (or (sb-kernel:classoid-pcl-class type)
+ (find-structure-class (sb-kernel:classoid-name type))))
((specializerp type) type)))
;;; interface
(if (atom type)
(if (eq type t)
*the-class-t*
- (error "bad argument to type-class"))
+ (error "bad argument to TYPE-CLASS"))
(case (car type)
(eql (class-of (cadr type)))
(prototype (class-of (cadr type))) ;?
(defun class-eq-type (class)
(specializer-type (class-eq-specializer class)))
-(defun inform-type-system-about-std-class (name)
- (let ((predicate-name (make-type-predicate-name name)))
- (setf (gdefinition predicate-name)
- (make-type-predicate name))
- (do-satisfies-deftype name predicate-name)))
-
-(defun make-type-predicate (name)
- (let ((cell (find-class-cell name)))
- #'(lambda (x)
- (funcall (the function (find-class-cell-predicate cell)) x))))
-
-;This stuff isn't right. Good thing it isn't used.
-;The satisfies predicate has to be a symbol. There is no way to
-;construct such a symbol from a class object if class names change.
-(defun class-predicate (class)
- (when (symbolp class) (setq class (find-class class)))
- #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
-
-(defun make-class-eq-predicate (class)
- (when (symbolp class) (setq class (find-class class)))
- #'(lambda (object) (eq class (class-of object))))
-
-(defun make-eql-predicate (eql-object)
- #'(lambda (object) (eql eql-object object)))
-
-#|| ; The argument to satisfies must be a symbol.
-(deftype class (&optional class)
- (if class
- `(satisfies ,(class-predicate class))
- `(satisfies ,(class-predicate 'class))))
-
-(deftype class-eq (class)
- `(satisfies ,(make-class-eq-predicate class)))
-||#
-
-;;; internal to this file
+;;; internal to this file..
;;;
-;;; These functions are a pale imitiation of their namesake. They accept
+;;; These functions are a pale imitation of their namesake. They accept
;;; class objects or types where they should.
(defun *normalize-type (type)
(cond ((consp type)
(t
(error "~S is not a type." type))))
-;;; Not used...
-#+nil
-(defun unparse-type-list (tlist)
- (mapcar #'unparse-type tlist))
-
-;;; Not used...
-#+nil
-(defun unparse-type (type)
- (if (atom type)
- (if (specializerp type)
- (unparse-type (specializer-type type))
- type)
- (case (car type)
- (eql type)
- (class-eq `(class-eq ,(class-name (cadr type))))
- (class (class-name (cadr type)))
- (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
-
;;; internal to this file...
(defun convert-to-system-type (type)
(case (car type)
((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
(cdr type))))
((class class-eq) ; class-eq is impossible to do right
- (sb-kernel:layout-class (class-wrapper (cadr type))))
+ (sb-kernel:layout-classoid (class-wrapper (cadr type))))
(eql type)
(t (if (null (cdr type))
(car type)
type))))
-;;; not used...
-#+nil
-(defun *typep (object type)
- (setq type (*normalize-type type))
- (cond ((member (car type) '(eql wrapper-eq class-eq class))
- (specializer-applicable-using-type-p type `(eql ,object)))
- ((eq (car type) 'not)
- (not (*typep object (cadr type))))
- (t
- (typep object (convert-to-system-type type)))))
-
-;;; Writing the missing NOT and AND clauses will improve
-;;; the quality of code generated by generate-discrimination-net, but
-;;; calling subtypep in place of just returning (values nil nil) can be
-;;; very slow. *SUBTYPEP is used by PCL itself, and must be fast.
+;;; Writing the missing NOT and AND clauses will improve the quality
+;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
+;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
+;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
+;;;
+;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
+;;; in the compiler. Could we share some of it here?
(defun *subtypep (type1 type2)
(if (equal type1 type2)
(values t t)
(values (eq type1 type2) t)
(let ((*in-precompute-effective-methods-p* t))
(declare (special *in-precompute-effective-methods-p*))
- ;; *in-precompute-effective-methods-p* is not a good name.
- ;; It changes the way class-applicable-using-class-p works.
+ ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
+ ;; good name. It changes the way
+ ;; CLASS-APPLICABLE-USING-CLASS-P works.
(setq type1 (*normalize-type type1))
(setq type2 (*normalize-type type2))
(case (car type2)
(not
- (values nil nil)) ; Should improve this.
+ (values nil nil)) ; XXX We should improve this.
(and
- (values nil nil)) ; Should improve this.
+ (values nil nil)) ; XXX We should improve this.
((eql wrapper-eq class-eq class)
(multiple-value-bind (app-p maybe-app-p)
(specializer-applicable-using-type-p type2 type1)
(t
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2))))))))
-
-(defun do-satisfies-deftype (name predicate)
- (declare (ignore name predicate)))
-
-(defun make-type-predicate-name (name &optional kind)
- (if (symbol-package name)
- (intern (format nil
- "~@[~A ~]TYPE-PREDICATE ~A ~A"
- kind
- (package-name (symbol-package name))
- (symbol-name name))
- *pcl-package*)
- (make-symbol (format nil
- "~@[~A ~]TYPE-PREDICATE ~A"
- kind
- (symbol-name name)))))
\f
(defvar *built-in-class-symbols* ())
(defvar *built-in-wrapper-symbols* ())
(push (list class-name symbol) *built-in-wrapper-symbols*)
symbol)))
\f
-(pushnew '%class *variable-declarations*)
-(pushnew '%variable-rebinding *variable-declarations*)
+(pushnew '%class *var-declarations*)
+(pushnew '%variable-rebinding *var-declarations*)
(defun variable-class (var env)
- (caddr (variable-declaration 'class var env)))
+ (caddr (var-declaration 'class var env)))
(defvar *name->class->slotd-table* (make-hash-table))
-;;; This is used by combined methods to communicate the next methods
-;;; to the methods they call. This variable is captured by a lexical
-;;; variable of the methods to give it the proper lexical scope.
-(defvar *next-methods* nil)
-
-(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
-
-(defvar *umi-gfs*)
-(defvar *umi-complete-classes*)
-(defvar *umi-reorder*)
-
-(defvar *invalidate-discriminating-function-force-p* ())
-(defvar *invalid-dfuns-on-stack* ())
-
(defvar *standard-method-combination*)
-
-(defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
\f
-(defmacro define-gf-predicate (predicate-name &rest classes)
- `(progn
- (defmethod ,predicate-name ((x t)) nil)
- ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
- classes)))
-
(defun make-class-predicate-name (name)
- (intern (format nil "~A::~A class predicate"
- (package-name (symbol-package name))
- name)
- *pcl-package*))
-
+ (list 'class-predicate name))
+
(defun plist-value (object name)
(getf (object-plist object) name))
;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
;;; SB-PCL:*BUILT-IN-CLASSES*.
-(sb-int:/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
+(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
- (sb-int:/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
- (if (typep class 'cl:built-in-class)
- (sb-kernel:built-in-class-direct-superclasses class)
+ (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class))
+ (if (typep class 'sb-kernel:built-in-classoid)
+ (sb-kernel:built-in-classoid-direct-superclasses class)
(let ((inherits (sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
- (sb-int:/show inherits)
+ (sb-kernel:classoid-layout class))))
+ (/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
- (sb-int:/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
- (sb-int:collect ((res))
- (let ((subs (sb-kernel:class-subclasses class)))
- (sb-int:/show subs)
+ (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (collect ((res))
+ (let ((subs (sb-kernel:classoid-subclasses class)))
+ (/noshow subs)
(when subs
- (sb-int:dohash (sub v subs)
+ (dohash (sub v subs)
(declare (ignore v))
- (sb-int:/show sub)
+ (/noshow sub)
(when (member class (direct-supers sub))
(res sub)))))
(res)))
;; relevant cases.
42))))
(mapcar (lambda (kernel-bic-entry)
- (sb-int:/show "setting up" kernel-bic-entry)
+ (/noshow "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
- (class (cl:find-class name)))
- (sb-int:/show name class)
+ (class (sb-kernel:find-classoid name)))
+ (/noshow name class)
`(,name
- ,(mapcar #'cl:class-name (direct-supers class))
- ,(mapcar #'cl:class-name (direct-subs class))
+ ,(mapcar #'sb-kernel:classoid-name (direct-supers class))
+ ,(mapcar #'sb-kernel:classoid-name (direct-subs class))
,(map 'list
(lambda (x)
- (cl:class-name (sb-kernel:layout-class x)))
+ (sb-kernel:classoid-name
+ (sb-kernel:layout-classoid x)))
(reverse
(sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
+ (sb-kernel:classoid-layout class))))
,(prototype name))))
(remove-if (lambda (kernel-bic-entry)
(member (first kernel-bic-entry)
sb-kernel:funcallable-instance
function stream)))
sb-kernel::*built-in-classes*))))
-(sb-int:/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
+(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
\f
;;;; the classes that define the kernel of the metabraid
(defclass sb-kernel:funcallable-instance (function) ()
(:metaclass built-in-class))
-(defclass stream (t) ()
+(defclass stream (sb-kernel:instance) ()
(:metaclass built-in-class))
(defclass slot-object (t) ()
(:metaclass structure-class))
(defstruct (dead-beef-structure-object
- (:constructor |STRUCTURE-OBJECT class constructor|)))
+ (:constructor |STRUCTURE-OBJECT class constructor|)
+ (:copier nil)))
(defclass std-object (slot-object) ()
(:metaclass std-class))
(defclass funcallable-standard-object (std-object
sb-kernel:funcallable-instance)
- ()
+ ()
(:metaclass funcallable-standard-class))
(defclass specializer (standard-object)
- ((type
- :initform nil
- :reader specializer-type)))
+ ((type
+ :initform nil
+ :reader specializer-type)))
(defclass definition-source-mixin (std-object)
- ((source
- :initform *load-truename*
- :reader definition-source
- :initarg :definition-source))
+ ((source
+ :initform *load-pathname*
+ :reader definition-source
+ :initarg :definition-source))
(:metaclass std-class))
(defclass plist-mixin (std-object)
- ((plist
- :initform ()
- :accessor object-plist))
+ ((plist
+ :initform ()
+ :accessor object-plist))
(:metaclass std-class))
(defclass documentation-mixin (plist-mixin)
- ()
+ ()
(:metaclass std-class))
(defclass dependent-update-mixin (plist-mixin)
- ()
+ ()
(:metaclass std-class))
-;;; The class CLASS is a specified basic class. It is the common superclass
-;;; of any kind of class. That is any class that can be a metaclass must
-;;; have the class CLASS in its class precedence list.
-(defclass class (documentation-mixin dependent-update-mixin
- definition-source-mixin specializer)
- ((name
- :initform nil
- :initarg :name
- :accessor class-name)
- (class-eq-specializer
- :initform nil
- :reader class-eq-specializer)
- (direct-superclasses
- :initform ()
- :reader class-direct-superclasses)
- (direct-subclasses
- :initform ()
- :reader class-direct-subclasses)
- (direct-methods
- :initform (cons nil nil))
- (predicate-name
- :initform nil
- :reader class-predicate-name)))
-
-;;; The class PCL-CLASS is an implementation-specific common superclass of
-;;; all specified subclasses of the class CLASS.
+;;; The class CLASS is a specified basic class. It is the common
+;;; superclass of any kind of class. That is, any class that can be a
+;;; metaclass must have the class CLASS in its class precedence list.
+(defclass class (documentation-mixin
+ dependent-update-mixin
+ definition-source-mixin
+ specializer)
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor class-name)
+ (class-eq-specializer
+ :initform nil
+ :reader class-eq-specializer)
+ (direct-superclasses
+ :initform ()
+ :reader class-direct-superclasses)
+ ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
+ ;; CONDITION-CLASSes are lazily computed whenever the subclass info
+ ;; becomes available, i.e. when the PCL class is created.
+ (direct-subclasses
+ :initform ()
+ :reader class-direct-subclasses)
+ (direct-methods
+ :initform (cons nil nil))
+ (predicate-name
+ :initform nil
+ :reader class-predicate-name)))
+
+;;; The class PCL-CLASS is an implementation-specific common
+;;; superclass of all specified subclasses of the class CLASS.
(defclass pcl-class (class)
- ((class-precedence-list
- :reader class-precedence-list)
- (can-precede-list
- :initform ()
- :reader class-can-precede-list)
- (incompatible-superclass-list
- :initform ()
- :accessor class-incompatible-superclass-list)
- (wrapper
- :initform nil
- :reader class-wrapper)
- (prototype
- :initform nil
- :reader class-prototype)))
+ ((class-precedence-list
+ :reader class-precedence-list)
+ (can-precede-list
+ :initform ()
+ :reader class-can-precede-list)
+ (incompatible-superclass-list
+ :initform ()
+ :accessor class-incompatible-superclass-list)
+ (wrapper
+ :initform nil
+ :reader class-wrapper)
+ (prototype
+ :initform nil
+ :reader class-prototype)))
(defclass slot-class (pcl-class)
- ((direct-slots
- :initform ()
- :accessor class-direct-slots)
- (slots
- :initform ()
- :accessor class-slots)
- (initialize-info
- :initform nil
- :accessor class-initialize-info)))
-
-;;; The class STD-CLASS is an implementation-specific common superclass of
-;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
+ ((direct-slots
+ :initform ()
+ :accessor class-direct-slots)
+ (slots
+ :initform ()
+ :accessor class-slots)
+ (initialize-info
+ :initform nil
+ :accessor class-initialize-info)))
+
+;;; The class STD-CLASS is an implementation-specific common
+;;; superclass of the classes STANDARD-CLASS and
+;;; FUNCALLABLE-STANDARD-CLASS.
(defclass std-class (slot-class)
())
;;;; slot definitions
(defclass slot-definition (standard-object)
- ((name
- :initform nil
- :initarg :name
- :accessor slot-definition-name)
- (initform
- :initform nil
- :initarg :initform
- :accessor slot-definition-initform)
- (initfunction
- :initform nil
- :initarg :initfunction
- :accessor slot-definition-initfunction)
- (readers
- :initform nil
- :initarg :readers
- :accessor slot-definition-readers)
- (writers
- :initform nil
- :initarg :writers
- :accessor slot-definition-writers)
- (initargs
- :initform nil
- :initarg :initargs
- :accessor slot-definition-initargs)
- (type
- :initform t
- :initarg :type
- :accessor slot-definition-type)
- (documentation
- :initform ""
- :initarg :documentation)
- (class
- :initform nil
- :initarg :class
- :accessor slot-definition-class)))
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor slot-definition-name)
+ (initform
+ :initform nil
+ :initarg :initform
+ :accessor slot-definition-initform)
+ (initfunction
+ :initform nil
+ :initarg :initfunction
+ :accessor slot-definition-initfunction)
+ (readers
+ :initform nil
+ :initarg :readers
+ :accessor slot-definition-readers)
+ (writers
+ :initform nil
+ :initarg :writers
+ :accessor slot-definition-writers)
+ (initargs
+ :initform nil
+ :initarg :initargs
+ :accessor slot-definition-initargs)
+ (type
+ :initform t
+ :initarg :type
+ :accessor slot-definition-type)
+ (documentation
+ :initform ""
+ :initarg :documentation)
+ (class
+ :initform nil
+ :initarg :class
+ :accessor slot-definition-class)))
(defclass standard-slot-definition (slot-definition)
((allocation
:initform :instance
:initarg :allocation
- :accessor slot-definition-allocation)))
+ :accessor slot-definition-allocation)
+ (allocation-class
+ :initform nil
+ :initarg :allocation-class
+ :accessor slot-definition-allocation-class)))
(defclass structure-slot-definition (slot-definition)
((defstruct-accessor-symbol
())
(defclass effective-slot-definition (slot-definition)
- ((reader-function ; #'(lambda (object) ...)
+ ((reader-function ; (lambda (object) ...)
:accessor slot-definition-reader-function)
- (writer-function ; #'(lambda (new-value object) ...)
+ (writer-function ; (lambda (new-value object) ...)
:accessor slot-definition-writer-function)
- (boundp-function ; #'(lambda (object) ...)
+ (boundp-function ; (lambda (object) ...)
:accessor slot-definition-boundp-function)
(accessor-flags
:initform 0)))
(defclass method (standard-object) ())
(defclass standard-method (definition-source-mixin plist-mixin method)
- ((generic-function
- :initform nil
- :accessor method-generic-function)
-; (qualifiers
-; :initform ()
-; :initarg :qualifiers
-; :reader method-qualifiers)
- (specializers
- :initform ()
- :initarg :specializers
- :reader method-specializers)
- (lambda-list
- :initform ()
- :initarg :lambda-list
- :reader method-lambda-list)
- (function
- :initform nil
- :initarg :function) ;no writer
- (fast-function
- :initform nil
- :initarg :fast-function ;no writer
- :reader method-fast-function)
-; (documentation
-; :initform nil
-; :initarg :documentation
-; :reader method-documentation)
- ))
+ ((generic-function
+ :initform nil
+ :accessor method-generic-function)
+;;; (qualifiers
+;;; :initform ()
+;;; :initarg :qualifiers
+;;; :reader method-qualifiers)
+ (specializers
+ :initform ()
+ :initarg :specializers
+ :reader method-specializers)
+ (lambda-list
+ :initform ()
+ :initarg :lambda-list
+ :reader method-lambda-list)
+ (function
+ :initform nil
+ :initarg :function) ;no writer
+ (fast-function
+ :initform nil
+ :initarg :fast-function ;no writer
+ :reader method-fast-function)
+;;; (documentation
+;;; :initform nil
+;;; :initarg :documentation
+;;; :reader method-documentation)
+ ))
(defclass standard-accessor-method (standard-method)
- ((slot-name :initform nil
- :initarg :slot-name
- :reader accessor-method-slot-name)
- (slot-definition :initform nil
- :initarg :slot-definition
- :reader accessor-method-slot-definition)))
+ ((slot-name :initform nil
+ :initarg :slot-name
+ :reader accessor-method-slot-name)
+ (slot-definition :initform nil
+ :initarg :slot-definition
+ :reader accessor-method-slot-definition)))
(defclass standard-reader-method (standard-accessor-method) ())
definition-source-mixin
documentation-mixin
funcallable-standard-object)
- ()
+ (;; We need to make a distinction between the methods initially set
+ ;; up by :METHOD options to DEFGENERIC and the ones set up later by
+ ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
+ ;; an already-DEFGENERICed function clears the methods set by the
+ ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
+ ;; this distinction seems a little kludgy, but it has the positive
+ ;; effect of making it so that loading a file a.lisp containing
+ ;; DEFGENERIC, then loading a second file b.lisp containing
+ ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
+ ;; tends to leave the generic function in a state consistent with
+ ;; the most-recently-loaded state of a.lisp and b.lisp.)
+ (initial-methods
+ :initform ()
+ :accessor generic-function-initial-methods))
(:metaclass funcallable-standard-class))
(defclass standard-generic-function (generic-function)
- ((name
- :initform nil
- :initarg :name
- :accessor generic-function-name)
- (methods
- :initform ()
- :accessor generic-function-methods
- :type list)
- (method-class
- :initarg :method-class
- :accessor generic-function-method-class)
- (method-combination
- :initarg :method-combination
- :accessor generic-function-method-combination)
- (arg-info
- :initform (make-arg-info)
- :reader gf-arg-info)
- (dfun-state
- :initform ()
- :accessor gf-dfun-state)
- (pretty-arglist
- :initform ()
- :accessor gf-pretty-arglist))
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor generic-function-name)
+ (methods
+ :initform ()
+ :accessor generic-function-methods
+ :type list)
+ (method-class
+ :initarg :method-class
+ :accessor generic-function-method-class)
+ (method-combination
+ :initarg :method-combination
+ :accessor generic-function-method-combination)
+ (declarations
+ :initarg :declarations
+ :initform ()
+ :accessor generic-function-declarations)
+ (arg-info
+ :initform (make-arg-info)
+ :reader gf-arg-info)
+ (dfun-state
+ :initform ()
+ :accessor gf-dfun-state))
(:metaclass funcallable-standard-class)
(:default-initargs :method-class *the-class-standard-method*
:method-combination *standard-method-combination*))
(defclass method-combination (standard-object) ())
-(defclass standard-method-combination
- (definition-source-mixin method-combination)
- ((type :reader method-combination-type
- :initarg :type)
- (documentation :reader method-combination-documentation
- :initarg :documentation)
- (options :reader method-combination-options
- :initarg :options)))
+(defclass standard-method-combination (definition-source-mixin
+ method-combination)
+ ((type
+ :reader method-combination-type
+ :initarg :type)
+ (documentation
+ :reader method-combination-documentation
+ :initarg :documentation)
+ (options
+ :reader method-combination-options
+ :initarg :options)))
+
+(defclass long-method-combination (standard-method-combination)
+ ((function
+ :initarg :function
+ :reader long-method-combination-function)
+ (args-lambda-list
+ :initarg :args-lambda-list
+ :reader long-method-combination-args-lambda-list)))
(defparameter *early-class-predicates*
'((specializer specializerp)
(standard-boundp-method standard-boundp-method-p)
(generic-function generic-function-p)
(standard-generic-function standard-generic-function-p)
- (method-combination method-combination-p)))
+ (method-combination method-combination-p)
+ (long-method-combination long-method-combination-p)))
projects / sbcl.git / blobdiff