/[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.10.1.6 by ram, Fri Oct 28 21:20:58 1994 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  ;;; *************************************************************************  ;;; *************************************************************************
 ;;;  
26    
27  (in-package :pcl)  (in-package :pcl)
28    (intl:textdomain "cmucl")
29    
30  (eval-when (compile load eval)  #-(or loadable-pcl bootable-pcl)
31    (eval-when (:compile-toplevel :load-toplevel :execute)
 (defvar *defclass-times*   '(load eval))        ;Probably have to change this  
                                                 ;if you use defconstructor.  
 (defvar *defmethod-times*  '(load eval))  
 (defvar *defgeneric-times* '(load eval))  
   
 ; defvar is now actually in macros  
 ;(defvar *boot-state* ())                       ;NIL  
                                                 ;EARLY  
                                                 ;BRAID  
                                                 ;COMPLETE  
 (defvar *fegf-started-p* nil)  
   
   
 )  
   
 (eval-when (load eval)  
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))  
   #+setf (declare (ignore setf-var setf-case))  
   (once-only (spec)  
     `(cond (#-setf (symbolp ,spec) #+setf t  
             (let ((,non-setf-var ,spec)) ,@non-setf-case))  
            #-setf  
            ((and (listp ,spec)  
                  (eq (car ,spec) 'setf)  
                  (symbolp (cadr ,spec)))  
             (let ((,setf-var (cadr ,spec))) ,@setf-case))  
            #-setf  
            (t  
             (error  
               "Can't understand ~S as a generic function specifier.~%~  
                It must be either a symbol which can name a function or~%~  
                a list like ~S, where the car is the symbol ~S and the cadr~%~  
                is a symbol which can name a generic function."  
               ,spec '(setf <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))
   #+kcl (symbol-function  
           (let ((sym (get symbol 'si::traced)) first-form)  
             (if (and sym  
                      (consp (symbol-function symbol))  
                      (consp (setq first-form (nth 3 (symbol-function symbol))))  
                      (eq (car first-form) 'si::trace-call))  
                 sym  
                 symbol)))  
   #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol))  
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 (name new-definition)  (defun (setf gdefinition) (new-definition name)
70    #+Lispm (si:fdefine name new-definition t t)    (c::%%defun name new-definition nil)
71    #+Lucid (let ((lucid::*redefinition-action* nil))    (c::note-name-defined name :function)
72              (setf (symbol-function name) new-definition))    new-definition)
   #+excl  (setf (symbol-function name) new-definition)  
   #+xerox (let ((advisedp (member name il:advisedfns :test #'eq))  
                 (brokenp (member name il:brokenfns :test #'eq)))  
             ;; In XeroxLisp (late of envos) tracing is implemented  
             ;; as a special case of "breaking".  Advising, however,  
             ;; is treated specially.  
             (xcl:unadvise-function name :no-error t)  
             (xcl:unbreak-function name :no-error t)  
             (setf (symbol-function name) new-definition)  
             (when brokenp (xcl:rebreak-function name))  
             (when advisedp (xcl:readvise-function name)))  
   #+(and setf (not cmu)) (setf (fdefinition name) new-definition)  
   #+kcl (setf (symbol-function  
                (let ((sym (get name 'si::traced)) first-form)  
                  (if (and sym  
                           (consp (symbol-function name))  
                           (consp (setq first-form  
                                        (nth 3 (symbol-function name))))  
                           (eq (car first-form) 'si::trace-call))  
                      sym  
                      name)))  
               new-definition)  
   #+cmu (progn  
           (c::%%defun name new-definition nil)  
           (c::note-name-defined name :function)  
           new-definition)  
   #-(or Lispm Lucid excl Xerox setf kcl cmu)  
   (setf (symbol-function name) new-definition))  
   
 (defun gboundp (spec)  
   (parse-gspec spec  
     (name (fboundp name))  
     (name (fboundp (get-setf-function-name name)))))  
   
 (defun gmakunbound (spec)  
   (parse-gspec spec  
     (name (fmakunbound name))  
     (name (fmakunbound (get-setf-function-name name)))))  
   
 (defun gdefinition (spec)  
   (parse-gspec spec  
     (name (or #-setf (macro-function name)              ;??  
               (unencapsulated-fdefinition name)))  
     (name (unencapsulated-fdefinition (get-setf-function-name name)))))  
   
 (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)  
   (parse-gspec spec  
     (name (fdefine-carefully name new-value))  
     (name (fdefine-carefully (get-setf-function-name name) new-value))))  
73    
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-generic-function*                    *the-class-funcallable-standard-object*
89                      *the-class-built-in-class*                    *the-class-class*
90                      *the-class-slot-class*                    *the-class-generic-function*
91                      *the-class-structure-class*                    *the-class-built-in-class*
92                      *the-class-standard-class*                    *the-class-slot-class*
93                      *the-class-funcallable-standard-class*                    *the-class-std-class*
94                      *the-class-method*                    *the-class-condition-class*
95                      *the-class-standard-method*                    *the-class-structure-class*
96                      *the-class-standard-reader-method*                    *the-class-standard-class*
97                      *the-class-standard-writer-method*                    *the-class-funcallable-standard-class*
98                      *the-class-standard-boundp-method*                    *the-class-method*
99                      *the-class-standard-generic-function*                    *the-class-standard-method*
100                      *the-class-standard-effective-slot-definition*                    *the-class-standard-reader-method*
101                      *the-class-standard-writer-method*
102                      *the-eslotd-standard-class-slots*                    *the-class-standard-boundp-method*
103                      *the-eslotd-funcallable-standard-class-slots*))                    *the-class-standard-generic-function*
104                      *the-class-standard-effective-slot-definition*
105  (proclaim '(special *the-wrapper-of-t*  
106                      *the-wrapper-of-vector* *the-wrapper-of-symbol*                    *the-eslotd-standard-class-slots*
107                      *the-wrapper-of-string* *the-wrapper-of-sequence*                    *the-eslotd-funcallable-standard-class-slots*))
108                      *the-wrapper-of-rational* *the-wrapper-of-ratio*  
109                      *the-wrapper-of-number* *the-wrapper-of-null*  (declaim (special *the-wrapper-of-t*
110                      *the-wrapper-of-list* *the-wrapper-of-integer*                    *the-wrapper-of-vector* *the-wrapper-of-symbol*
111                      *the-wrapper-of-float* *the-wrapper-of-cons*                    *the-wrapper-of-string* *the-wrapper-of-sequence*
112                      *the-wrapper-of-complex* *the-wrapper-of-character*                    *the-wrapper-of-rational* *the-wrapper-of-ratio*
113                      *the-wrapper-of-bit-vector* *the-wrapper-of-array*))                    *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:  ;;;; Type specifier hackery:
120    
# Line 231  Line 133 
133           (or (and (null args) (find-class type))           (or (and (null args) (find-class type))
134               (ecase type               (ecase type
135                 (class    (coerce-to-class (car args)))                 (class    (coerce-to-class (car args)))
                (prototype (make-instance 'class-prototype-specializer  
                                          :object (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          #+cmu17          ((and (null args) (typep type 'kernel::class))
139          ((and (null args) (typep type 'lisp:class))           (or (kernel:%class-pcl-class type)
140           (or (kernel:class-pcl-class type)               (ensure-non-standard-class (kernel:%class-name type))))
              (find-structure-class (lisp:class-name type))))  
141          ((specializerp type) type)))          ((specializerp type) type)))
142    
143  ;;; interface  ;;; interface
144  (defun type-from-specializer (specl)  (defun type-from-specializer (specl)
145    (cond ((eq specl 't)    (cond ((eq specl t)
146           't)           t)
147          ((consp specl)          ((consp specl)
148           (unless (member (car specl) '(class prototype 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          ((progn          ((progn
152             (when (symbolp specl)             (when (symbolp specl)
# Line 257  Line 156 
156                 (specializerp specl)))                 (specializerp specl)))
157           (specializer-type specl))           (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        (if (eq type 't)        (if (eq type t)
166            *the-class-t*            *the-class-t*
167            (error "bad argument to type-class"))            (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)))
         (prototype (class-of (cadr type))) ;?  
170          (class-eq (cadr type))          (class-eq (cadr type))
171          (class (cadr type)))))          (class (cadr type)))))
172    
# Line 276  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 (gdefinition 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)))  
 ||#  
   
 #-(or excl cmu17)  
 (deftype eql (type-object)  
   `(member ,type-object))  
   
192    
193  ;;; Internal to this file.  ;;; Internal to this file.
194  ;;;  ;;;
# Line 337  Line 212 
212               (specializerp type))               (specializerp type))
213           (specializer-type type))           (specializer-type type))
214          (t          (t
215           (error "~s is not a type" type))))           (error _"~s is not a type." type))))
   
 ;;; Not used...  
 #+nil  
 (defun unparse-type-list (tlist)  
   (mapcar #'unparse-type tlist))  
   
 ;;; Not used...  
 #+nil  
 (defun unparse-type (type)  
   (if (atom type)  
       (if (specializerp type)  
           (unparse-type (specializer-type type))  
           type)  
       (case (car type)  
         (eql type)  
         (class-eq `(class-eq ,(class-name (cadr type))))  
         (class (class-name (cadr type)))  
         (t `(,(car type) ,@(unparse-type-list (cdr type)))))))  
216    
217  ;;; internal to this file...  ;;; internal to this file...
218  (defun convert-to-system-type (type)  (defun convert-to-system-type (type)
# Line 363  Line 220 
220      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
221                                            (cdr type))))                                            (cdr type))))
222      ((class class-eq) ; class-eq is impossible to do right      ((class class-eq) ; class-eq is impossible to do right
223       #-cmu17 (class-name (cadr type))       (kernel:layout-class (class-wrapper (cadr type))))
      #+cmu17 (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    
 ;;; not used...  
 #+nil  
 (defun *typep (object type)  
   (setq type (*normalize-type type))  
   (cond ((member (car type) '(eql wrapper-eq class-eq class))  
          (specializer-applicable-using-type-p type `(eql ,object)))  
         ((eq (car type) 'not)  
          (not (*typep object (cadr type))))  
         (t  
          (typep object (convert-to-system-type type)))))  
   
229    
230  ;;; *SUBTYPEP  --  Interface  ;;; *SUBTYPEP  --  Interface
231  ;;;  ;;;
# Line 411  Line 256 
256                (t                (t
257                 (subtypep (convert-to-system-type type1)                 (subtypep (convert-to-system-type type1)
258                           (convert-to-system-type type2))))))))                           (convert-to-system-type type2))))))))
   
 (defun do-satisfies-deftype (name predicate)  
   #+cmu17 (declare (ignore name predicate))  
   #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)  
   (let* ((specifier `(satisfies ,predicate))  
          (expand-fn #'(lambda (&rest ignore)  
                         (declare (ignore ignore))  
                         specifier)))  
     ;; Specific ports can insert their own way of doing this.  Many  
     ;; ports may find the expand-fn defined above useful.  
     ;;  
     (or #+:Genera  
         (setf (get name 'deftype) expand-fn)  
         #+(and :Lucid (not :Prime))  
         (system::define-macro `(deftype ,name) expand-fn nil)  
         #+ExCL  
         (setf (get name 'excl::deftype-expander) expand-fn)  
         #+:coral  
         (setf (get name 'ccl::deftype-expander) expand-fn)))  
   #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17)  
   ;; This is the default for ports for which we don't know any  
   ;; better.  Note that for most ports, providing this definition  
   ;; should just speed up class definition.  It shouldn't have an  
   ;; effect on performance of most user code.  
   (eval `(deftype ,name () '(satisfies ,predicate))))  
   
 (defun make-type-predicate-name (name &optional kind)  
   (if (symbol-package name)  
       (intern (format nil  
                       "~@[~A ~]TYPE-PREDICATE ~A ~A"  
                       kind  
                       (package-name (symbol-package name))  
                       (symbol-name name))  
               *the-pcl-package*)  
       (make-symbol (format nil  
                            "~@[~A ~]TYPE-PREDICATE ~A"  
                            kind  
                            (symbol-name name)))))  
   
259    
260    
261  (defvar *built-in-class-symbols* ())  (defvar *built-in-class-symbols* ())
# Line 457  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 479  Line 281 
281  (pushnew 'class *variable-declarations*)  (pushnew 'class *variable-declarations*)
282  (pushnew 'variable-rebinding *variable-declarations*)  (pushnew 'variable-rebinding *variable-declarations*)
283    
 (defun variable-class (var env)  
   (caddr (variable-declaration 'class var env)))  
   
284  (defvar *name->class->slotd-table* (make-hash-table))  (defvar *name->class->slotd-table* (make-hash-table))
285    
286    (defun slot-name->class-table (slot-name)
287  ;;;    (or (gethash slot-name *name->class->slotd-table*)
288  ;;; This is used by combined methods to communicate the next methods to        (setf (gethash slot-name *name->class->slotd-table*)
289  ;;; the methods they call.  This variable is captured by a lexical variable              (make-hash-table :test 'eq :size 5))))
 ;;; 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* ())  
   
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 (format nil "~A::~A class predicate"    `(class-predicate ,name))
                   (package-name (symbol-package name))  
                   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 571  Line 347 
347                   list)     ()                       (symbol list sequence t)                   list)     ()                       (symbol list sequence t)
348       nil)))       nil)))
349    
 #+cmu17  
350  (labels ((direct-supers (class)  (labels ((direct-supers (class)
351             (if (typep class 'lisp:built-in-class)             (if (typep class 'kernel::built-in-class)
352                 (kernel:built-in-class-direct-superclasses class)                 (kernel:built-in-class-direct-superclasses class)
353                 (let ((inherits (kernel:layout-inherits                 (let ((inherits (kernel:layout-inherits
354                                  (kernel:class-layout class))))                                  (kernel:%class-layout class))))
355                   (list (svref inherits (1- (length inherits)))))))                   (list (svref inherits (1- (length inherits)))))))
356           (direct-subs (class)           (direct-subs (class)
357             (ext:collect ((res))             (collect ((res))
358               (let ((subs (kernel:class-subclasses class)))               (let ((subs (kernel:%class-subclasses class)))
359                 (when subs                 (when subs
360                   (ext:do-hash (sub v subs)                   (do-hash (sub v subs)
361                     (declare (ignore v))                     (declare (ignore v))
362                     (when (member class (direct-supers sub))                     (when (member class (direct-supers sub))
363                       (res sub)))))                       (res sub)))))
364               (res))))               (res))))
365    (ext:collect ((res))    (collect ((res))
366      (dolist (bic kernel::built-in-classes)      (dolist (bic kernel::built-in-classes)
367        (let* ((name (car bic))        (let* ((name (car bic))
368               (class (lisp:find-class name)))               (class (kernel::find-class name)))
369          (unless (member name '(t kernel:instance kernel:funcallable-instance          (unless (member name '(t kernel:instance kernel:funcallable-instance
370                                   function))                                   function stream))
371            (res `(,name            (res `(,name
372                   ,(mapcar #'lisp:class-name (direct-supers class))                   ,(mapcar #'kernel:%class-name (direct-supers class))
373                   ,(mapcar #'lisp:class-name (direct-subs class))                   ,(mapcar #'kernel:%class-name (direct-subs class))
                  ,(map 'list #'(lambda (x)  
                                  (lisp:class-name (kernel:layout-class x)))  
                        (reverse  
                         (kernel:layout-inherits  
                          (kernel:class-layout class))))  
374                   ,(let ((found (assoc name *built-in-classes*)))                   ,(let ((found (assoc name *built-in-classes*)))
375                      (if found (fifth found) 42)))))))                      (if found (fifth found) 42)))))))
376      (setq *built-in-classes* (res))))      (setq *built-in-classes* (res))))
# Line 612  Line 382 
382  (defclass t () ()  (defclass t () ()
383    (:metaclass built-in-class))    (:metaclass built-in-class))
384    
385  #+cmu17  (defclass kernel:instance (t) ()
386  (progn    (:metaclass built-in-class))
387    (defclass kernel:instance (t) ()  
388      (:metaclass built-in-class))  (defclass function (t) ()
389      (:metaclass built-in-class))
390    (defclass function (t) ()  
391      (:metaclass built-in-class))  (defclass kernel:funcallable-instance (function) ()
392      (:metaclass built-in-class))
393    
394    (defclass kernel:funcallable-instance (function) ()  (defclass stream (kernel:instance) ()
395      (:metaclass built-in-class)))    (:metaclass built-in-class))
396    
397  (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) ()  (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 (#-cmu17 structure-object #+cmu17 dead-beef-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)))
       (initialize-info  
         :initform nil  
         :accessor class-initialize-info)))  
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) ())
      ())  
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  (defclass class-prototype-specializer (specializer-with-object)  ;;;
548    ((object :initarg :class :reader specializer-class :reader specializer-object)))  ;;; (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 771  Line 587 
587  ;;; Slot definitions.  ;;; Slot definitions.
588  ;;;  ;;;
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 827  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 846  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 854  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) ())  (defclass method (metaobject) ())
696    
697  (defclass standard-method (definition-source-mixin plist-mixin method)  (defclass standard-method (method definition-source-mixin documentation-mixin)
698       ((generic-function    ((generic-function
699          :initform nil      :initform nil
700          :accessor method-generic-function)      :accessor method-generic-function)
701  ;     (qualifiers     (specializers
702  ;       :initform ()      :initform ()
703  ;       :initarg  :qualifiers      :initarg  :specializers
704  ;       :reader method-qualifiers)      :reader method-specializers)
705        (specializers     (lambda-list
706          :initform ()      :initform ()
707          :initarg  :specializers      :initarg  :lambda-list
708          :reader method-specializers)      :reader method-lambda-list)
709        (lambda-list     (function
710          :initform ()      :initform nil
711          :initarg  :lambda-list      :initarg :function)
712          :reader method-lambda-list)     (fast-function
713        (function      :initform nil
714          :initform nil      :initarg :fast-function
715          :initarg :function)             ;no writer      :reader method-fast-function)))
       (fast-function  
         :initform nil  
         :initarg :fast-function         ;no writer  
         :reader method-fast-function)  
 ;     (documentation  
 ;       :initform nil  
 ;       :initarg  :documentation  
 ;       :reader method-documentation)  
       ))  
716    
717  (defclass standard-accessor-method (standard-method)  (defclass standard-accessor-method (standard-method)
718       ((slot-name :initform nil    ((slot-name
719                   :initarg :slot-name      :initform nil
720                   :reader accessor-method-slot-name)      :initarg :slot-name
721        (slot-definition :initform nil      :reader accessor-method-slot-name)
722                         :initarg :slot-definition     (slot-definition
723                         :reader accessor-method-slot-definition)))      :initform nil
724        :initarg :slot-definition
725        :reader accessor-method-slot-definition)))
726    
727  (defclass standard-reader-method (standard-accessor-method) ())  (defclass standard-reader-method (standard-accessor-method) ())
728    
# Line 907  Line 734 
734                              definition-source-mixin                              definition-source-mixin
735                              documentation-mixin                              documentation-mixin
736                              metaobject                              metaobject
737                              #+cmu17 kernel:funcallable-instance)                              funcallable-standard-object)
738       ()    ()
739    (:metaclass funcallable-standard-class))    (:metaclass funcallable-standard-class))
740    
741  (defclass standard-generic-function (generic-function)  (defclass standard-generic-function (generic-function)
742       ((name    ((name
743          :initform nil      :initform nil
744          :initarg :name      :initarg :name
745          :accessor generic-function-name)      :accessor generic-function-name)
746        (methods     (methods
747          :initform ()      :initform ()
748          :accessor generic-function-methods)      :accessor generic-function-methods)
749        (method-class     (method-class
750          :initarg :method-class      :initarg :method-class
751          :accessor generic-function-method-class)      :accessor generic-function-method-class)
752        (method-combination     (method-combination
753          :initarg :method-combination      :initarg :method-combination
754          :accessor generic-function-method-combination)      :accessor generic-function-method-combination)
755        (arg-info     (arg-info
756          :initform (make-arg-info)      :initform (make-arg-info)
757          :reader gf-arg-info)      :reader gf-arg-info)
758        (dfun-state     (dfun-state
759          :initform ()      :initform ()
760          :accessor gf-dfun-state)      :accessor gf-dfun-state)
761        (pretty-arglist     (pretty-arglist
762          :initform ()      :initform ()
763          :accessor gf-pretty-arglist)      :accessor gf-pretty-arglist)
764        )     (declarations
765        :initform ()
766        :initarg :declarations
767        :reader generic-function-declarations))
768    (:metaclass funcallable-standard-class)    (:metaclass funcallable-standard-class)
769    (:default-initargs :method-class *the-class-standard-method*    (:default-initargs :method-class *the-class-standard-method*
770                       :method-combination *standard-method-combination*))      :method-combination *standard-method-combination*))
771    
772  (defclass method-combination (metaobject) ())  (defclass method-combination (metaobject) ())
773    
774  (defclass standard-method-combination  (defclass standard-method-combination
775            (definition-source-mixin method-combination)      (definition-source-mixin method-combination)
776       ((type          :reader method-combination-type    ((type
777                       :initarg :type)      :reader method-combination-type
778        (documentation :reader method-combination-documentation      :initarg :type)
779                       :initarg :documentation)     (documentation
780        (options       :reader method-combination-options      :reader method-combination-documentation
781                       :initarg :options)))      :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)
# Line 957  Line 803 
803      (eql-specializer eql-specializer-p)      (eql-specializer eql-specializer-p)
804      (class classp)      (class classp)
805      (slot-class slot-class-p)      (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        (condition-class condition-class-p)
811      (forward-referenced-class forward-referenced-class-p)      (forward-referenced-class forward-referenced-class-p)
812      (method method-p)      (method method-p)
813      (standard-method standard-method-p)      (standard-method standard-method-p)
# Line 969  Line 817 
817      (standard-boundp-method standard-boundp-method-p)      (standard-boundp-method standard-boundp-method-p)
818      (generic-function generic-function-p)      (generic-function generic-function-p)
819      (standard-generic-function standard-generic-function-p)      (standard-generic-function standard-generic-function-p)
820      (method-combination method-combination-p)))      (method-combination method-combination-p)
821        (long-method-combination long-method-combination-p)))
822    
823    

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

  ViewVC Help
Powered by ViewVC 1.1.5