/[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.33 by gerd, Thu Feb 6 15:20:12 2003 UTC revision 1.34 by gerd, Sat Mar 22 16:15:17 2003 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    
29    #-(or loadable-pcl bootable-pcl)
30  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
   ;; Probably have to add 'compile' if you use defconstructor.  
   (defvar *defclass-times*   '(load eval))  
   
   (defvar *defmethod-times*  '(load eval))  
   (defvar *defgeneric-times* '(load eval))  
   
31    (when (eq *boot-state* 'complete)    (when (eq *boot-state* 'complete)
32      (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 ~
33              has already been loaded.  This doesn't work, you will have to~%~              has already been loaded.  This doesn't work, you will have to ~
34              get a fresh lisp (reboot) and then load PCL."))              get a fresh lisp (reboot) and then load PCL.~@:>"))
35    
36    (when *boot-state*    (when *boot-state*
37      (cerror "Try loading (or compiling) PCL anyways."      (cerror "Try loading (or compiling) PCL anyways."
38              "Trying to load (or compile) PCL in an environment in which it~%~              "~@<Trying to load (or compile) PCL in an environment in which it ~
39               has already been partially loaded.  This may not work, you may~%~               has already been partially loaded.  This may not work, you may ~
40               need to get a fresh lisp (reboot) and then load PCL.")))               need to get a fresh lisp (reboot) and then load PCL.~@:>")))
41    
42    ;;;
43    ;;; These are retained only for backward compatibility.  They
44    ;;; are no longer used, and may be deleted at some point.
45    ;;;
46    (defvar *defclass-times*   () "Obsolete, don't use.")
47    (defvar *defmethod-times*  () "Obsolete, don't use.")
48    (defvar *defgeneric-times* () "Obsolete, don't use.")
49    
50    
51  ;;;  ;;;
# Line 52  Line 53 
53  ;;; unadvised, traced etc. definition.  This lets me get at the generic  ;;; unadvised, traced etc. definition.  This lets me get at the generic
54  ;;; function object even when it is traced.  ;;; function object even when it is traced.
55  ;;;  ;;;
56    ;;; Note that FDEFINITION takes care of encapsulations.  PROFILE
57    ;;; isn't using encapsulations, so it has to be treated specially.
58    ;;;
59  (declaim (inline gdefinition))  (declaim (inline gdefinition))
60  (defun gdefinition (symbol)  
61    (fdefinition symbol))  (defun gdefinition (name)
62      (let ((fdefn (fdefinition name))
63            (info (gethash name profile::*profile-info*)))
64        (if (and info
65                 (eq fdefn (profile::profile-info-new-definition info)))
66            (profile::profile-info-old-definition info)
67            fdefn)))
68    
69  ;;;  ;;;
70  ;;; If symbol names a function which is traced or advised, redefine  ;;; If symbol names a function which is traced or advised, redefine
# Line 64  Line 74 
74    (c::%%defun name new-definition nil)    (c::%%defun name new-definition nil)
75    (c::note-name-defined name :function)    (c::note-name-defined name :function)
76    new-definition)    new-definition)
77    
78    
79  (declaim (special *the-class-t*  (declaim (special *the-class-t*
80                    *the-class-vector* *the-class-symbol*                    *the-class-vector* *the-class-symbol*
# Line 126  Line 137 
137           (or (and (null args) (find-class type))           (or (and (null args) (find-class type))
138               (ecase type               (ecase type
139                 (class    (coerce-to-class (car args)))                 (class    (coerce-to-class (car args)))
                (prototype (make-instance 'class-prototype-specializer  
                                          :object (coerce-to-class (car args))))  
140                 (class-eq (class-eq-specializer (coerce-to-class (car args))))                 (class-eq (class-eq-specializer (coerce-to-class (car args))))
141                 (eql      (intern-eql-specializer (car args))))))                 (eql      (intern-eql-specializer (car args))))))
142          ((and (null args) (typep type 'lisp:class))          ((and (null args) (typep type 'kernel::class))
143           (or (kernel:class-pcl-class type)           (or (kernel:%class-pcl-class type)
144               (find-structure-class (lisp:class-name type))))               (ensure-non-standard-class (kernel:%class-name type))))
145          ((specializerp type) type)))          ((specializerp type) type)))
146    
147  ;;; interface  ;;; interface
# Line 140  Line 149 
149    (cond ((eq specl t)    (cond ((eq specl t)
150           t)           t)
151          ((consp specl)          ((consp specl)
152           (unless (member (car specl) '(class prototype class-eq eql))           (unless (member (car specl) '(class class-eq eql))
153             (error "~S is not a legal specializer type" specl))             (error "~@<~S is not a legal specializer type.~@:>" specl))
154           specl)           specl)
155          ((progn          ((progn
156             (when (symbolp specl)             (when (symbolp specl)
# Line 151  Line 160 
160                 (specializerp specl)))                 (specializerp specl)))
161           (specializer-type specl))           (specializer-type specl))
162          (t          (t
163           (error "~s is neither a type nor a specializer" specl))))           (error "~@<~s is neither a type nor a specializer.~@:>" specl))))
164    
165  (defun type-class (type)  (defun type-class (type)
166    (declare (special *the-class-t*))    (declare (special *the-class-t*))
# Line 159  Line 168 
168    (if (atom type)    (if (atom type)
169        (if (eq type t)        (if (eq type t)
170            *the-class-t*            *the-class-t*
171            (error "bad argument to type-class"))            (internal-error "Bad argument to type-class."))
172        (case (car type)        (case (car type)
173          (eql (class-of (cadr type)))          (eql (class-of (cadr type)))
         (prototype (class-of (cadr type))) ;?  
174          (class-eq (cadr type))          (class-eq (cadr type))
175          (class (cadr type)))))          (class (cadr type)))))
176    
# Line 182  Line 190 
190    ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.    ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
191    (declare (ignorable name))    (declare (ignorable name))
192    (when (and (eq *boot-state* 'complete)    (when (and (eq *boot-state* 'complete)
193               (null (lisp:find-class name nil)))               (null (kernel::find-class name nil)))
194      (setf (lisp:find-class name)      (setf (kernel::find-class name)
195            (lisp::make-standard-class :name name))))            (kernel::make-standard-class :name name))))
196    
197  ;;; Internal to this file.  ;;; Internal to this file.
198  ;;;  ;;;
# Line 208  Line 216 
216               (specializerp type))               (specializerp type))
217           (specializer-type type))           (specializer-type type))
218          (t          (t
219           (error "~s is not a type" type))))           (error "~s is not a type." type))))
220    
221  ;;; internal to this file...  ;;; internal to this file...
222  (defun convert-to-system-type (type)  (defun convert-to-system-type (type)
# Line 259  Line 267 
267    
268  (defun get-built-in-class-symbol (class-name)  (defun get-built-in-class-symbol (class-name)
269    (or (cadr (assq class-name *built-in-class-symbols*))    (or (cadr (assq class-name *built-in-class-symbols*))
270        (let ((symbol (intern (format nil        (let ((symbol (symbolicate *the-pcl-package*
271                                      "*THE-CLASS-~A*"                                   '*the-class- class-name '*)))
                                     (symbol-name class-name))  
                             *the-pcl-package*)))  
272          (push (list class-name symbol) *built-in-class-symbols*)          (push (list class-name symbol) *built-in-class-symbols*)
273          symbol)))          symbol)))
274    
275  (defun get-built-in-wrapper-symbol (class-name)  (defun get-built-in-wrapper-symbol (class-name)
276    (or (cadr (assq class-name *built-in-wrapper-symbols*))    (or (cadr (assq class-name *built-in-wrapper-symbols*))
277        (let ((symbol (intern (format nil        (let ((symbol (symbolicate *the-pcl-package*
278                                      "*THE-WRAPPER-OF-~A*"                                   '*the-wrapper-of- class-name '*)))
                                     (symbol-name class-name))  
                             *the-pcl-package*)))  
279          (push (list class-name symbol) *built-in-wrapper-symbols*)          (push (list class-name symbol) *built-in-wrapper-symbols*)
280          symbol)))          symbol)))
281    
# Line 288  Line 292 
292    
293    
294  (defun make-class-predicate-name (name)  (defun make-class-predicate-name (name)
295    (intern (format nil "~A::~A class predicate"    `(class-predicate ,name))
                   (let ((pkg (symbol-package name)))  
                     (if pkg (package-name pkg) ""))  
                   name)  
           *the-pcl-package*))  
296    
297  (defun plist-value (object name)  (defun plist-value (object name)
298    (getf (object-plist object) name))    (getf (object-plist object) name))
# Line 347  Line 347 
347       nil)))       nil)))
348    
349  (labels ((direct-supers (class)  (labels ((direct-supers (class)
350             (if (typep class 'lisp:built-in-class)             (if (typep class 'kernel::built-in-class)
351                 (kernel:built-in-class-direct-superclasses class)                 (kernel:built-in-class-direct-superclasses class)
352                 (let ((inherits (kernel:layout-inherits                 (let ((inherits (kernel:layout-inherits
353                                  (kernel:class-layout class))))                                  (kernel:%class-layout class))))
354                   (list (svref inherits (1- (length inherits)))))))                   (list (svref inherits (1- (length inherits)))))))
355           (direct-subs (class)           (direct-subs (class)
356             (ext:collect ((res))             (ext:collect ((res))
357               (let ((subs (kernel:class-subclasses class)))               (let ((subs (kernel:%class-subclasses class)))
358                 (when subs                 (when subs
359                   (ext:do-hash (sub v subs)                   (ext:do-hash (sub v subs)
360                     (declare (ignore v))                     (declare (ignore v))
# Line 364  Line 364 
364    (ext:collect ((res))    (ext:collect ((res))
365      (dolist (bic kernel::built-in-classes)      (dolist (bic kernel::built-in-classes)
366        (let* ((name (car bic))        (let* ((name (car bic))
367               (class (lisp:find-class name)))               (class (kernel::find-class name)))
368          (unless (member name '(t kernel:instance kernel:funcallable-instance          (unless (member name '(t kernel:instance kernel:funcallable-instance
369                                   function stream))                                   function stream))
370            (res `(,name            (res `(,name
371                   ,(mapcar #'lisp:class-name (direct-supers class))                   ,(mapcar #'kernel:%class-name (direct-supers class))
372                   ,(mapcar #'lisp:class-name (direct-subs class))                   ,(mapcar #'kernel:%class-name (direct-subs class))
373                   ,(map 'list (lambda (x)                   ,(map 'list (lambda (x)
374                                 (lisp:class-name (kernel:layout-class x)))                                 (kernel:%class-name (kernel:layout-class x)))
375                         (reverse                         (reverse
376                          (kernel:layout-inherits                          (kernel:layout-inherits
377                           (kernel:class-layout class))))                           (kernel:%class-layout class))))
378                   ,(let ((found (assoc name *built-in-classes*)))                   ,(let ((found (assoc name *built-in-classes*)))
379                      (if found (fifth found) 42)))))))                      (if found (fifth found) 42)))))))
380      (setq *built-in-classes* (res))))      (setq *built-in-classes* (res))))
# Line 401  Line 401 
401  (defclass slot-object (t) ()  (defclass slot-object (t) ()
402    (:metaclass slot-class))    (:metaclass slot-class))
403    
404    ;;;
405    ;;; In a host Lisp with intact PCL, the DEFCLASS below would normally
406    ;;; generate a DEFSTRUCT with :INCLUDE SLOT-OBJECT.  SLOT-OBJECT is
407    ;;; not a structure, so this would give an error.  Likewise,
408    ;;; KERNEL:INSTANCE is a BUILT-IN-CLASS, not a structure class, so
409    ;;; this would give an error, too.
410    ;;;
411    ;;; When PCL is bootstrapped normally, *BOOT-STATE* is not COMPLETE at
412    ;;; this point, which means that a DEFSTRUCT is not done, because
413    ;;; EXPAND-DEFCLASS looks at the boot state.
414    ;;;
415    ;;; I've modified EXPAND-DEFCLASS accordingly to not do a DEFSTRUCT
416    ;;; when a loadable or bootable PCL is built.
417    ;;;
418  (defclass structure-object (slot-object kernel:instance) ()  (defclass structure-object (slot-object kernel:instance) ()
419    (:metaclass structure-class))    (:metaclass structure-class))
420    
# Line 413  Line 427 
427    
428  (defclass standard-object (std-object kernel:instance) ())  (defclass standard-object (std-object kernel:instance) ())
429    
430  (defclass funcallable-standard-object (std-object kernel:funcallable-instance)  (defclass funcallable-standard-object (std-object
431       ()                                         kernel:funcallable-instance)
432      ()
433    (:metaclass funcallable-standard-class))    (:metaclass funcallable-standard-class))
434    
435  (defclass specializer (standard-object)  (defclass specializer (standard-object)
436       ((type    ((type
437          :initform nil      :initform nil
438          :reader specializer-type)))      :reader specializer-type)))
439    
440  (defclass definition-source-mixin (std-object)  (defclass definition-source-mixin (std-object)
441       ((source    ((source
442          :initform *load-pathname*      :initform *load-pathname*
443          :reader definition-source      :reader definition-source
444          :initarg :definition-source))      :initarg :definition-source))
445    (:metaclass std-class))    (:metaclass std-class))
446    
447  (defclass plist-mixin (std-object)  (defclass plist-mixin (std-object)
448       ((plist    ((plist
449          :initform ()      :initform ()
450          :accessor object-plist))      :accessor object-plist))
451    (:metaclass std-class))    (:metaclass std-class))
452    
453  (defclass documentation-mixin (plist-mixin)  (defclass documentation-mixin (plist-mixin)
454       ()    ()
455    (:metaclass std-class))    (:metaclass std-class))
456    
457  (defclass dependent-update-mixin (plist-mixin)  (defclass dependent-update-mixin (plist-mixin)
458      ()    ()
459    (:metaclass std-class))    (:metaclass std-class))
460    
461  ;;;  ;;;
# Line 448  Line 463 
463  ;;; 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
464  ;;; have the class CLASS in its class precedence list.  ;;; have the class CLASS in its class precedence list.
465  ;;;  ;;;
466  (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin  (defclass class (documentation-mixin dependent-update-mixin
467                   specializer)                                       definition-source-mixin
468       ((name                                       specializer)
469          :initform nil    ((name
470          :initarg  :name      :initform nil
471          :accessor class-name)      :initarg  :name
472        (class-eq-specializer      :accessor class-name)
473          :initform nil     (class-eq-specializer
474          :reader class-eq-specializer)      :initform nil
475        (direct-superclasses      :reader class-eq-specializer)
476          :initform ()     (direct-superclasses
477          :reader class-direct-superclasses)      :initform ()
478        (direct-subclasses      :reader class-direct-superclasses)
479          :initform ()     (direct-subclasses
480          :reader class-direct-subclasses)      :initform ()
481        (direct-methods      :reader class-direct-subclasses)
482          :initform (cons nil nil))     (direct-methods
483        (predicate-name      :initform (cons nil nil))
484          :initform nil     (predicate-name
485          :reader class-predicate-name)))      :initform nil
486        :reader class-predicate-name)))
487    
488  ;;;  ;;;
489  ;;; The class PCL-CLASS is an implementation-specific common superclass of  ;;; The class PCL-CLASS is an implementation-specific common superclass of
490  ;;; all specified subclasses of the class CLASS.  ;;; all specified subclasses of the class CLASS.
491  ;;;  ;;;
492  (defclass pcl-class (class)  (defclass pcl-class (class)
493       ((class-precedence-list    ((class-precedence-list
494          :reader class-precedence-list)      :reader class-precedence-list)
495        (can-precede-list     (can-precede-list
496          :initform ()      :initform ()
497          :reader class-can-precede-list)      :reader class-can-precede-list)
498        (incompatible-superclass-list     (incompatible-superclass-list
499          :initform ()      :initform ()
500          :accessor class-incompatible-superclass-list)      :accessor class-incompatible-superclass-list)
501        (wrapper     (wrapper
502          :initform nil      :initform nil
503          :reader class-wrapper)      :reader class-wrapper)
504        (prototype     (prototype
505          :initform nil      :initform nil
506          :reader class-prototype)))      :reader class-prototype)))
507    
508  (defclass slot-class (pcl-class)  (defclass slot-class (pcl-class)
509       ((direct-slots    ((direct-slots
510          :initform ()      :initform ()
511          :accessor class-direct-slots)      :accessor class-direct-slots)
512        (slots     (slots
513          :initform ()      :initform ()
514          :accessor class-slots)      :accessor class-slots)
515        (initialize-info     (initialize-info
516          :initform nil      :initform nil
517          :accessor class-initialize-info)))      :accessor class-initialize-info)))
518    
519  ;;;  ;;;
520  ;;; The class STD-CLASS is an implementation-specific common superclass of  ;;; The class STD-CLASS is an implementation-specific common superclass of
521  ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.  ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
522  ;;;  ;;;
523  (defclass std-class (slot-class)  (defclass std-class (slot-class) ())
      ())  
524    
525  (defclass standard-class (std-class)  (defclass standard-class (std-class) ())
      ())  
526    
527  (defclass funcallable-standard-class (std-class)  (defclass funcallable-standard-class (std-class) ())
      ())  
528    
529  (defclass forward-referenced-class (pcl-class) ())  (defclass forward-referenced-class (pcl-class) ())
530    
531  (defclass built-in-class (pcl-class) ())  (defclass built-in-class (pcl-class) ())
532    
533  (defclass structure-class (slot-class)  (defclass structure-class (slot-class)
534       ((defstruct-form    ((defstruct-form
535          :initform ()       :initform ()
536          :accessor class-defstruct-form)       :accessor class-defstruct-form)
537        (defstruct-constructor     (defstruct-constructor
538          :initform nil       :initform nil
539          :accessor class-defstruct-constructor)       :accessor class-defstruct-constructor)
540        (from-defclass-p     (from-defclass-p
541          :initform nil      :initform nil
542          :initarg :from-defclass-p)))      :initarg :from-defclass-p)))
543    
544    (defclass condition-class (pcl-class) ())
545    
546  (defclass specializer-with-object (specializer) ())  (defclass specializer-with-object (specializer) ())
547    
548  (defclass exact-class-specializer (specializer) ())  (defclass exact-class-specializer (specializer) ())
549    
550  (defclass class-eq-specializer (exact-class-specializer specializer-with-object)  ;;;
551    ((object :initarg :class :reader specializer-class :reader specializer-object)))  ;;; Extension specializing on the exact specified class.  You must set
552    ;;; pcl::*allow-experimental-specializers-p* to use this extension.
553  (defclass class-prototype-specializer (specializer-with-object)  ;;;
554    ((object :initarg :class :reader specializer-class :reader specializer-object)))  ;;; (defclass foo () ())
555    ;;; (defclass bar (foo) ())
556    ;;;
557    ;;; (setq pcl::*allow-experimental-specializers-p* t)
558    ;;; (defmethod m (x) nil)
559    ;;; (defmethod m ((x (pcl::class-eq 'foo))) t)
560    ;;;
561    ;;; (m (make-instance 'foo)) => t
562    ;;; (m (make-instance 'bar)) => nil
563    ;;;
564    
565    (defclass class-eq-specializer (exact-class-specializer
566                                    specializer-with-object)
567      ((object
568        :initarg :class
569        :reader specializer-class
570        :reader specializer-object)))
571    
572  (defclass eql-specializer (exact-class-specializer specializer-with-object)  (defclass eql-specializer (exact-class-specializer specializer-with-object)
573    ((object :initarg :object :reader specializer-object    ((object
574             :reader eql-specializer-object)))      :initarg :object
575        :reader specializer-object
576        :reader eql-specializer-object)))
577    
578  (defvar *eql-specializer-table* (make-hash-table :test 'eql))  (defvar *eql-specializer-table* (make-hash-table :test 'eql))
579    
580    ;;;
581    ;;; When compiled with an intact PCL, the MAKE-INSTANCE in the function
582    ;;; below will generate an optimized constructor, and a LOAD-TIME-VALUE
583    ;;; creating it.  That means CTOR must be initialized before this file
584    ;;; is.
585    ;;;
586  (defun intern-eql-specializer (object)  (defun intern-eql-specializer (object)
587    (or (gethash object *eql-specializer-table*)    (or (gethash object *eql-specializer-table*)
588        (setf (gethash object *eql-specializer-table*)        (setf (gethash object *eql-specializer-table*)
# Line 555  Line 593 
593  ;;; Slot definitions.  ;;; Slot definitions.
594  ;;;  ;;;
595  (defclass slot-definition (standard-object)  (defclass slot-definition (standard-object)
596       ((name    ((name
597          :initform nil      :initform nil
598          :initarg :name      :initarg :name
599          :accessor slot-definition-name)      :accessor slot-definition-name)
600        (initform     (initform
601          :initform nil      :initform nil
602          :initarg :initform      :initarg :initform
603          :accessor slot-definition-initform)      :accessor slot-definition-initform)
604        (initfunction     (initfunction
605          :initform nil      :initform nil
606          :initarg :initfunction      :initarg :initfunction
607          :accessor slot-definition-initfunction)      :accessor slot-definition-initfunction)
608        (readers     (readers
609          :initform nil      :initform nil
610          :initarg :readers      :initarg :readers
611          :accessor slot-definition-readers)      :accessor slot-definition-readers)
612        (writers     (writers
613          :initform nil      :initform nil
614          :initarg :writers      :initarg :writers
615          :accessor slot-definition-writers)      :accessor slot-definition-writers)
616        (initargs     (initargs
617          :initform nil      :initform nil
618          :initarg :initargs      :initarg :initargs
619          :accessor slot-definition-initargs)      :accessor slot-definition-initargs)
620        (type     (type
621          :initform t      :initform t
622          :initarg :type      :initarg :type
623          :accessor slot-definition-type)      :accessor slot-definition-type)
624        (documentation     (documentation
625          :initform ""      :initform ""
626          :initarg :documentation)      :initarg :documentation)
627        (class     (class
628          :initform nil      :initform nil
629          :initarg :class      :initarg :class
630          :accessor slot-definition-class)))      :accessor slot-definition-class)))
631    
632  (defclass standard-slot-definition (slot-definition)  (defclass standard-slot-definition (slot-definition)
633    ((allocation    ((allocation
# Line 597  Line 635 
635      :initarg :allocation      :initarg :allocation
636      :accessor slot-definition-allocation)      :accessor slot-definition-allocation)
637     (allocation-class     (allocation-class
638        :documentation "For class slots, the class defininig the slot.
639    For inherited class slots, this is the superclass from which the slot
640    was inherited."
641      :initform nil      :initform nil
642      :initarg :allocation-class      :initarg :allocation-class
643      :accessor slot-definition-allocation-class)))      :accessor slot-definition-allocation-class)))
# Line 648  Line 689 
689    
690  (defclass method (standard-object) ())  (defclass method (standard-object) ())
691    
692  (defclass standard-method (definition-source-mixin documentation-mixin method)  (defclass standard-method (definition-source-mixin documentation-mixin
693       ((generic-function                                method)
694          :initform nil    ((generic-function
695          :accessor method-generic-function)      :initform nil
696  ;     (qualifiers      :accessor method-generic-function)
697  ;       :initform ()     (specializers
698  ;       :initarg  :qualifiers      :initform ()
699  ;       :reader method-qualifiers)      :initarg  :specializers
700        (specializers      :reader method-specializers)
701          :initform ()     (lambda-list
702          :initarg  :specializers      :initform ()
703          :reader method-specializers)      :initarg  :lambda-list
704        (lambda-list      :reader method-lambda-list)
705          :initform ()     (function
706          :initarg  :lambda-list      :initform nil
707          :reader method-lambda-list)      :initarg :function)
708        (function     (fast-function
709          :initform nil      :initform nil
710          :initarg :function)             ;no writer      :initarg :fast-function
711        (fast-function      :reader method-fast-function)))
         :initform nil  
         :initarg :fast-function         ;no writer  
         :reader method-fast-function)  
 ;     (documentation  
 ;       :initform nil  
 ;       :initarg  :documentation  
 ;       :reader method-documentation)  
       ))  
712    
713  (defclass standard-accessor-method (standard-method)  (defclass standard-accessor-method (standard-method)
714       ((slot-name :initform nil    ((slot-name
715                   :initarg :slot-name      :initform nil
716                   :reader accessor-method-slot-name)      :initarg :slot-name
717        (slot-definition :initform nil      :reader accessor-method-slot-name)
718                         :initarg :slot-definition     (slot-definition
719                         :reader accessor-method-slot-definition)))      :initform nil
720        :initarg :slot-definition
721        :reader accessor-method-slot-definition)))
722    
723  (defclass standard-reader-method (standard-accessor-method) ())  (defclass standard-reader-method (standard-accessor-method) ())
724    
# Line 695  Line 730 
730                              definition-source-mixin                              definition-source-mixin
731                              documentation-mixin                              documentation-mixin
732                              funcallable-standard-object)                              funcallable-standard-object)
733       ()    ()
734    (:metaclass funcallable-standard-class))    (:metaclass funcallable-standard-class))
735    
736  (defclass standard-generic-function (generic-function)  (defclass standard-generic-function (generic-function)
737       ((name    ((name
738          :initform nil      :initform nil
739          :initarg :name      :initarg :name
740          :accessor generic-function-name)      :accessor generic-function-name)
741        (methods     (methods
742          :initform ()      :initform ()
743          :accessor generic-function-methods)      :accessor generic-function-methods)
744        (method-class     (method-class
745          :initarg :method-class      :initarg :method-class
746          :accessor generic-function-method-class)      :accessor generic-function-method-class)
747        (method-combination     (method-combination
748          :initarg :method-combination      :initarg :method-combination
749          :accessor generic-function-method-combination)      :accessor generic-function-method-combination)
750        (declarations     (arg-info
751          :initarg :declarations      :initform (make-arg-info)
752          :initform ()      :reader gf-arg-info)
753          :accessor generic-function-declarations)     (dfun-state
754        (arg-info      :initform ()
755          :initform (make-arg-info)      :accessor gf-dfun-state)
756          :reader gf-arg-info)     (pretty-arglist
757        (dfun-state      :initform ()
758          :initform ()      :accessor gf-pretty-arglist)
759          :accessor gf-dfun-state)     (declarations
760        (pretty-arglist      :initform ()
761          :initform ()      :initarg :declarations
762          :accessor gf-pretty-arglist)      :reader generic-function-declarations))
       )  
763    (:metaclass funcallable-standard-class)    (:metaclass funcallable-standard-class)
764    (:default-initargs :method-class *the-class-standard-method*    (:default-initargs :method-class *the-class-standard-method*
765                       :method-combination *standard-method-combination*))      :method-combination *standard-method-combination*))
766    
767  (defclass method-combination (standard-object) ())  (defclass method-combination (standard-object) ())
768    
769  (defclass standard-method-combination  (defclass standard-method-combination
770            (definition-source-mixin method-combination)      (definition-source-mixin method-combination)
771       ((type          :reader method-combination-type    ((type
772                       :initarg :type)      :reader method-combination-type
773        (documentation :reader method-combination-documentation      :initarg :type)
774                       :initarg :documentation)     (documentation
775        (options       :reader method-combination-options      :reader method-combination-documentation
776                       :initarg :options)))      :initarg :documentation)
777       (options
778        :reader method-combination-options
779        :initarg :options)))
780    
781  (defclass long-method-combination (standard-method-combination)  (defclass long-method-combination (standard-method-combination)
782    ((function    ((function
783      :initarg :function      :initarg :function
784      :reader long-method-combination-function)      :reader long-method-combination-function)
785     (arguments-lambda-list     (args-lambda-list
786      :initarg :arguments-lambda-list      :initarg :args-lambda-list
787      :reader long-method-combination-arguments-lambda-list)))      :reader long-method-combination-args-lambda-list)))
788    
789    (defclass seal (standard-object)
790      ((quality
791        :initarg :quality
792        :reader seal-quality)))
793    
794  (defparameter *early-class-predicates*  (defparameter *early-class-predicates*
795    '((specializer specializerp)    '((specializer specializerp)
# Line 772  Line 814 
814      (method-combination method-combination-p)      (method-combination method-combination-p)
815      (long-method-combination long-method-combination-p)))      (long-method-combination long-method-combination-p)))
816    
817    

Legend:
Removed from v.1.33  
changed lines
  Added in v.1.34

  ViewVC Help
Powered by ViewVC 1.1.5