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

Diff of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.1 by ram, Sat Oct 19 16:44:34 1991 UTC revision 1.45 by rtoy, Fri Mar 19 15:19:03 2010 UTC
# Line 1  Line 1 
1  ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-  ;;;-*-Mode:LISP; Package:PCL  -*-
2  ;;;  ;;;
3  ;;; *************************************************************************  ;;; *************************************************************************
4  ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.  ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
# Line 23  Line 23 
23  ;;;  ;;;
24  ;;; Suggestions, comments and requests for improvements are also welcome.  ;;; Suggestions, comments and requests for improvements are also welcome.
25  ;;; *************************************************************************  ;;; *************************************************************************
 ;;;  
   
 (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))  
   
 )  
26    
27    (in-package :pcl)
28  ;;;  (intl:textdomain "cmucl")
 ;;; Convert a function name to its standard setf function name.  We have to  
 ;;; do this hack because not all Common Lisps have yet converted to having  
 ;;; setf function specs.  
 ;;;  
 ;;; In a port that does have setf function specs you can use those just by  
 ;;; making the obvious simple changes to these functions.  The rest of PCL  
 ;;; believes that there are function names like (SETF <foo>), this is the  
 ;;; only place that knows about this hack.  
 ;;;  
 (eval-when (compile load eval)  
   
 (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))  
   
 (defun get-setf-function-name (name)  
   (or (gethash name *setf-function-names*)  
       (setf (gethash name *setf-function-names*)  
             (intern (format nil  
                             "SETF ~A ~A"  
                             (package-name (symbol-package name))  
                             (symbol-name name))  
                     *the-pcl-package*))))  
   
 ;;;  
 ;;; Call this to define a setf macro for a function with the same behavior as  
 ;;; specified by the SETF function cleanup proposal.  Specifically, this will  
 ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).  
 ;;;  
 ;;; do-standard-defsetf                  A macro interface for use at top level  
 ;;;                                      in files.  Unfortunately, users may  
 ;;;                                      have to use this for a while.  
 ;;;  
 ;;; do-standard-defsetfs-for-defclass    A special version called by defclass.  
 ;;;  
 ;;; do-standard-defsetf-1                A functional interface called by the  
 ;;;                                      above, defmethod and defgeneric.  
 ;;;                                      Since this is all a crock anyways,  
 ;;;                                      users are free to call this as well.  
 ;;;  
 (defmacro do-standard-defsetf (&rest function-names)  
   `(eval-when (compile load eval)  
      (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))  
   
 (defun do-standard-defsetfs-for-defclass (accessors)  
   (dolist (name accessors) (do-standard-defsetf-1 name)))  
   
 (defun do-standard-defsetf-1 (function-name)  
   (unless (setfboundp function-name)  
     (let* ((setf-function-name (get-setf-function-name function-name)))  
   
       #+Genera  
       (let ((fn #'(lambda (form)  
                     (lt::help-defsetf  
                       '(&rest accessor-args) '(new-value) function-name 'nil  
                       `(`(,',setf-function-name ,new-value .,accessor-args))  
                       form))))  
         (setf (get function-name 'lt::setf-method) fn  
               (get function-name 'lt::setf-method-internal) fn))  
   
       #+Lucid  
       (lucid::set-simple-setf-method  
         function-name  
         #'(lambda (form new-value)  
             (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))  
                                      (cdr form)))  
                    (vars (mapcar #'car bindings)))  
               ;; This may wrap spurious LET bindings around some form,  
               ;;   but the PQC compiler will unwrap then.  
               `(LET (,.bindings)  
                  (,setf-function-name ,new-value . ,vars)))))  
   
       #+kcl  
       (let ((helper (gensym)))  
         (setf (macro-function helper)  
               #'(lambda (form env)  
                   (declare (ignore env))  
                   (let* ((loc-args (butlast (cdr form)))  
                          (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))  
                          (vars (mapcar #'car bindings)))  
                     `(let ,bindings  
                        (,setf-function-name ,(car (last form)) ,@vars)))))  
         (eval `(defsetf ,function-name ,helper)))  
       #+Xerox  
       (flet ((setf-expander (body env)  
                (declare (ignore env))  
                (let ((temps  
                        (mapcar #'(lambda (x) (declare (ignore x)) (gensym))  
                                (cdr body)))  
                      (forms (cdr body))  
                      (vars (list (gensym))))  
                  (values temps  
                          forms  
                          vars  
                          `(,setf-function-name ,@vars ,@temps)  
                          `(,function-name ,@temps)))))  
         (let ((setf-method-expander (intern (concatenate 'string  
                                                          (symbol-name function-name)  
                                                          "-setf-expander")  
                                      (symbol-package function-name))))  
           (setf (get function-name :setf-method-expander) setf-method-expander  
                 (symbol-function setf-method-expander) #'setf-expander)))  
   
       #-(or Genera Lucid kcl Xerox)  
       (eval `(defsetf ,function-name (&rest accessor-args) (new-value)  
                `(,',setf-function-name ,new-value ,@accessor-args)))  
   
       )))  
   
 (defun setfboundp (symbol)  
   #+Genera (not (null (get-properties (symbol-plist symbol)  
                                       'lt::(derived-setf-function trivial-setf-method  
                                             setf-equivalence setf-method))))  
   #+Lucid  (locally  
              (declare (special lucid::*setf-inverse-table*  
                                lucid::*simple-setf-method-table*  
                                lucid::*setf-method-expander-table*))  
              (or (gethash symbol lucid::*setf-inverse-table*)  
                  (gethash symbol lucid::*simple-setf-method-table*)  
                  (gethash symbol lucid::*setf-method-expander-table*)))  
   #+kcl    (or (get symbol 'si::setf-method)  
                (get symbol 'si::setf-update-fn)  
                (get symbol 'si::setf-lambda))  
   #+Xerox  (or (get symbol :setf-inverse)  
                (get symbol 'il:setf-inverse)  
                (get symbol 'il:setfn)  
                (get symbol :shared-setf-inverse)  
                (get symbol :setf-method-expander)  
                (get symbol 'il:setf-method-expander))  
29    
30    #+:coral (or (get symbol 'ccl::setf-inverse)  #-(or loadable-pcl bootable-pcl)
31                 (get symbol 'ccl::setf-method-expander))  (eval-when (:compile-toplevel :load-toplevel :execute)
32      (when (eq *boot-state* 'complete)
33        (error _"~@<Trying to load (or compile) PCL in an environment in which it ~
34                has already been loaded.  This doesn't work, you will have to ~
35                get a fresh lisp (reboot) and then load PCL.~@:>"))
36    
37    #-(or Genera Lucid KCL Xerox :coral) nil)    (when *boot-state*
38        (cerror _"Try loading (or compiling) PCL anyways."
39  );eval-when              "~@<Trying to load (or compile) PCL in an environment in which it ~
40                 has already been partially loaded.  This may not work, you may ~
41                 need to get a fresh lisp (reboot) and then load PCL.~@:>")))
42    
   
43  ;;;  ;;;
44  ;;; PCL, like user code, must endure the fact that we don't have a properly  ;;; These are retained only for backward compatibility.  They
45  ;;; working setf.  Many things work because they get mentioned by a defclass  ;;; are no longer used, and may be deleted at some point.
46  ;;; or defmethod before they are used, but others have to be done by hand.  ;;;
47  ;;;  (defvar *defclass-times*   () "Obsolete, don't use.")
48  (do-standard-defsetf  (defvar *defmethod-times*  () "Obsolete, don't use.")
49    class-wrapper                                 ;***  (defvar *defgeneric-times* () "Obsolete, don't use.")
   generic-function-name  
   method-function-plist  
   method-function-get  
   gdefinition  
   slot-value-using-class  
   )  
   
 (defsetf slot-value set-slot-value)  
50    
51    
52  ;;;  ;;;
 ;;; 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))  
   (once-only (spec)  
     `(cond ((symbolp ,spec)  
             (let ((,non-setf-var ,spec)) ,@non-setf-case))  
            ((and (listp ,spec)  
                  (eq (car ,spec) 'setf)  
                  (symbolp (cadr ,spec)))  
             (let ((,setf-var (cadr ,spec))) ,@setf-case))  
            (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 <foo>) 'setf)))))  
   
 ;;;  
53  ;;; If symbol names a function which is traced or advised, return the  ;;; If symbol names a function which is traced or advised, return the
54  ;;; unadvised, traced etc. definition.  This lets me get at the generic  ;;; unadvised, traced etc. definition.  This lets me get at the generic
55  ;;; function object even when it is traced.  ;;; function object even when it is traced.
56  ;;;  ;;;
57  (defun unencapsulated-fdefinition (symbol)  ;;; Note that FDEFINITION takes care of encapsulations.  PROFILE
58    #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))  ;;; isn't using encapsulations, so it has to be treated specially.
59    #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))  ;;;
60    #+excl  (or (excl::encapsulated-basic-definition symbol)  (declaim (inline gdefinition))
61                (symbol-function symbol))  
62    #+xerox (il:virginfn symbol)  (defun gdefinition (name)
63      (fdefinition name))
   #-(or Lispm Lucid excl Xerox) (symbol-function symbol))  
64    
65  ;;;  ;;;
66  ;;; If symbol names a function which is traced or advised, redefine  ;;; If symbol names a function which is traced or advised, redefine
67  ;;; the `real' definition without affecting the advise.  ;;; the `real' definition without affecting the advise.
68  ;;;  ;;
69  (defun fdefine-carefully (symbol new-definition)  (defun (setf gdefinition) (new-definition name)
70    #+Lispm (si:fdefine symbol new-definition t t)    (c::%%defun name new-definition nil)
71    #+Lucid (let ((lucid::*redefinition-action* nil))    (c::note-name-defined name :function)
             (setf (symbol-function symbol) new-definition))  
   #+excl  (setf (symbol-function symbol) new-definition)  
   #+xerox (let ((advisedp (member symbol il:advisedfns :test #'eq))  
                 (brokenp (member symbol 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 symbol :no-error t)  
             (xcl:unbreak-function symbol :no-error t)  
             (setf (symbol-function symbol) new-definition)  
             (when brokenp (xcl:rebreak-function symbol))  
             (when advisedp (xcl:readvise-function symbol)))  
   
   #-(or Lispm Lucid excl Xerox)  
   (setf (symbol-function symbol) new-definition)  
   
72    new-definition)    new-definition)
73    
 (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 (macro-function name)             ;??  
               (unencapsulated-fdefinition name)))  
     (name (unencapsulated-fdefinition (get-setf-function-name name)))))  
   
 (defun SETF\ PCL\ GDEFINITION (new-value spec)  
   (parse-gspec spec  
     (name (fdefine-carefully name new-value))  
     (name (fdefine-carefully (get-setf-function-name name) new-value))))  
   
74    
75    (declaim (special *the-class-t*
76                      *the-class-vector* *the-class-symbol*
77                      *the-class-string* *the-class-sequence*
78                      *the-class-rational* *the-class-ratio*
79                      *the-class-number* *the-class-null* *the-class-list*
80                      *the-class-integer* *the-class-float* *the-class-cons*
81                      *the-class-complex* *the-class-character*
82                      *the-class-bit-vector* *the-class-array*
83                      *the-class-stream*
84    
85                      *the-class-slot-object*
86                      *the-class-structure-object*
87                      *the-class-standard-object*
88                      *the-class-funcallable-standard-object*
89                      *the-class-class*
90                      *the-class-generic-function*
91                      *the-class-built-in-class*
92                      *the-class-slot-class*
93                      *the-class-std-class*
94                      *the-class-condition-class*
95                      *the-class-structure-class*
96                      *the-class-standard-class*
97                      *the-class-funcallable-standard-class*
98                      *the-class-method*
99                      *the-class-standard-method*
100                      *the-class-standard-reader-method*
101                      *the-class-standard-writer-method*
102                      *the-class-standard-boundp-method*
103                      *the-class-standard-generic-function*
104                      *the-class-standard-effective-slot-definition*
105    
106                      *the-eslotd-standard-class-slots*
107                      *the-eslotd-funcallable-standard-class-slots*))
108    
109    (declaim (special *the-wrapper-of-t*
110                      *the-wrapper-of-vector* *the-wrapper-of-symbol*
111                      *the-wrapper-of-string* *the-wrapper-of-sequence*
112                      *the-wrapper-of-rational* *the-wrapper-of-ratio*
113                      *the-wrapper-of-number* *the-wrapper-of-null*
114                      *the-wrapper-of-list* *the-wrapper-of-integer*
115                      *the-wrapper-of-float* *the-wrapper-of-cons*
116                      *the-wrapper-of-complex* *the-wrapper-of-character*
117                      *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
118    
119    ;;;; Type specifier hackery:
120    
121    ;;; internal to this file.
122    (defun coerce-to-class (class &optional make-forward-referenced-class-p)
123      (if (symbolp class)
124          (or (find-class class (not make-forward-referenced-class-p))
125              (ensure-class class))
126          class))
127    
128    ;;; Interface
129    (defun specializer-from-type (type &aux args)
130      (when (consp type)
131        (setq args (cdr type) type (car type)))
132      (cond ((symbolp type)
133             (or (and (null args) (find-class type))
134                 (ecase type
135                   (class    (coerce-to-class (car args)))
136                   (class-eq (class-eq-specializer (coerce-to-class (car args))))
137                   (eql      (intern-eql-specializer (car args))))))
138            ((and (null args) (typep type 'kernel::class))
139             (or (kernel:%class-pcl-class type)
140                 (ensure-non-standard-class (kernel:%class-name type))))
141            ((specializerp type) type)))
142    
143    ;;; interface
144    (defun type-from-specializer (specl)
145      (cond ((eq specl t)
146             t)
147            ((consp specl)
148             (unless (member (car specl) '(class class-eq eql))
149               (error _"~@<~S is not a legal specializer type.~@:>" specl))
150             specl)
151            ((progn
152               (when (symbolp specl)
153                 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
154                 (setq specl (find-class specl)))
155               (or (not (eq *boot-state* 'complete))
156                   (specializerp specl)))
157             (specializer-type specl))
158            (t
159             (error _"~@<~s is neither a type nor a specializer.~@:>" specl))))
160    
161  (defun type-class (type)  (defun type-class (type)
162    (if (consp type)    (declare (special *the-class-t*))
163      (setq type (type-from-specializer type))
164      (if (atom type)
165          (if (eq type t)
166              *the-class-t*
167              (internal-error _"Bad argument to type-class."))
168        (case (car type)        (case (car type)
169          (class-eq (cadr type))          (eql (class-of (cadr type)))
170          (eql (class-of (cadr type)))          (class-eq (cadr type))
171          (t (and (null (cdr type)) (find-class (car type) nil))))          (class (cadr type)))))
172        (if (symbolp type)  
173            (find-class type nil)  (defun class-eq-type (class)
174            (and (class-specializer-p type)    (specializer-type (class-eq-specializer class)))
175                 (specializer-class type)))))  
176    (defun inform-type-system-about-std-class (name)
177  (defun class-type-p (type)    ;; This should only be called if metaclass is standard-class.
178    (if (consp type)    ;; Compiler problems have been seen if the metaclass is
179        (and (null (cdr type)) (find-class (car type) nil))    ;; funcallable-standard-class and this is called from the defclass macro
180        (if (symbolp type)    ;; expander. However, bootstrap-meta-braid calls this for funcallable-
181            (find-class type nil)    ;; standard-class metaclasses but *boot-state* is not 'complete then.
182            (and (classp type) type))))    ;;
183  ;;;;;;    ;; The only effect of this code is to ensure a lisp:standard-class class
184  (defun exact-class-type-p (type)    ;; exists so as to avoid undefined-function compiler warnings. The
185    (if (consp type)    ;; skeleton class will be replaced at load-time with the correct object.
186        (or (eq (car type) 'class-eq) (eq (car type) 'eql))    ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
187        (exact-class-specializer-p type)))    (declare (ignorable name))
188      (when (and (eq *boot-state* 'complete)
189  (defun make-class-eq-predicate (class)               (null (kernel::find-class name nil)))
190    (when (symbolp class) (setq class (find-class class)))      (setf (kernel::find-class name)
191    #'(lambda (object) (eq class (class-of object))))            (kernel::make-standard-class :name name))))
   
 (deftype class-eq (class)  
   `(satisfies ,(make-class-eq-predicate class)))  
   
 (defun class-eq-type-p (type)  
   (if (consp type)  
       (eq (car type) 'class-eq)  
       (class-eq-specializer-p type)))  
 ;;;;;;  
 (defun make-eql-predicate (eql-object)  
   #'(lambda (object) (eql eql-object object)))  
   
 (deftype eql (type-object)  
   `(satisfies ,(make-eql-predicate type-object)))  
   
 (defun eql-type-p (type)  
   (if (consp type)  
       (eq (car type) 'eql)  
       (eql-specializer-p type)))  
   
 (defun type-object (type)  
   (if (consp type)  
       (cadr type)  
       (specializer-object type)))  
   
 ;;;;;;  
 (defun not-type-p (type)  
   (and (consp type) (eq (car type) 'not)))  
   
 (defun not-type (type)  
   (cadr type))  
192    
193    ;;; Internal to this file.
194  ;;;  ;;;
195  ;;; These functions are a pale imitiation of their namesake.  They accept  ;;; These functions are a pale imitiation of their namesake.  They accept
196  ;;; class objects or types where they should.  ;;; class objects or types where they should.
197  ;;;  ;;;
198  (defun *typep (object type)  (defun *normalize-type (type)
199    (let ((specializer (or (class-type-p type)    (cond ((consp type)
200                           (and (specializerp type) type))))           (if (member (car type) '(not and or))
201      (cond (specializer               `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
202              (specializer-type-p object specializer))               (if (null (cdr type))
203            ((not-type-p type)                   (*normalize-type (car type))
204             (not (*typep object (not-type type))))                   type)))
205            (t          ((symbolp type)
206             (typep object type)))))           (let ((class (find-class type nil)))
207               (if class
208                   (let ((type (specializer-type class)))
209                     (if (listp type) type `(,type)))
210                   `(,type))))
211            ((or (not (eq *boot-state* 'complete))
212                 (specializerp type))
213             (specializer-type type))
214            (t
215             (error _"~s is not a type." type))))
216    
217    ;;; internal to this file...
218    (defun convert-to-system-type (type)
219      (case (car type)
220        ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
221                                              (cdr type))))
222        ((class class-eq) ; class-eq is impossible to do right
223         (kernel:layout-class (class-wrapper (cadr type))))
224        (eql type)
225        (t (if (null (cdr type))
226               (car type)
227               type))))
228    
229    
230    ;;; *SUBTYPEP  --  Interface
231    ;;;
232    ;Writing the missing NOT and AND clauses will improve
233    ;the quality of code generated by generate-discrimination-net, but
234    ;calling subtypep in place of just returning (values nil nil) can be
235    ;very slow.  *subtypep is used by PCL itself, and must be fast.
236  (defun *subtypep (type1 type2)  (defun *subtypep (type1 type2)
237    (let ((c1 (class-type-p type1))    (if (equal type1 type2)
238          (c2 (class-type-p type2)))        (values t t)
239      (cond ((and c1 c2)        (if (eq *boot-state* 'early)
240             (values (memq c2 (class-precedence-list c1)) t))            (values (eq type1 type2) t)
241            ((setq c1 (or c1 (specializerp type1)))            (let ((*in-precompute-effective-methods-p* t))
242             (specializer-applicable-using-type-p c1 type2))              (declare (special *in-precompute-effective-methods-p*))
243            ((or (null c2) (classp c2))              ;; *in-precompute-effective-methods-p* is not a good name.
244             (subtypep type1 (if c2 (class-name c2) type2))))))              ;; It changes the way class-applicable-using-class-p works.
245                (setq type1 (*normalize-type type1))
246  (defun do-satisfies-deftype (name predicate)              (setq type2 (*normalize-type type2))
247    (let* ((specifier `(satisfies ,predicate))              (case (car type2)
248           (expand-fn #'(lambda (&rest ignore)                (not
249                          (declare (ignore ignore))                 (values nil nil)) ; Should improve this.
250                          specifier)))                (and
251      ;; Specific ports can insert their own way of doing this.  Many                 (values nil nil)) ; Should improve this.
252      ;; ports may find the expand-fn defined above useful.                ((eql wrapper-eq class-eq class)
253      ;;                 (multiple-value-bind (app-p maybe-app-p)
254      (or #+:Genera                     (specializer-applicable-using-type-p type2 type1)
255          (setf (get name 'deftype) expand-fn)                   (values app-p (or app-p (not maybe-app-p)))))
256          #+(and :Lucid (not :Prime))                (t
257          (system::define-macro `(deftype ,name) expand-fn nil)                 (subtypep (convert-to-system-type type1)
258          #+ExCL                           (convert-to-system-type type2))))))))
         (setf (get name 'excl::deftype-expander) expand-fn)  
         #+:coral  
         (setf (get name 'ccl::deftype-expander) expand-fn)  
   
         ;; 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)  
   (intern (format nil  
                   "TYPE-PREDICATE ~A ~A"  
                   (package-name (symbol-package name))  
                   (symbol-name name))  
           *the-pcl-package*))  
   
   
   
 (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-standard-object*  
                     *the-class-class*  
                     *the-class-method*  
                     *the-class-generic-function*  
                     *the-class-standard-class*  
                     *the-class-funcallable-standard-class*  
                     *the-class-standard-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*))  
   
259    
260    
261  (defvar *built-in-class-symbols* ())  (defvar *built-in-class-symbols* ())
# Line 437  Line 263 
263    
264  (defun get-built-in-class-symbol (class-name)  (defun get-built-in-class-symbol (class-name)
265    (or (cadr (assq class-name *built-in-class-symbols*))    (or (cadr (assq class-name *built-in-class-symbols*))
266        (let ((symbol (intern (format nil        (let ((symbol (symbolicate* *the-pcl-package*
267                                      "*THE-CLASS-~A*"                                    '*the-class- class-name '*)))
                                     (symbol-name class-name))  
                             *the-pcl-package*)))  
268          (push (list class-name symbol) *built-in-class-symbols*)          (push (list class-name symbol) *built-in-class-symbols*)
269          symbol)))          symbol)))
270    
271  (defun get-built-in-wrapper-symbol (class-name)  (defun get-built-in-wrapper-symbol (class-name)
272    (or (cadr (assq class-name *built-in-wrapper-symbols*))    (or (cadr (assq class-name *built-in-wrapper-symbols*))
273        (let ((symbol (intern (format nil        (let ((symbol (symbolicate* *the-pcl-package*
274                                      "*THE-WRAPPER-OF-~A*"                                    '*the-wrapper-of- class-name '*)))
                                     (symbol-name class-name))  
                             *the-pcl-package*)))  
275          (push (list class-name symbol) *built-in-wrapper-symbols*)          (push (list class-name symbol) *built-in-wrapper-symbols*)
276          symbol)))          symbol)))
277    
# Line 459  Line 281 
281  (pushnew 'class *variable-declarations*)  (pushnew 'class *variable-declarations*)
282  (pushnew 'variable-rebinding *variable-declarations*)  (pushnew 'variable-rebinding *variable-declarations*)
283    
284  (defun variable-class (var env)  (defvar *name->class->slotd-table* (make-hash-table))
   (caddr (variable-declaration 'class var env)))  
   
   
 (defvar *boot-state* ())                        ;NIL  
                                                 ;EARLY  
                                                 ;BRAID  
                                                 ;COMPLETE  
   
 (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 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* ())  
285    
286    (defun slot-name->class-table (slot-name)
287      (or (gethash slot-name *name->class->slotd-table*)
288          (setf (gethash slot-name *name->class->slotd-table*)
289                (make-hash-table :test 'eq :size 5))))
290    
291  (defvar *standard-method-combination*)  (defvar *standard-method-combination*)
292    
 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*))  ;***  
293    
294    
295  (defmacro define-gf-predicate (predicate &rest classes)  (defun make-class-predicate-name (name)
296    `(progn (defmethod ,predicate ((x t)) nil)    `(class-predicate ,name))
297            ,@(mapcar #'(lambda (c) `(defmethod ,predicate ((x ,c)) t))  
298                      classes)))  (defun plist-value (object name)
299      (getf (object-plist object) name))
300  (defmacro plist-value (object name)  
301    `(with-slots (plist) ,object (getf plist ,name)))  (defun (setf plist-value) (new-value object name)
302      (if new-value
303  (defsetf plist-value (object name) (new-value)        (setf (getf (object-plist object) name) new-value)
304    (once-only (new-value)        (progn
305      `(with-slots (plist) ,object          (remf (object-plist object) name)
306         (if ,new-value          nil)))
            (setf (getf plist ,name) ,new-value)  
            (progn (remf plist ,name) nil)))))  
307    
308    
309    
310  (defvar *built-in-classes*  (defvar *built-in-classes*
311    ;;    ;;
312    ;; name       supers     subs                     cdr of cpl    ;; name       supers     subs                     cdr of cpl
313    ;;    ;; prototype
314    '((number     (t)        (complex float rational) (t))    '(;(t         ()         (number sequence array character symbol) ())
315      (complex    (number)   ()                       (number t))      (number     (t)        (complex float rational) (t))
316      (float      (number)   ()                       (number t))      (complex    (number)   ()                       (number t)
317         #c(1 1))
318        (float      (number)   ()                       (number t)
319         1.0)
320      (rational   (number)   (integer ratio)          (number t))      (rational   (number)   (integer ratio)          (number t))
321      (integer    (rational) ()                       (rational number t))      (integer    (rational) ()                       (rational number t)
322      (ratio      (rational) ()                       (rational number t))       1)
323        (ratio      (rational) ()                       (rational number t)
324         1/2)
325    
326      (sequence   (t)        (list vector)            (t))      (sequence   (t)        (list vector)            (t))
327      (list       (sequence) (cons null)              (sequence t))      (list       (sequence) (cons null)              (sequence t))
328      (cons       (list)     ()                       (list sequence t))      (cons       (list)     ()                       (list sequence t)
329         (nil))
330    
331    
332      (array      (t)        (vector)                 (t))      (array      (t)        (vector)                 (t)
333         #2A((NIL)))
334      (vector     (array      (vector     (array
335                   sequence) (string bit-vector)      (array sequence t))                   sequence) (string bit-vector)      (array sequence t)
336      (string     (vector)   ()                       (vector array sequence t))       #())
337      (bit-vector (vector)   ()                       (vector array sequence t))      (string     (vector)   ()                       (vector array sequence t)
338      (character  (t)        ()                       (t))       "")
339        (bit-vector (vector)   ()                       (vector array sequence t)
340         #*1)
341        (character  (t)        ()                       (t)
342         #\c)
343    
344      (symbol     (t)        (null)                   (t))      (symbol     (t)        (null)                   (t)
345      (null       (symbol)   ()                       (symbol list sequence t))))       symbol)
346        (null       (symbol
347                     list)     ()                       (symbol list sequence t)
348         nil)))
349    
350    (labels ((direct-supers (class)
351               (if (typep class 'kernel::built-in-class)
352                   (kernel:built-in-class-direct-superclasses class)
353                   (let ((inherits (kernel:layout-inherits
354                                    (kernel:%class-layout class))))
355                     (list (svref inherits (1- (length inherits)))))))
356             (direct-subs (class)
357               (collect ((res))
358                 (let ((subs (kernel:%class-subclasses class)))
359                   (when subs
360                     (do-hash (sub v subs)
361                       (declare (ignore v))
362                       (when (member class (direct-supers sub))
363                         (res sub)))))
364                 (res))))
365      (collect ((res))
366        (dolist (bic kernel::built-in-classes)
367          (let* ((name (car bic))
368                 (class (kernel::find-class name)))
369            (unless (member name '(t kernel:instance kernel:funcallable-instance
370                                     function stream))
371              (res `(,name
372                     ,(mapcar #'kernel:%class-name (direct-supers class))
373                     ,(mapcar #'kernel:%class-name (direct-subs class))
374                     ,(let ((found (assoc name *built-in-classes*)))
375                        (if found (fifth found) 42)))))))
376        (setq *built-in-classes* (res))))
377    
378    
379  ;;;  ;;;
# Line 552  Line 382 
382  (defclass t () ()  (defclass t () ()
383    (:metaclass built-in-class))    (:metaclass built-in-class))
384    
385  (defclass standard-object (t) ())  (defclass kernel:instance (t) ()
386      (:metaclass built-in-class))
387    
388  (defclass metaobject (standard-object) ())  (defclass function (t) ()
389      (:metaclass built-in-class))
390    
391    (defclass kernel:funcallable-instance (function) ()
392      (:metaclass built-in-class))
393    
394    (defclass stream (kernel:instance) ()
395      (:metaclass built-in-class))
396    
397    (defclass slot-object (t) ()
398      (:metaclass slot-class))
399    
400    ;;;
401    ;;; In a host Lisp with intact PCL, the DEFCLASS below would normally
402    ;;; generate a DEFSTRUCT with :INCLUDE SLOT-OBJECT.  SLOT-OBJECT is
403    ;;; not a structure, so this would give an error.  Likewise,
404    ;;; KERNEL:INSTANCE is a BUILT-IN-CLASS, not a structure class, so
405    ;;; this would give an error, too.
406    ;;;
407    ;;; When PCL is bootstrapped normally, *BOOT-STATE* is not COMPLETE at
408    ;;; this point, which means that a DEFSTRUCT is not done, because
409    ;;; EXPAND-DEFCLASS looks at the boot state.
410    ;;;
411    ;;; I've modified EXPAND-DEFCLASS accordingly to not do a DEFSTRUCT
412    ;;; when a loadable or bootable PCL is built.
413    ;;;
414    (defclass structure-object (slot-object kernel:instance) ()
415      (:metaclass structure-class))
416    
417  (defclass specializer (metaobject) ())  (defstruct (dead-beef-structure-object
418                 (:constructor |STRUCTURE-OBJECT class constructor|)))
419    
420    (defclass standard-object (slot-object) ())
421    (defclass metaobject (standard-object) ())
422    
423  (defclass class-specializer (specializer) ())  (defclass funcallable-standard-object (standard-object
424                                           kernel:funcallable-instance)
425      ()
426      (:metaclass funcallable-standard-class))
427    
428    (defclass specializer (metaobject)
429      ((type
430        :initform nil
431        :reader specializer-type)))
432    
433  (defclass definition-source-mixin (standard-object)  (defclass definition-source-mixin (standard-object)
434       ((source    ((source
435          :initform (load-truename)      :initform *load-pathname*
436          :reader definition-source      :reader definition-source
437          :initarg :definition-source)))      :initarg :definition-source)))
438    
439  (defclass plist-mixin (standard-object)  (defclass plist-mixin (standard-object)
440       ((plist    ((plist
441          :initform ())))      :initform ()
442        :accessor object-plist)))
443    
444  (defclass documentation-mixin (plist-mixin)  (defclass documentation-mixin (plist-mixin) ())
      ())  
445    
446  (defclass dependent-update-mixin (plist-mixin)  (defclass dependent-update-mixin (plist-mixin) ())
     ())  
447    
448  ;;;  ;;;
449  ;;; The class CLASS is a specified basic class.  It is the common superclass  ;;; The class CLASS is a specified basic class.  It is the common superclass
450  ;;; of any kind of class.  That is any class that can be a metaclass must  ;;; of any kind of class.  That is any class that can be a metaclass must
451  ;;; have the class CLASS in its class precedence list.  ;;; have the class CLASS in its class precedence list.
452  ;;;  ;;;
453  (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin  (defclass class (documentation-mixin dependent-update-mixin
454                                       class-specializer)                                       definition-source-mixin
455       ((name                                       specializer
456          :initform nil                                       kernel:instance)
457          :initarg  :name    ((name
458          :accessor class-name)      :initform nil
459        (direct-superclasses      :initarg  :name
460          :initform ()      :accessor class-name)
461          :reader class-direct-superclasses)     (class-eq-specializer
462        (direct-subclasses      :initform nil
463          :initform ()      :reader class-eq-specializer)
464          :reader class-direct-subclasses)     (direct-superclasses
465        (direct-methods      :initform ()
466          :initform (cons nil nil))))      :reader class-direct-superclasses)
467       (direct-subclasses
468        :initform ()
469        :reader class-direct-subclasses)
470       (direct-methods
471        :initform (cons nil nil))
472       (predicate-name
473        :initform nil
474        :reader class-predicate-name)
475       (finalized-p
476        :initform nil
477        :reader class-finalized-p)))
478    
479  ;;;  ;;;
480  ;;; The class PCL-CLASS is an implementation-specific common superclass of  ;;; The class PCL-CLASS is an implementation-specific common superclass of
481  ;;; all specified subclasses of the class CLASS.  ;;; all specified subclasses of the class CLASS.
482  ;;;  ;;;
483  (defclass pcl-class (class)  (defclass pcl-class (class)
484       ((class-precedence-list    ((class-precedence-list
485          :initform ())      :reader class-precedence-list)
486        (wrapper     (cpl-available-p
487          :initform nil)))      :reader cpl-available-p
488        :initform nil)
489       (can-precede-list
490        :initform ()
491        :reader class-can-precede-list)
492       (incompatible-superclass-list
493        :initform ()
494        :accessor class-incompatible-superclass-list)
495       (wrapper
496        :initform nil
497        :reader class-wrapper)
498       (prototype
499        :initform nil
500        :reader class-prototype)))
501    
502    (defclass slot-class (pcl-class)
503      ((direct-slots
504        :initform ()
505        :accessor class-direct-slots)
506       (slots
507        :initform ()
508        :accessor class-slots)))
509    
510  ;;;  ;;;
511  ;;; The class STD-CLASS is an implementation-specific common superclass of  ;;; The class STD-CLASS is an implementation-specific common superclass of
512  ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.  ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
513  ;;;  ;;;
514  (defclass std-class (pcl-class)  (defclass std-class (slot-class) ())
      ((direct-slots  
         :initform ()  
         :accessor class-direct-slots)  
       (slots  
         :initform ()  
         :accessor class-slots)  
       (no-of-instance-slots                 ;*** MOVE TO WRAPPER ***  
         :initform 0  
         :accessor class-no-of-instance-slots)  
       (prototype  
         :initform nil)))  
515    
516  (defclass standard-class (std-class)  (defclass standard-class (std-class) ())
      ())  
517    
518  (defclass funcallable-standard-class (std-class)  (defclass funcallable-standard-class (std-class) ())
      ())  
519    
520  (defclass forward-referenced-class (pcl-class) ())  (defclass forward-referenced-class (pcl-class) ())
521    
522  (defclass built-in-class (pcl-class) ())  (defclass built-in-class (pcl-class) ())
523    
524    (defclass structure-class (slot-class)
525      ((defstruct-form
526         :initform ()
527         :accessor class-defstruct-form)
528       (defstruct-constructor
529         :initform nil
530         :accessor class-defstruct-constructor)
531       (from-defclass-p
532        :initform nil
533        :initarg :from-defclass-p)))
534    
535    (defclass condition (slot-object kernel:instance) ()
536      (:metaclass condition-class))
537    
538    (defclass condition-class (slot-class) ())
539    
540    (defclass specializer-with-object (specializer) ())
541    
542    (defclass exact-class-specializer (specializer) ())
543    
544    ;;;
545    ;;; Extension specializing on the exact specified class.  You must set
546    ;;; pcl::*allow-experimental-specializers-p* to use this extension.
547    ;;;
548    ;;; (defclass foo () ())
549    ;;; (defclass bar (foo) ())
550    ;;;
551    ;;; (setq pcl::*allow-experimental-specializers-p* t)
552    ;;; (defmethod m (x) nil)
553    ;;; (defmethod m ((x (pcl::class-eq 'foo))) t)
554    ;;;
555    ;;; (m (make-instance 'foo)) => t
556    ;;; (m (make-instance 'bar)) => nil
557    ;;;
558    
559    (defclass class-eq-specializer (exact-class-specializer
560                                    specializer-with-object)
561      ((object
562        :initarg :class
563        :reader specializer-class
564        :reader specializer-object)))
565    
566    (defclass eql-specializer (exact-class-specializer specializer-with-object)
567      ((object
568        :initarg :object
569        :reader specializer-object
570        :reader eql-specializer-object)))
571    
572    (defvar *eql-specializer-table* (make-hash-table :test 'eql))
573    
574    ;;;
575    ;;; When compiled with an intact PCL, the MAKE-INSTANCE in the function
576    ;;; below will generate an optimized constructor, and a LOAD-TIME-VALUE
577    ;;; creating it.  That means CTOR must be initialized before this file
578    ;;; is.
579    ;;;
580    (defun intern-eql-specializer (object)
581      (or (gethash object *eql-specializer-table*)
582          (setf (gethash object *eql-specializer-table*)
583                (make-instance 'eql-specializer :object object))))
584    
585    
586  ;;;  ;;;
587  ;;; Slot definitions.  ;;; Slot definitions.
588  ;;;  ;;;
589  ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".  (defclass slot-definition (metaobject)
590  ;;;    ((name
591  (defclass slot-definition (metaobject) ())      :initform nil
592        :initarg :name
593  (defclass direct-slot-definition    (slot-definition) ())      :accessor slot-definition-name)
594  (defclass effective-slot-definition (slot-definition) ())     (initform
595        :initform nil
596  (defclass standard-slot-definition (slot-definition)      :initarg :initform
597       ((name      :accessor slot-definition-initform)
598          :initform nil     (initfunction
599          :accessor slotd-name)      :initform nil
600        (initform      :initarg :initfunction
601          :initform *slotd-unsupplied*      :accessor slot-definition-initfunction)
602          :accessor slotd-initform)     (readers
603        (initfunction      :initform nil
604          :initform *slotd-unsupplied*      :initarg :readers
605          :accessor slotd-initfunction)      :accessor slot-definition-readers)
606        (readers     (writers
607          :initform nil      :initform nil
608          :accessor slotd-readers)      :initarg :writers
609        (writers      :accessor slot-definition-writers)
610          :initform nil     (initargs
611          :accessor slotd-writers)      :initform nil
612        (initargs      :initarg :initargs
613          :initform nil      :accessor slot-definition-initargs)
614          :accessor slotd-initargs)     (type
615        (allocation      :initform t
616          :initform nil      :initarg :type
617          :accessor slotd-allocation)      :accessor slot-definition-type)
618        (type     (documentation
619          :initform nil      :initform ""
620          :accessor slotd-type)      :initarg :documentation)
621        (documentation     (class
622          :initform ""      :initform nil
623          :initarg :documentation)      :initarg :class
624        (class      :accessor slot-definition-class)))
625          :initform nil  
626          :accessor slotd-class)  (defclass standard-slot-definition (slot-definition)
627        (instance-index    ((allocation
628          :initform nil      :initform :instance
629          :accessor slotd-instance-index)))      :initarg :allocation
630        :accessor slot-definition-allocation)
631       (allocation-class
632        :documentation _N"For class slots, the class defininig the slot.
633    For inherited class slots, this is the superclass from which the slot
634    was inherited."
635        :initform nil
636        :initarg :allocation-class
637        :accessor slot-definition-allocation-class)))
638    
639    (defclass structure-slot-definition (slot-definition)
640      ((defstruct-accessor-symbol
641         :initform nil
642         :initarg :defstruct-accessor-symbol
643         :accessor slot-definition-defstruct-accessor-symbol)
644       (internal-reader-function
645         :initform nil
646         :initarg :internal-reader-function
647         :accessor slot-definition-internal-reader-function)
648       (internal-writer-function
649         :initform nil
650         :initarg :internal-writer-function
651         :accessor slot-definition-internal-writer-function)))
652    
653    (defclass condition-slot-definition (standard-slot-definition)
654      ())
655    
656    (defclass direct-slot-definition (slot-definition)
657      ())
658    
659    (defclass effective-slot-definition (slot-definition)
660      ((reader-function ; (lambda (object) ...)
661        :accessor slot-definition-reader-function)
662       (writer-function ; (lambda (new-value object) ...)
663        :accessor slot-definition-writer-function)
664       (boundp-function ; (lambda (object) ...)
665        :accessor slot-definition-boundp-function)
666       (accessor-flags
667        :initform 0)))
668    
669  (defclass standard-direct-slot-definition (standard-slot-definition  (defclass standard-direct-slot-definition (standard-slot-definition
670                                             direct-slot-definition)                                             direct-slot-definition)
671       ())                                        ;Adding slots here may    ())
                                                 ;involve extra work to  
                                                 ;the code in braid.lisp  
672    
673  (defclass standard-effective-slot-definition (standard-slot-definition  (defclass standard-effective-slot-definition (standard-slot-definition
674                                                effective-slot-definition)                                                effective-slot-definition)
675       ())                                        ;Adding slots here may    ((location
676                                                  ;involve extra work to      :initform nil
677                                                  ;the code in braid.lisp      :accessor slot-definition-location)))
678    
679    (defclass structure-direct-slot-definition (structure-slot-definition
680                                                direct-slot-definition)
681  (defclass eql-specializer (specializer)    ())
682       ((object :initarg :object :reader specializer-object)))  
683    (defclass condition-direct-slot-definition (condition-slot-definition
684                                                direct-slot-definition)
685      ())
686  ;;;  
687  ;;;  (defclass structure-effective-slot-definition (structure-slot-definition
688  ;;;                                                 effective-slot-definition)
689  (defmacro dolist-carefully ((var list improper-list-handler) &body body)    ())
690    `(let ((,var nil)  
691           (.dolist-carefully. ,list))  (defclass condition-effective-slot-definition (condition-slot-definition
692       (loop (when (null .dolist-carefully.) (return nil))                                                 effective-slot-definition)
693             (if (consp .dolist-carefully.)    ())
694                 (progn  
695                   (setq ,var (pop .dolist-carefully.))  (defclass method (metaobject) ())
696                   ,@body)  
697                 (,improper-list-handler)))))  (defclass standard-method (method definition-source-mixin documentation-mixin)
698      ((generic-function
699        :initform nil
700        :accessor method-generic-function)
701       (specializers
702        :initform ()
703        :initarg  :specializers
704        :reader method-specializers)
705       (lambda-list
706        :initform ()
707        :initarg  :lambda-list
708        :reader method-lambda-list)
709       (function
710        :initform nil
711        :initarg :function)
712       (fast-function
713        :initform nil
714        :initarg :fast-function
715        :reader method-fast-function)))
716    
717    (defclass standard-accessor-method (standard-method)
718      ((slot-name
719        :initform nil
720        :initarg :slot-name
721        :reader accessor-method-slot-name)
722       (slot-definition
723        :initform nil
724        :initarg :slot-definition
725        :reader accessor-method-slot-definition)))
726    
727    (defclass standard-reader-method (standard-accessor-method) ())
728    
729    (defclass standard-writer-method (standard-accessor-method) ())
730    
731    (defclass standard-boundp-method (standard-accessor-method) ())
732    
733    (defclass generic-function (dependent-update-mixin
734                                definition-source-mixin
735                                documentation-mixin
736                                metaobject
737                                funcallable-standard-object)
738      ()
739      (:metaclass funcallable-standard-class))
740    
741    (defclass standard-generic-function (generic-function)
742      ((name
743        :initform nil
744        :initarg :name
745        :accessor generic-function-name)
746       (methods
747        :initform ()
748        :accessor generic-function-methods)
749       (method-class
750        :initarg :method-class
751        :accessor generic-function-method-class)
752       (method-combination
753        :initarg :method-combination
754        :accessor generic-function-method-combination)
755       (arg-info
756        :initform (make-arg-info)
757        :reader gf-arg-info)
758       (dfun-state
759        :initform ()
760        :accessor gf-dfun-state)
761       (pretty-arglist
762        :initform ()
763        :accessor gf-pretty-arglist)
764       (declarations
765        :initform ()
766        :initarg :declarations
767        :reader generic-function-declarations))
768      (:metaclass funcallable-standard-class)
769      (:default-initargs :method-class *the-class-standard-method*
770        :method-combination *standard-method-combination*))
771    
772    (defclass method-combination (metaobject) ())
773    
774    (defclass standard-method-combination
775        (definition-source-mixin method-combination)
776      ((type
777        :reader method-combination-type
778        :initarg :type)
779       (documentation
780        :reader method-combination-documentation
781        :initarg :documentation)
782       (options
783        :reader method-combination-options
784        :initarg :options)))
785    
786    (defclass long-method-combination (standard-method-combination)
787      ((function
788        :initarg :function
789        :reader long-method-combination-function)
790       (args-lambda-list
791        :initarg :args-lambda-list
792        :reader long-method-combination-args-lambda-list)))
793    
794    (defclass seal (standard-object)
795      ((quality
796        :initarg :quality
797        :reader seal-quality)))
798    
799    (defparameter *early-class-predicates*
800      '((specializer specializerp)
801        (exact-class-specializer exact-class-specializer-p)
802        (class-eq-specializer class-eq-specializer-p)
803        (eql-specializer eql-specializer-p)
804        (class classp)
805        (slot-class slot-class-p)
806        (std-class std-class-p)
807        (standard-class standard-class-p)
808        (funcallable-standard-class funcallable-standard-class-p)
809        (structure-class structure-class-p)
810        (condition-class condition-class-p)
811        (forward-referenced-class forward-referenced-class-p)
812        (method method-p)
813        (standard-method standard-method-p)
814        (standard-accessor-method standard-accessor-method-p)
815        (standard-reader-method standard-reader-method-p)
816        (standard-writer-method standard-writer-method-p)
817        (standard-boundp-method standard-boundp-method-p)
818        (generic-function generic-function-p)
819        (standard-generic-function standard-generic-function-p)
820        (method-combination method-combination-p)
821        (long-method-combination long-method-combination-p)))
822    
823    

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.45

  ViewVC Help
Powered by ViewVC 1.1.5