/[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.6.1.1 by ram, Mon Dec 14 13:27:45 1992 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))  
   
 (defvar *boot-state* ())                        ;NIL  
                                                 ;EARLY  
                                                 ;BRAID  
                                                 ;COMPLETE  
26    
27  )  (in-package :pcl)
28    (intl:textdomain "cmucl")
29    
30  (eval-when (load eval)  #-(or loadable-pcl bootable-pcl)
31    (eval-when (:compile-toplevel :load-toplevel :execute)
32    (when (eq *boot-state* 'complete)    (when (eq *boot-state* 'complete)
33      (error "Trying to load (or compile) PCL in an environment in which it~%~      (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~%~              has already been loaded.  This doesn't work, you will have to ~
35              get a fresh lisp (reboot) and then load PCL."))              get a fresh lisp (reboot) and then load PCL.~@:>"))
36    
37    (when *boot-state*    (when *boot-state*
38      (cerror "Try loading (or compiling) PCL anyways."      (cerror _"Try loading (or compiling) PCL anyways."
39              "Trying to load (or compile) PCL in an environment in which it~%~              "~@<Trying to load (or compile) PCL in an environment in which it ~
40               has already been partially loaded.  This may not work, you may~%~               has already been partially loaded.  This may not work, you may ~
41               need to get a fresh lisp (reboot) and then load PCL."))               need to get a fresh lisp (reboot) and then load PCL.~@:>")))
   )  
   
42    
   
43  ;;;  ;;;
44  ;;; This is like fdefinition on the Lispm.  If Common Lisp had something like  ;;; These are retained only for backward compatibility.  They
45  ;;; function specs I wouldn't need this.  On the other hand, I don't like the  ;;; are no longer used, and may be deleted at some point.
46  ;;; way this really works so maybe function specs aren't really right either?  ;;;
47  ;;;  (defvar *defclass-times*   () "Obsolete, don't use.")
48  ;;; I also don't understand the real implications of a Lisp-1 on this sort of  (defvar *defmethod-times*  () "Obsolete, don't use.")
49  ;;; thing.  Certainly some of the lossage in all of this is because these  (defvar *defgeneric-times* () "Obsolete, don't use.")
 ;;; 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 (#-setf (symbolp ,spec) #+setf t  
             (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)))))  
50    
51    
52  ;;;  ;;;
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    #+setf (fdefinition symbol)    (fdefinition name))
   #-(or Lispm Lucid excl Xerox setf) (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)))  
   #+setf (setf (fdefinition symbol) new-definition)  
   #-(or Lispm Lucid excl Xerox setf)  
   (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 #-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))))  
   
74    
75  (proclaim '(special *the-class-t*  (declaim (special *the-class-t*
76                      *the-class-vector* *the-class-symbol*                    *the-class-vector* *the-class-symbol*
77                      *the-class-string* *the-class-sequence*                    *the-class-string* *the-class-sequence*
78                      *the-class-rational* *the-class-ratio*                    *the-class-rational* *the-class-ratio*
79                      *the-class-number* *the-class-null* *the-class-list*                    *the-class-number* *the-class-null* *the-class-list*
80                      *the-class-integer* *the-class-float* *the-class-cons*                    *the-class-integer* *the-class-float* *the-class-cons*
81                      *the-class-complex* *the-class-character*                    *the-class-complex* *the-class-character*
82                      *the-class-bit-vector* *the-class-array*                    *the-class-bit-vector* *the-class-array*
83                      *the-class-stream*
84                      *the-class-slot-object*  
85                      *the-class-standard-object*                    *the-class-slot-object*
86                      *the-class-structure-object*                    *the-class-structure-object*
87                      *the-class-class*                    *the-class-standard-object*
88                      *the-class-method*                    *the-class-funcallable-standard-object*
89                      *the-class-generic-function*                    *the-class-class*
90                      *the-class-built-in-class*                    *the-class-generic-function*
91                      *the-class-slot-class*                    *the-class-built-in-class*
92                      *the-class-structure-class*                    *the-class-slot-class*
93                      *the-class-standard-class*                    *the-class-std-class*
94                      *the-class-funcallable-standard-class*                    *the-class-condition-class*
95                      *the-class-standard-method*                    *the-class-structure-class*
96                      *the-class-standard-generic-function*                    *the-class-standard-class*
97                      *the-class-standard-effective-slot-definition*                    *the-class-funcallable-standard-class*
98                      *the-class-method*
99                      *the-eslotd-standard-class-slots*                    *the-class-standard-method*
100                      *the-eslotd-funcallable-standard-class-slots*))                    *the-class-standard-reader-method*
101                      *the-class-standard-writer-method*
102  (proclaim '(special *the-wrapper-of-t*                    *the-class-standard-boundp-method*
103                      *the-wrapper-of-vector* *the-wrapper-of-symbol*                    *the-class-standard-generic-function*
104                      *the-wrapper-of-string* *the-wrapper-of-sequence*                    *the-class-standard-effective-slot-definition*
105                      *the-wrapper-of-rational* *the-wrapper-of-ratio*  
106                      *the-wrapper-of-number* *the-wrapper-of-null*                    *the-eslotd-standard-class-slots*
107                      *the-wrapper-of-list* *the-wrapper-of-integer*                    *the-eslotd-funcallable-standard-class-slots*))
108                      *the-wrapper-of-float* *the-wrapper-of-cons*  
109                      *the-wrapper-of-complex* *the-wrapper-of-character*  (declaim (special *the-wrapper-of-t*
110                      *the-wrapper-of-bit-vector* *the-wrapper-of-array*))                    *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)  (defun coerce-to-class (class &optional make-forward-referenced-class-p)
123    (if (symbolp class)    (if (symbolp class)
124        (or (find-class class (not make-forward-referenced-class-p))        (or (find-class class (not make-forward-referenced-class-p))
125            (ensure-class class))            (ensure-class class))
126        class))        class))
127    
128    ;;; Interface
129  (defun specializer-from-type (type &aux args)  (defun specializer-from-type (type &aux args)
130    (when (consp type)    (when (consp type)
131      (setq args (cdr type) type (car type)))      (setq args (cdr type) type (car type)))
# Line 200  Line 135 
135                 (class    (coerce-to-class (car args)))                 (class    (coerce-to-class (car args)))
136                 (class-eq (class-eq-specializer (coerce-to-class (car args))))                 (class-eq (class-eq-specializer (coerce-to-class (car args))))
137                 (eql      (intern-eql-specializer (car args))))))                 (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)))          ((specializerp type) type)))
142    
143    ;;; interface
144  (defun type-from-specializer (specl)  (defun type-from-specializer (specl)
145    (when (symbolp specl)    (cond ((eq specl t)
146      (setq specl (find-class specl))) ;(or (find-class specl nil) (ensure-class specl))           t)
147    (cond ((consp specl)          ((consp specl)
148           (unless (member (car specl) '(class class-eq eql))           (unless (member (car specl) '(class class-eq eql))
149             (error "~S is not a legal specializer type" specl))             (error _"~@<~S is not a legal specializer type.~@:>" specl))
150           specl)           specl)
151          ((specializerp specl)          ((progn
152           (specializer-type specl))             (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          (t
159           (error "~s is neither a type nor a specializer" specl))))           (error _"~@<~s is neither a type nor a specializer.~@:>" specl))))
160    
161  (defun type-class (type)  (defun type-class (type)
162    (declare (special *the-class-t*))    (declare (special *the-class-t*))
163    (setq type (type-from-specializer type))    (setq type (type-from-specializer type))
164    (if (atom type)    (if (atom type)
165        *the-class-t*        (if (eq type t)
166              *the-class-t*
167              (internal-error _"Bad argument to type-class."))
168        (case (car type)        (case (car type)
169          (eql (class-of (cadr type)))          (eql (class-of (cadr type)))
170          (class-eq (cadr type))          (class-eq (cadr type))
# Line 228  Line 174 
174    (specializer-type (class-eq-specializer class)))    (specializer-type (class-eq-specializer class)))
175    
176  (defun inform-type-system-about-std-class (name)  (defun inform-type-system-about-std-class (name)
177    (let ((predicate-name (make-type-predicate-name name)))    ;; This should only be called if metaclass is standard-class.
178      (setf (symbol-function predicate-name) (make-type-predicate name))    ;; Compiler problems have been seen if the metaclass is
179      (do-satisfies-deftype name predicate-name)))    ;; funcallable-standard-class and this is called from the defclass macro
180      ;; expander. However, bootstrap-meta-braid calls this for funcallable-
181  (defun make-type-predicate (name)    ;; standard-class metaclasses but *boot-state* is not 'complete then.
182    (let ((cell (find-class-cell name)))    ;;
183      #'(lambda (x)    ;; The only effect of this code is to ensure a lisp:standard-class class
184          (funcall (the function (find-class-cell-predicate cell)) x))))    ;; exists so as to avoid undefined-function compiler warnings. The
185      ;; skeleton class will be replaced at load-time with the correct object.
186      ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
187  ;This stuff isn't right.  Good thing it isn't used.    (declare (ignorable name))
188  ;The satisfies predicate has to be a symbol.  There is no way to    (when (and (eq *boot-state* 'complete)
189  ;construct such a symbol from a class object if class names change.               (null (kernel::find-class name nil)))
190  (defun class-predicate (class)      (setf (kernel::find-class name)
191    (when (symbolp class) (setq class (find-class class)))            (kernel::make-standard-class :name name))))
   #'(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)))  
 ||#  
   
 (deftype eql (type-object)  
   `(member ,type-object))  
   
   
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.
# Line 284  Line 208 
208                 (let ((type (specializer-type class)))                 (let ((type (specializer-type class)))
209                   (if (listp type) type `(,type)))                   (if (listp type) type `(,type)))
210                 `(,type))))                 `(,type))))
211          ((specializerp type)          ((or (not (eq *boot-state* 'complete))
212           (specializer-type type))               (specializerp type))
213             (specializer-type type))
214          (t          (t
215           (error "~s is not a type" type))))           (error _"~s is not a type." type))))
   
 (defun unparse-type-list (tlist)  
   (mapcar #'unparse-type tlist))  
   
 (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)))))))  
216    
217    ;;; internal to this file...
218  (defun convert-to-system-type (type)  (defun convert-to-system-type (type)
219    (case (car type)    (case (car type)
220      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type))))      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
221      (class (class-name (cadr type))) ; it had better be a named class                                            (cdr type))))
222      (class-eq (class-name (cadr type))) ; this one is impossible to do right      ((class class-eq) ; class-eq is impossible to do right
223         (kernel:layout-class (class-wrapper (cadr type))))
224      (eql type)      (eql type)
225      (t (if (null (cdr type))      (t (if (null (cdr type))
226             (car type)             (car type)
227             type))))             type))))
228    
 (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)))))  
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    (setq type1 (*normalize-type type1))    (if (equal type1 type2)
238    (setq type2 (*normalize-type type2))        (values t t)
239    (if (member (car type2) '(eql wrapper-eq class-eq class))        (if (eq *boot-state* 'early)
240        (multiple-value-bind (app-p maybe-app-p)            (values (eq type1 type2) t)
241            (specializer-applicable-using-type-p type2 type1)            (let ((*in-precompute-effective-methods-p* t))
242          (values app-p (or app-p (not maybe-app-p))))              (declare (special *in-precompute-effective-methods-p*))
243        (subtypep (convert-to-system-type type1)              ;; *in-precompute-effective-methods-p* is not a good name.
244                  (convert-to-system-type 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    #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)              (case (car type2)
248    (let* ((specifier `(satisfies ,predicate))                (not
249           (expand-fn #'(lambda (&rest ignore)                 (values nil nil)) ; Should improve this.
250                          (declare (ignore ignore))                (and
251                          specifier)))                 (values nil nil)) ; Should improve this.
252      ;; Specific ports can insert their own way of doing this.  Many                ((eql wrapper-eq class-eq class)
253      ;; ports may find the expand-fn defined above useful.                 (multiple-value-bind (app-p maybe-app-p)
254      ;;                     (specializer-applicable-using-type-p type2 type1)
255      (or #+:Genera                   (values app-p (or app-p (not maybe-app-p)))))
256          (setf (get name 'deftype) expand-fn)                (t
257          #+(and :Lucid (not :Prime))                 (subtypep (convert-to-system-type type1)
258          (system::define-macro `(deftype ,name) expand-fn nil)                           (convert-to-system-type type2))))))))
         #+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)  
   ;; 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)))))  
   
259    
260    
261  (defvar *built-in-class-symbols* ())  (defvar *built-in-class-symbols* ())
# Line 376  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 398  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)))  
   
   
   
   
 ;;;  
 ;;; 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    
 (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)))  
   
295  (defun make-class-predicate-name (name)  (defun make-class-predicate-name (name)
296    (intern (let ((*package* *the-pcl-package*))    `(class-predicate ,name))
             (format nil "~S class predicate" name))  
           *the-pcl-package*))  
297    
298  (defun plist-value (object name)  (defun plist-value (object name)
299    (getf (object-plist object) name))    (getf (object-plist object) name))
300    
301  (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)  (defun (setf plist-value) (new-value object name)
302    (if new-value    (if new-value
303        (setf (getf (object-plist object) name) new-value)        (setf (getf (object-plist object) name) new-value)
304        (progn        (progn
# Line 485  Line 343 
343    
344      (symbol     (t)        (null)                   (t)      (symbol     (t)        (null)                   (t)
345       symbol)       symbol)
346      (null       (symbol      (null       (symbol
347                   list)   ()                       (symbol list sequence t)                   list)     ()                       (symbol list sequence t)
348       nil)))       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  ;;;  ;;;
380  ;;; The classes that define the kernel of the metabraid.  ;;; The classes that define the kernel of the metabraid.
# Line 496  Line 382 
382  (defclass t () ()  (defclass t () ()
383    (:metaclass built-in-class))    (:metaclass built-in-class))
384    
385    (defclass kernel:instance (t) ()
386      (:metaclass built-in-class))
387    
388    (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) ()  (defclass slot-object (t) ()
398    (:metaclass slot-class))    (:metaclass slot-class))
399    
400  (defclass structure-object (slot-object) ()  ;;;
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))    (:metaclass structure-class))
416    
417  (defstruct (structure-object  (defstruct (dead-beef-structure-object
418               (:constructor |STRUCTURE-OBJECT class constructor|)))               (:constructor |STRUCTURE-OBJECT class constructor|)))
419    
420  (defclass standard-object (slot-object) ())  (defclass standard-object (slot-object) ())
   
421  (defclass metaobject (standard-object) ())  (defclass metaobject (standard-object) ())
422    
423    (defclass funcallable-standard-object (standard-object
424                                           kernel:funcallable-instance)
425      ()
426      (:metaclass funcallable-standard-class))
427    
428  (defclass specializer (metaobject)  (defclass specializer (metaobject)
429       ((type    ((type
430          :initform nil      :initform nil
431          :reader specializer-type)))      :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)))      :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                   specializer)                                       definition-source-mixin
455       ((name                                       specializer
456          :initform nil                                       kernel:instance)
457          :initarg  :name    ((name
458          :accessor class-name)      :initform nil
459        (class-eq-specializer      :initarg  :name
460          :initform nil      :accessor class-name)
461          :reader class-eq-specializer)     (class-eq-specializer
462        (direct-superclasses      :initform nil
463          :initform ()      :reader class-eq-specializer)
464          :reader class-direct-superclasses)     (direct-superclasses
465        (direct-subclasses      :initform ()
466          :initform ()      :reader class-direct-superclasses)
467          :reader class-direct-subclasses)     (direct-subclasses
468        (direct-methods      :initform ()
469          :initform (cons nil nil))      :reader class-direct-subclasses)
470        (predicate-name     (direct-methods
471          :initform nil      :initform (cons nil nil))
472          :reader class-predicate-name)))     (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          :reader class-precedence-list)      :reader class-precedence-list)
486        (can-precede-list     (cpl-available-p
487          :initform ()      :reader cpl-available-p
488          :reader class-can-precede-list)      :initform nil)
489        (incompatible-superclass-list     (can-precede-list
490          :initform ()      :initform ()
491          :accessor class-incompatible-superclass-list)      :reader class-can-precede-list)
492        (wrapper     (incompatible-superclass-list
493          :initform nil      :initform ()
494          :reader class-wrapper)      :accessor class-incompatible-superclass-list)
495        (prototype     (wrapper
496          :initform nil      :initform nil
497          :reader class-prototype)))      :reader class-wrapper)
498       (prototype
499        :initform nil
500        :reader class-prototype)))
501    
502  (defclass slot-class (pcl-class)  (defclass slot-class (pcl-class)
503       ((direct-slots    ((direct-slots
504          :initform ()      :initform ()
505          :accessor class-direct-slots)      :accessor class-direct-slots)
506        (slots     (slots
507          :initform ()      :initform ()
508          :accessor class-slots)))      :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 (slot-class)  (defclass std-class (slot-class) ())
      ((no-of-instance-slots                 ;*** MOVE TO WRAPPER ***  
         :initform 0  
         :accessor class-no-of-instance-slots)))  
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)  (defclass structure-class (slot-class)
525       ((defstruct-form    ((defstruct-form
526          :initform ()       :initform ()
527          :accessor class-defstruct-form)       :accessor class-defstruct-form)
528        (defstruct-constructor     (defstruct-constructor
529          :initform nil       :initform nil
530          :accessor class-defstruct-constructor)       :accessor class-defstruct-constructor)
531        (from-defclass-p     (from-defclass-p
532          :initform nil      :initform nil
533          :initarg :from-defclass-p)))      :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) ())  (defclass specializer-with-object (specializer) ())
541    
542  (defclass exact-class-specializer (specializer) ())  (defclass exact-class-specializer (specializer) ())
543    
544  (defclass class-eq-specializer (exact-class-specializer specializer-with-object)  ;;;
545    ((object :initarg :class :reader specializer-class :reader specializer-object)))  ;;; 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)  (defclass eql-specializer (exact-class-specializer specializer-with-object)
567    ((object :initarg :object :reader specializer-object    ((object
568             :reader eql-specializer-object)))      :initarg :object
569        :reader specializer-object
570        :reader eql-specializer-object)))
571    
572  (defvar *eql-specializer-table* (make-hash-table :test 'eql))  (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)  (defun intern-eql-specializer (object)
581    (or (gethash object *eql-specializer-table*)    (or (gethash object *eql-specializer-table*)
582        (setf (gethash object *eql-specializer-table*)        (setf (gethash object *eql-specializer-table*)
# Line 638  Line 586 
586  ;;;  ;;;
587  ;;; Slot definitions.  ;;; Slot definitions.
588  ;;;  ;;;
 ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".  
 ;;;  
589  (defclass slot-definition (metaobject)  (defclass slot-definition (metaobject)
590       ((name    ((name
591          :initform nil      :initform nil
592          :initarg :name      :initarg :name
593          :accessor slot-definition-name)      :accessor slot-definition-name)
594        (initform     (initform
595          :initform nil      :initform nil
596          :initarg :initform      :initarg :initform
597          :accessor slot-definition-initform)      :accessor slot-definition-initform)
598        (initfunction     (initfunction
599          :initform nil      :initform nil
600          :initarg :initfunction      :initarg :initfunction
601          :accessor slot-definition-initfunction)      :accessor slot-definition-initfunction)
602        (readers     (readers
603          :initform nil      :initform nil
604          :initarg :readers      :initarg :readers
605          :accessor slot-definition-readers)      :accessor slot-definition-readers)
606        (writers     (writers
607          :initform nil      :initform nil
608          :initarg :writers      :initarg :writers
609          :accessor slot-definition-writers)      :accessor slot-definition-writers)
610        (initargs     (initargs
611          :initform nil      :initform nil
612          :initarg :initargs      :initarg :initargs
613          :accessor slot-definition-initargs)      :accessor slot-definition-initargs)
614        (type     (type
615          :initform t      :initform t
616          :initarg :type      :initarg :type
617          :accessor slot-definition-type)      :accessor slot-definition-type)
618        (documentation     (documentation
619          :initform ""      :initform ""
620          :initarg :documentation)      :initarg :documentation)
621        (class     (class
622          :initform nil      :initform nil
623          :initarg :class      :initarg :class
624          :accessor slot-definition-class)))      :accessor slot-definition-class)))
625    
626  (defclass standard-slot-definition (slot-definition)  (defclass standard-slot-definition (slot-definition)
627    ((allocation    ((allocation
628      :initform :instance      :initform :instance
629      :initarg :allocation      :initarg :allocation
630      :accessor slot-definition-allocation)))      :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)  (defclass structure-slot-definition (slot-definition)
640    ((defstruct-accessor-symbol    ((defstruct-accessor-symbol
# Line 697  Line 650 
650       :initarg :internal-writer-function       :initarg :internal-writer-function
651       :accessor slot-definition-internal-writer-function)))       :accessor slot-definition-internal-writer-function)))
652    
653    (defclass condition-slot-definition (standard-slot-definition)
654      ())
655    
656  (defclass direct-slot-definition (slot-definition)  (defclass direct-slot-definition (slot-definition)
657    ())    ())
658    
659  (defclass effective-slot-definition (slot-definition)  (defclass effective-slot-definition (slot-definition)
660    ((reader-function ; #'(lambda (object) ...)    ((reader-function ; (lambda (object) ...)
661      :accessor slot-definition-reader-function)      :accessor slot-definition-reader-function)
662     (writer-function ; #'(lambda (new-value object) ...)     (writer-function ; (lambda (new-value object) ...)
663      :accessor slot-definition-writer-function)      :accessor slot-definition-writer-function)
664     (boundp-function ; #'(lambda (object) ...)     (boundp-function ; (lambda (object) ...)
665      :accessor slot-definition-boundp-function)      :accessor slot-definition-boundp-function)
666     (accessor-flags     (accessor-flags
667      :initform 0)))      :initform 0)))
# Line 716  Line 672 
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    ((location ; nil, a fixnum, a cons: (slot-name . value)    ((location
676      :initform nil      :initform nil
677      :accessor slot-definition-location)))      :accessor slot-definition-location)))
678    
# Line 724  Line 680 
680                                              direct-slot-definition)                                              direct-slot-definition)
681    ())    ())
682    
683    (defclass condition-direct-slot-definition (condition-slot-definition
684                                                direct-slot-definition)
685      ())
686    
687  (defclass structure-effective-slot-definition (structure-slot-definition  (defclass structure-effective-slot-definition (structure-slot-definition
688                                                 effective-slot-definition)                                                 effective-slot-definition)
689    ())    ())
690    
691    (defclass condition-effective-slot-definition (condition-slot-definition
692                                                   effective-slot-definition)
693      ())
694    
695    (defclass method (metaobject) ())
696    
697    (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*  (defparameter *early-class-predicates*
800    '((specializer specializerp)    '((specializer specializerp)
801      (exact-class-specializer exact-class-specializer-p)      (exact-class-specializer exact-class-specializer-p)
802      (class-eq-specializer class-eq-specializer-p)      (class-eq-specializer class-eq-specializer-p)
803      (eql-specializer eql-specializer-p)      (eql-specializer eql-specializer-p)
804      (class classp)      (class classp)
805        (slot-class slot-class-p)
806        (std-class std-class-p)
807      (standard-class standard-class-p)      (standard-class standard-class-p)
808      (funcallable-standard-class funcallable-standard-class-p)      (funcallable-standard-class funcallable-standard-class-p)
809      (structure-class structure-class-p)      (structure-class structure-class-p)
810      (forward-referenced-class forward-referenced-class-p)))      (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.6.1.1  
changed lines
  Added in v.1.45

  ViewVC Help
Powered by ViewVC 1.1.5