;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (eval-when (compile load eval) (defvar *defclass-times* '(load eval)) ;Probably have to change this ;if you use defconstructor. (defvar *defmethod-times* '(load eval)) (defvar *defgeneric-times* '(load eval)) ; defvar is now actually in macros ;(defvar *boot-state* ()) ;NIL ;EARLY ;BRAID ;COMPLETE (defvar *fegf-started-p* nil) ) (eval-when (load eval) (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.")) ) ;;; ;;; This is like fdefinition on the Lispm. If Common Lisp had something like ;;; function specs I wouldn't need this. On the other hand, I don't like the ;;; way this really works so maybe function specs aren't really right either? ;;; ;;; I also don't understand the real implications of a Lisp-1 on this sort of ;;; thing. Certainly some of the lossage in all of this is because these ;;; SPECs name global definitions. ;;; ;;; Note that this implementation is set up so that an implementation which ;;; has a 'real' function spec mechanism can use that instead and in that way ;;; get rid of setf generic function names. ;;; (defmacro parse-gspec (spec (non-setf-var . non-setf-case) (setf-var . setf-case)) (declare (indentation 1 1)) #+setf (declare (ignore setf-var setf-case)) (once-only (spec) `(cond (#-setf (symbolp ,spec) #+setf t (let ((,non-setf-var ,spec)) ,@non-setf-case)) #-setf ((and (listp ,spec) (eq (car ,spec) 'setf) (symbolp (cadr ,spec))) (let ((,setf-var (cadr ,spec))) ,@setf-case)) #-setf (t (error "Can't understand ~S as a generic function specifier.~%~ It must be either a symbol which can name a function or~%~ a list like ~S, where the car is the symbol ~S and the cadr~%~ is a symbol which can name a generic function." ,spec '(setf ) 'setf))))) ;;; ;;; 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. ;;; (defun unencapsulated-fdefinition (symbol) #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol)) #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol)) #+excl (or (excl::encapsulated-basic-definition symbol) (symbol-function symbol)) #+xerox (il:virginfn symbol) #+setf (fdefinition symbol) #+kcl (symbol-function (let ((sym (get symbol 'si::traced)) first-form) (if (and sym (consp (symbol-function symbol)) (consp (setq first-form (nth 3 (symbol-function symbol)))) (eq (car first-form) 'si::trace-call)) sym symbol))) #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol)) ;;; ;;; If symbol names a function which is traced or advised, redefine ;;; the `real' definition without affecting the advise. ;;; (defun fdefine-carefully (name new-definition) #+Lispm (si:fdefine name new-definition t t) #+Lucid (let ((lucid::*redefinition-action* nil)) (setf (symbol-function name) new-definition)) #+excl (setf (symbol-function name) new-definition) #+xerox (let ((advisedp (member name il:advisedfns :test #'eq)) (brokenp (member name il:brokenfns :test #'eq))) ;; In XeroxLisp (late of envos) tracing is implemented ;; as a special case of "breaking". Advising, however, ;; is treated specially. (xcl:unadvise-function name :no-error t) (xcl:unbreak-function name :no-error t) (setf (symbol-function name) new-definition) (when brokenp (xcl:rebreak-function name)) (when advisedp (xcl:readvise-function name))) #+(and setf (not cmu)) (setf (fdefinition name) new-definition) #+kcl (setf (symbol-function (let ((sym (get name 'si::traced)) first-form) (if (and sym (consp (symbol-function name)) (consp (setq first-form (nth 3 (symbol-function name)))) (eq (car first-form) 'si::trace-call)) sym name))) new-definition) #+cmu (progn (c::%%defun name new-definition nil) (c::note-name-defined name :function) new-definition) #-(or Lispm Lucid excl Xerox setf kcl cmu) (setf (symbol-function name) new-definition)) (defun gboundp (spec) (parse-gspec spec (name (fboundp name)) (name (fboundp (get-setf-function-name name))))) (defun gmakunbound (spec) (parse-gspec spec (name (fmakunbound name)) (name (fmakunbound (get-setf-function-name name))))) (defun gdefinition (spec) (parse-gspec spec (name (or #-setf (macro-function name) ;?? (unencapsulated-fdefinition name))) (name (unencapsulated-fdefinition (get-setf-function-name name))))) (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec) (parse-gspec spec (name (fdefine-carefully name new-value)) (name (fdefine-carefully (get-setf-function-name name) new-value)))) (proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* *the-class-null* *the-class-list* *the-class-integer* *the-class-float* *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* *the-class-array* *the-class-slot-object* *the-class-standard-object* *the-class-structure-object* *the-class-class* *the-class-generic-function* *the-class-built-in-class* *the-class-slot-class* *the-class-structure-class* *the-class-standard-class* *the-class-funcallable-standard-class* *the-class-method* *the-class-standard-method* *the-class-standard-reader-method* *the-class-standard-writer-method* *the-class-standard-boundp-method* *the-class-standard-generic-function* *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots* *the-eslotd-funcallable-standard-class-slots*)) (proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) ;;;; Type specifier hackery: ;;; 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 (defun specializer-from-type (type &aux args) (when (consp type) (setq args (cdr type) type (car type))) (cond ((symbolp type) (or (and (null args) (find-class type)) (ecase type (class (coerce-to-class (car args))) (prototype (make-instance 'class-prototype-specializer :object (coerce-to-class (car args)))) (class-eq (class-eq-specializer (coerce-to-class (car args)))) (eql (intern-eql-specializer (car args)))))) #+cmu17 ((and (null args) (typep type 'lisp:class)) (or (kernel:class-pcl-class type) (find-structure-class (lisp:class-name type)))) ((specializerp type) type))) ;;; interface (defun type-from-specializer (specl) (cond ((eq specl 't) 't) ((consp specl) (unless (member (car specl) '(class prototype class-eq eql)) (error "~S is not a legal specializer type" specl)) specl) ((progn (when (symbolp specl) ;;maybe (or (find-class specl nil) (ensure-class specl)) instead? (setq specl (find-class specl))) (or (not (eq *boot-state* 'complete)) (specializerp specl))) (specializer-type specl)) (t (error "~s is neither a type nor a specializer" specl)))) (defun type-class (type) (declare (special *the-class-t*)) (setq type (type-from-specializer type)) (if (atom type) (if (eq type 't) *the-class-t* (error "bad argument to type-class")) (case (car type) (eql (class-of (cadr type))) (prototype (class-of (cadr type))) ;? (class-eq (cadr type)) (class (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))) ||# #-(or excl cmu17) (deftype eql (type-object) `(member ,type-object)) ;;; Internal to this file. ;;; ;;; These functions are a pale imitiation of their namesake. They accept ;;; class objects or types where they should. ;;; (defun *normalize-type (type) (cond ((consp type) (if (member (car type) '(not and or)) `(,(car type) ,@(mapcar #'*normalize-type (cdr type))) (if (null (cdr type)) (*normalize-type (car type)) type))) ((symbolp type) (let ((class (find-class type nil))) (if class (let ((type (specializer-type class))) (if (listp type) type `(,type))) `(,type)))) ((or (not (eq *boot-state* 'complete)) (specializerp type)) (specializer-type 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 #-cmu17 (class-name (cadr type)) #+cmu17 (kernel:layout-class (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))))) ;;; *SUBTYPEP -- Interface ;;; ;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. (defun *subtypep (type1 type2) (if (equal type1 type2) (values t t) (if (eq *boot-state* 'early) (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. (setq type1 (*normalize-type type1)) (setq type2 (*normalize-type type2)) (case (car type2) (not (values nil nil)) ; Should improve this. (and (values nil nil)) ; Should improve this. ((eql wrapper-eq class-eq class) (multiple-value-bind (app-p maybe-app-p) (specializer-applicable-using-type-p type2 type1) (values app-p (or app-p (not maybe-app-p))))) (t (subtypep (convert-to-system-type type1) (convert-to-system-type type2)))))))) (defun do-satisfies-deftype (name predicate) #+cmu17 (declare (ignore name predicate)) #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral) (let* ((specifier `(satisfies ,predicate)) (expand-fn #'(lambda (&rest ignore) (declare (ignore ignore)) specifier))) ;; Specific ports can insert their own way of doing this. Many ;; ports may find the expand-fn defined above useful. ;; (or #+:Genera (setf (get name 'deftype) expand-fn) #+(and :Lucid (not :Prime)) (system::define-macro `(deftype ,name) expand-fn nil) #+ExCL (setf (get name 'excl::deftype-expander) expand-fn) #+:coral (setf (get name 'ccl::deftype-expander) expand-fn))) #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17) ;; This is the default for ports for which we don't know any ;; better. Note that for most ports, providing this definition ;; should just speed up class definition. It shouldn't have an ;; effect on performance of most user code. (eval `(deftype ,name () '(satisfies ,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)) *the-pcl-package*) (make-symbol (format nil "~@[~A ~]TYPE-PREDICATE ~A" kind (symbol-name name))))) (defvar *built-in-class-symbols* ()) (defvar *built-in-wrapper-symbols* ()) (defun get-built-in-class-symbol (class-name) (or (cadr (assq class-name *built-in-class-symbols*)) (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name)) *the-pcl-package*))) (push (list class-name symbol) *built-in-class-symbols*) symbol))) (defun get-built-in-wrapper-symbol (class-name) (or (cadr (assq class-name *built-in-wrapper-symbols*)) (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name)) *the-pcl-package*))) (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) (pushnew 'class *variable-declarations*) (pushnew 'variable-rebinding *variable-declarations*) (defun variable-class (var env) (caddr (variable-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*)) ;*** (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) *the-pcl-package*)) (defun plist-value (object name) (getf (object-plist object) name)) (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name) (if new-value (setf (getf (object-plist object) name) new-value) (progn (remf (object-plist object) name) nil))) (defvar *built-in-classes* ;; ;; name supers subs cdr of cpl ;; prototype '(;(t () (number sequence array character symbol) ()) (number (t) (complex float rational) (t)) (complex (number) () (number t) #c(1 1)) (float (number) () (number t) 1.0) (rational (number) (integer ratio) (number t)) (integer (rational) () (rational number t) 1) (ratio (rational) () (rational number t) 1/2) (sequence (t) (list vector) (t)) (list (sequence) (cons null) (sequence t)) (cons (list) () (list sequence t) (nil)) (array (t) (vector) (t) #2A((NIL))) (vector (array sequence) (string bit-vector) (array sequence t) #()) (string (vector) () (vector array sequence t) "") (bit-vector (vector) () (vector array sequence t) #*1) (character (t) () (t) #\c) (symbol (t) (null) (t) symbol) (null (symbol list) () (symbol list sequence t) nil))) #+cmu17 (labels ((direct-supers (class) (if (typep class 'lisp:built-in-class) (kernel:built-in-class-direct-superclasses class) (let ((inherits (kernel:layout-inherits (kernel:class-layout class)))) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) (ext:collect ((res)) (let ((subs (kernel:class-subclasses class))) (when subs (ext:do-hash (sub v subs) (declare (ignore v)) (when (member class (direct-supers sub)) (res sub))))) (res)))) (ext:collect ((res)) (dolist (bic kernel::built-in-classes) (let* ((name (car bic)) (class (lisp:find-class name))) (unless (member name '(t kernel:instance kernel:funcallable-instance function)) (res `(,name ,(mapcar #'lisp:class-name (direct-supers class)) ,(mapcar #'lisp:class-name (direct-subs class)) ,(map 'list #'(lambda (x) (lisp:class-name (kernel:layout-class x))) (reverse (kernel:layout-inherits (kernel:class-layout class)))) ,(let ((found (assoc name *built-in-classes*))) (if found (fifth found) 42))))))) (setq *built-in-classes* (res)))) ;;; ;;; The classes that define the kernel of the metabraid. ;;; (defclass t () () (:metaclass built-in-class)) #+cmu17 (progn (defclass kernel:instance (t) () (:metaclass built-in-class)) (defclass function (t) () (:metaclass built-in-class)) (defclass kernel:funcallable-instance (function) () (:metaclass built-in-class))) (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () (:metaclass slot-class)) (defclass structure-object (slot-object) () (:metaclass structure-class)) (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object (:constructor |STRUCTURE-OBJECT class constructor|))) (defclass standard-object (slot-object) ()) (defclass metaobject (standard-object) ()) (defclass specializer (metaobject) ((type :initform nil :reader specializer-type))) (defclass definition-source-mixin (standard-object) ((source :initform (load-truename) :reader definition-source :initarg :definition-source))) (defclass plist-mixin (standard-object) ((plist :initform () :accessor object-plist))) (defclass documentation-mixin (plist-mixin) ()) (defclass dependent-update-mixin (plist-mixin) ()) ;;; ;;; 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. ;;; (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))) (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. ;;; (defclass std-class (slot-class) ()) (defclass standard-class (std-class) ()) (defclass funcallable-standard-class (std-class) ()) (defclass forward-referenced-class (pcl-class) ()) (defclass built-in-class (pcl-class) ()) (defclass structure-class (slot-class) ((defstruct-form :initform () :accessor class-defstruct-form) (defstruct-constructor :initform nil :accessor class-defstruct-constructor) (from-defclass-p :initform nil :initarg :from-defclass-p))) (defclass specializer-with-object (specializer) ()) (defclass exact-class-specializer (specializer) ()) (defclass class-eq-specializer (exact-class-specializer specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) (defclass class-prototype-specializer (specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) (defclass eql-specializer (exact-class-specializer specializer-with-object) ((object :initarg :object :reader specializer-object :reader eql-specializer-object))) (defvar *eql-specializer-table* (make-hash-table :test 'eql)) (defun intern-eql-specializer (object) (or (gethash object *eql-specializer-table*) (setf (gethash object *eql-specializer-table*) (make-instance 'eql-specializer :object object)))) ;;; ;;; Slot definitions. ;;; (defclass slot-definition (metaobject) ((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))) (defclass structure-slot-definition (slot-definition) ((defstruct-accessor-symbol :initform nil :initarg :defstruct-accessor-symbol :accessor slot-definition-defstruct-accessor-symbol) (internal-reader-function :initform nil :initarg :internal-reader-function :accessor slot-definition-internal-reader-function) (internal-writer-function :initform nil :initarg :internal-writer-function :accessor slot-definition-internal-writer-function))) (defclass direct-slot-definition (slot-definition) ()) (defclass effective-slot-definition (slot-definition) ((reader-function ; #'(lambda (object) ...) :accessor slot-definition-reader-function) (writer-function ; #'(lambda (new-value object) ...) :accessor slot-definition-writer-function) (boundp-function ; #'(lambda (object) ...) :accessor slot-definition-boundp-function) (accessor-flags :initform 0))) (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) ()) (defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) ((location ; nil, a fixnum, a cons: (slot-name . value) :initform nil :accessor slot-definition-location))) (defclass structure-direct-slot-definition (structure-slot-definition direct-slot-definition) ()) (defclass structure-effective-slot-definition (structure-slot-definition effective-slot-definition) ()) (defclass method (metaobject) ()) (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) )) (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))) (defclass standard-reader-method (standard-accessor-method) ()) (defclass standard-writer-method (standard-accessor-method) ()) (defclass standard-boundp-method (standard-accessor-method) ()) (defclass generic-function (dependent-update-mixin definition-source-mixin documentation-mixin metaobject #+cmu17 kernel:funcallable-instance) () (: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) (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) ) (:metaclass funcallable-standard-class) (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) (defclass method-combination (metaobject) ()) (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))) (defparameter *early-class-predicates* '((specializer specializerp) (exact-class-specializer exact-class-specializer-p) (class-eq-specializer class-eq-specializer-p) (eql-specializer eql-specializer-p) (class classp) (slot-class slot-class-p) (standard-class standard-class-p) (funcallable-standard-class funcallable-standard-class-p) (structure-class structure-class-p) (forward-referenced-class forward-referenced-class-p) (method method-p) (standard-method standard-method-p) (standard-accessor-method standard-accessor-method-p) (standard-reader-method standard-reader-method-p) (standard-writer-method standard-writer-method-p) (standard-boundp-method standard-boundp-method-p) (generic-function generic-function-p) (standard-generic-function standard-generic-function-p) (method-combination method-combination-p)))