/[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.26.2.1 by pmai, Fri Oct 4 23:14:07 2002 UTC revision 1.45 by rtoy, Fri Mar 19 15:19:03 2010 UTC
# 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    #-(or loadable-pcl bootable-pcl)
31  (eval-when (:compile-toplevel :load-toplevel :execute)  (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-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    ;;; These are retained only for backward compatibility.  They
45    ;;; are no longer used, and may be deleted at some point.
46    ;;;
47    (defvar *defclass-times*   () "Obsolete, don't use.")
48    (defvar *defmethod-times*  () "Obsolete, don't use.")
49    (defvar *defgeneric-times* () "Obsolete, don't use.")
50    
51    
52  ;;;  ;;;
# Line 63  Line 54 
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    ;;; Note that FDEFINITION takes care of encapsulations.  PROFILE
58    ;;; isn't using encapsulations, so it has to be treated specially.
59    ;;;
60  (declaim (inline gdefinition))  (declaim (inline gdefinition))
61  (defun gdefinition (symbol)  
62    (fdefinition symbol))  (defun gdefinition (name)
63      (fdefinition name))
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
# Line 75  Line 70 
70    (c::%%defun name new-definition nil)    (c::%%defun name new-definition nil)
71    (c::note-name-defined name :function)    (c::note-name-defined name :function)
72    new-definition)    new-definition)
73    
74    
75  (declaim (special *the-class-t*  (declaim (special *the-class-t*
76                    *the-class-vector* *the-class-symbol*                    *the-class-vector* *the-class-symbol*
# Line 84  Line 80 
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*
                   #-fundamental-types  
83                    *the-class-stream*                    *the-class-stream*
                   #+fundamental-types  
                   *the-class-package*  
84    
85                    *the-class-slot-object*                    *the-class-slot-object*
86                    *the-class-structure-object*                    *the-class-structure-object*
                   *the-class-std-object*  
87                    *the-class-standard-object*                    *the-class-standard-object*
88                    *the-class-funcallable-standard-object*                    *the-class-funcallable-standard-object*
89                    *the-class-class*                    *the-class-class*
90                    *the-class-generic-function*                    *the-class-generic-function*
91                    *the-class-built-in-class*                    *the-class-built-in-class*
92                    *the-class-slot-class*                    *the-class-slot-class*
                   *the-class-structure-class*  
93                    *the-class-std-class*                    *the-class-std-class*
94                      *the-class-condition-class*
95                      *the-class-structure-class*
96                    *the-class-standard-class*                    *the-class-standard-class*
97                    *the-class-funcallable-standard-class*                    *the-class-funcallable-standard-class*
98                    *the-class-method*                    *the-class-method*
# Line 140  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          ((and (null args) (typep type 'lisp:class))          ((and (null args) (typep type 'kernel::class))
139           (or (kernel:class-pcl-class type)           (or (kernel:%class-pcl-class type)
140               (find-structure-class (lisp:class-name type))))               (ensure-non-standard-class (kernel:%class-name type))))
141          ((specializerp type) type)))          ((specializerp type) type)))
142    
143  ;;; interface  ;;; interface
# Line 154  Line 145 
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 165  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*))
# Line 173  Line 164 
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 196  Line 186 
186    ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.    ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
187    (declare (ignorable name))    (declare (ignorable name))
188    (when (and (eq *boot-state* 'complete)    (when (and (eq *boot-state* 'complete)
189               (null (lisp:find-class name nil)))               (null (kernel::find-class name nil)))
190      (setf (lisp:find-class name)      (setf (kernel::find-class name)
191            (lisp::make-standard-class :name name))))            (kernel::make-standard-class :name name))))
192    
193  ;;; Internal to this file.  ;;; Internal to this file.
194  ;;;  ;;;
# Line 222  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))))
216    
217  ;;; internal to this file...  ;;; internal to this file...
218  (defun convert-to-system-type (type)  (defun convert-to-system-type (type)
# Line 273  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 297  Line 283 
283    
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          (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    
293    
294    
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))
# Line 360  Line 348 
348       nil)))       nil)))
349    
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 stream                                   function stream))
                                 #+fundamental-types cl:package))  
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 409  Line 391 
391  (defclass kernel:funcallable-instance (function) ()  (defclass kernel:funcallable-instance (function) ()
392    (:metaclass built-in-class))    (:metaclass built-in-class))
393    
 #-fundamental-types  
394  (defclass stream (kernel:instance) ()  (defclass stream (kernel:instance) ()
395    (:metaclass built-in-class))    (:metaclass built-in-class))
396    
 #+fundamental-types  
 (macrolet ((frob (entries)  
             `(declaim (special  
                         ,@(mapcar  
                            #'(lambda (entry)  
                                (destructuring-bind (super &rest args) entry  
                                  (declare (ignore args))  
                                  (intern (format nil "*THE-CLASS-~A"  
                                                      (symbol-name super)))))  
                               (if (boundp entries)  
                                   (symbol-value entries)  
                                   nil))))))  
   (frob kernel::*fundamental-structure-bootstrap-info*))  
   
 #+fundamental-types  
 (macrolet ((frob (entries)  
             `(progn  
                ,@(mapcar  
                   #'(lambda (entry)  
                       (destructuring-bind (super &rest args) entry  
                         (declare (ignore args))  
                         `(defclass ,super (kernel:instance) ()  
                            (:metaclass built-in-class))))  
                     (if (boundp entries)  
                         (symbol-value entries)  
                         nil)))))  
   (frob kernel::*fundamental-structure-bootstrap-info*))  
   
397  (defclass slot-object (t) ()  (defclass slot-object (t) ()
398    (:metaclass slot-class))    (:metaclass slot-class))
399    
400    ;;;
401    ;;; In a host Lisp with intact PCL, the DEFCLASS below would normally
402    ;;; generate a DEFSTRUCT with :INCLUDE SLOT-OBJECT.  SLOT-OBJECT is
403    ;;; not a structure, so this would give an error.  Likewise,
404    ;;; KERNEL:INSTANCE is a BUILT-IN-CLASS, not a structure class, so
405    ;;; this would give an error, too.
406    ;;;
407    ;;; When PCL is bootstrapped normally, *BOOT-STATE* is not COMPLETE at
408    ;;; this point, which means that a DEFSTRUCT is not done, because
409    ;;; EXPAND-DEFCLASS looks at the boot state.
410    ;;;
411    ;;; I've modified EXPAND-DEFCLASS accordingly to not do a DEFSTRUCT
412    ;;; when a loadable or bootable PCL is built.
413    ;;;
414  (defclass structure-object (slot-object kernel:instance) ()  (defclass structure-object (slot-object kernel:instance) ()
415    (:metaclass structure-class))    (:metaclass structure-class))
416    
417  (defstruct (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) ())
421    (defclass metaobject (standard-object) ())
422    
423  (defclass std-object (slot-object) ()  (defclass funcallable-standard-object (standard-object
424    (:metaclass std-class))                                         kernel:funcallable-instance)
425      ()
426      (:metaclass funcallable-standard-class))
427    
428  (defclass standard-object (std-object kernel:instance) ())  (defclass specializer (metaobject)
429      ((type
430        :initform nil
431        :reader specializer-type)))
432    
433  (defclass funcallable-standard-object (std-object kernel:funcallable-instance)  (defclass definition-source-mixin (standard-object)
434       ()    ((source
435    (:metaclass funcallable-standard-class))      :initform *load-pathname*
436        :reader definition-source
437        :initarg :definition-source)))
438    
439    (defclass plist-mixin (standard-object)
440      ((plist
441        :initform ()
442        :accessor object-plist)))
443    
444    (defclass documentation-mixin (plist-mixin) ())
445    
446  (defclass specializer (standard-object)  (defclass dependent-update-mixin (plist-mixin) ())
      ((type  
         :initform nil  
         :reader specializer-type)))  
   
 (defclass definition-source-mixin (std-object)  
      ((source  
         :initform (load-truename)  
         :reader definition-source  
         :initarg :definition-source))  
   (:metaclass std-class))  
   
 (defclass plist-mixin (std-object)  
      ((plist  
         :initform ()  
         :accessor object-plist))  
   (:metaclass std-class))  
   
 (defclass documentation-mixin (plist-mixin)  
      ()  
   (:metaclass std-class))  
   
 (defclass dependent-update-mixin (plist-mixin)  
     ()  
   (:metaclass std-class))  
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 597  Line 586 
586  ;;;  ;;;
587  ;;; Slot definitions.  ;;; Slot definitions.
588  ;;;  ;;;
589  (defclass slot-definition (standard-object)  (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 654  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    
# Line 673  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 681  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 method (standard-object) ())  (defclass condition-effective-slot-definition (condition-slot-definition
692                                                   effective-slot-definition)
693      ())
694    
695    (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 733  Line 733 
733  (defclass generic-function (dependent-update-mixin  (defclass generic-function (dependent-update-mixin
734                              definition-source-mixin                              definition-source-mixin
735                              documentation-mixin                              documentation-mixin
736                                metaobject
737                              funcallable-standard-object)                              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 (standard-object) ())  (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 787  Line 807 
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 796  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.26.2.1  
changed lines
  Added in v.1.45

  ViewVC Help
Powered by ViewVC 1.1.5