/[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.11 by pw, Thu Feb 6 21:24:04 1997 UTC revision 1.11.2.4 by dtc, Sun Aug 6 19:09:49 2000 UTC
# Line 59  Line 59 
59    
60    
61  ;;;  ;;;
 ;;; This is like fdefinition on the Lispm.  If Common Lisp had something like  
 ;;; function specs I wouldn't need this.  On the other hand, I don't like the  
 ;;; way this really works so maybe function specs aren't really right either?  
 ;;;  
 ;;; I also don't understand the real implications of a Lisp-1 on this sort of  
 ;;; thing.  Certainly some of the lossage in all of this is because these  
 ;;; SPECs name global definitions.  
 ;;;  
 ;;; Note that this implementation is set up so that an implementation which  
 ;;; has a 'real' function spec mechanism can use that instead and in that way  
 ;;; get rid of setf generic function names.  
 ;;;  
 (defmacro parse-gspec (spec  
                        (non-setf-var . non-setf-case)  
                        (setf-var . setf-case))  
   (declare (indentation 1 1))  
   #+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)))))  
   
 ;;;  
62  ;;; If symbol names a function which is traced or advised, return the  ;;; If symbol names a function which is traced or advised, return the
63  ;;; unadvised, traced etc. definition.  This lets me get at the generic  ;;; unadvised, traced etc. definition.  This lets me get at the generic
64  ;;; function object even when it is traced.  ;;; function object even when it is traced.
65  ;;;  ;;;
66  (defun unencapsulated-fdefinition (symbol)  (declaim (inline gdefinition))
67    #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))  (defun gdefinition (symbol)
68    #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))    (fdefinition symbol))
   #+excl  (or (excl::encapsulated-basic-definition symbol)  
               (symbol-function symbol))  
   #+xerox (il:virginfn symbol)  
   #+setf (fdefinition symbol)  
   #+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))  
69    
70  ;;;  ;;;
71  ;;; If symbol names a function which is traced or advised, redefine  ;;; If symbol names a function which is traced or advised, redefine
72  ;;; the `real' definition without affecting the advise.  ;;; the `real' definition without affecting the advise.
73  ;;;  ;;
74  (defun fdefine-carefully (name new-definition)  (defun (setf gdefinition) (new-definition name)
75    #+Lispm (si:fdefine name new-definition t t)    (c::%%defun name new-definition nil)
76    #+Lucid (let ((lucid::*redefinition-action* nil))    (c::note-name-defined name :function)
77              (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))))  
   
78    
79  (proclaim '(special *the-class-t*  (proclaim '(special *the-class-t*
80                      *the-class-vector* *the-class-symbol*                      *the-class-vector* *the-class-symbol*
# Line 182  Line 84 
84                      *the-class-integer* *the-class-float* *the-class-cons*                      *the-class-integer* *the-class-float* *the-class-cons*
85                      *the-class-complex* *the-class-character*                      *the-class-complex* *the-class-character*
86                      *the-class-bit-vector* *the-class-array*                      *the-class-bit-vector* *the-class-array*
87                        *the-class-stream*
88    
89                      *the-class-slot-object*                      *the-class-slot-object*
                     *the-class-standard-object*  
90                      *the-class-structure-object*                      *the-class-structure-object*
91                        *the-class-std-object*
92                        *the-class-standard-object*
93                        *the-class-funcallable-standard-object*
94                      *the-class-class*                      *the-class-class*
95                      *the-class-generic-function*                      *the-class-generic-function*
96                      *the-class-built-in-class*                      *the-class-built-in-class*
97                      *the-class-slot-class*                      *the-class-slot-class*
98                      *the-class-structure-class*                      *the-class-structure-class*
99                        *the-class-std-class*
100                      *the-class-standard-class*                      *the-class-standard-class*
101                      *the-class-funcallable-standard-class*                      *the-class-funcallable-standard-class*
102                      *the-class-method*                      *the-class-method*
# Line 235  Line 141 
141                                           :object (coerce-to-class (car args))))                                           :object (coerce-to-class (car args))))
142                 (class-eq (class-eq-specializer (coerce-to-class (car args))))                 (class-eq (class-eq-specializer (coerce-to-class (car args))))
143                 (eql      (intern-eql-specializer (car args))))))                 (eql      (intern-eql-specializer (car args))))))
         #+cmu17  
144          ((and (null args) (typep type 'lisp:class))          ((and (null args) (typep type 'lisp:class))
145           (or (kernel:class-pcl-class type)           (or (kernel:class-pcl-class type)
146               (find-structure-class (lisp:class-name type))))               (find-structure-class (lisp:class-name type))))
# Line 276  Line 181 
181    (specializer-type (class-eq-specializer class)))    (specializer-type (class-eq-specializer class)))
182    
183  (defun inform-type-system-about-std-class (name)  (defun inform-type-system-about-std-class (name)
184    (let ((predicate-name (make-type-predicate-name name)))    ;; This should only be called if metaclass is standard-class.
185      (setf (gdefinition predicate-name) (make-type-predicate name))    ;; Compiler problems have been seen if the metaclass is
186      (do-satisfies-deftype name predicate-name)))    ;; funcallable-standard-class and this is called from the defclass macro
187      ;; expander. However, bootstrap-meta-braid calls this for funcallable-
188  (defun make-type-predicate (name)    ;; standard-class metaclasses but *boot-state* is not 'complete then.
189    (let ((cell (find-class-cell name)))    ;;
190      #'(lambda (x)    ;; The only effect of this code is to ensure a lisp:standard-class class
191          (funcall (the function (find-class-cell-predicate cell)) x))))    ;; exists so as to avoid undefined-function compiler warnings. The
192      ;; skeleton class will be replaced at load-time with the correct object.
193      ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
194  ;This stuff isn't right.  Good thing it isn't used.  
195  ;The satisfies predicate has to be a symbol.  There is no way to    (when (and (eq *boot-state* 'complete)
196  ;construct such a symbol from a class object if class names change.               (null (lisp:find-class name nil)))
197  (defun class-predicate (class)      (setf (lisp:find-class name)
198    (when (symbolp class) (setq class (find-class class)))            (lisp::make-standard-class :name name))))
   #'(lambda (object) (memq class (class-precedence-list (class-of object)))))  
199    
200  (defun make-class-eq-predicate (class)  (defun make-class-eq-predicate (class)
201    (when (symbolp class) (setq class (find-class class)))    (when (symbolp class) (setq class (find-class class)))
# Line 300  Line 204 
204  (defun make-eql-predicate (eql-object)  (defun make-eql-predicate (eql-object)
205    #'(lambda (object) (eql eql-object object)))    #'(lambda (object) (eql eql-object object)))
206    
 #|| ; 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))  
   
207    
208  ;;; Internal to this file.  ;;; Internal to this file.
209  ;;;  ;;;
# Line 339  Line 229 
229          (t          (t
230           (error "~s is not a type" type))))           (error "~s is not a type" type))))
231    
 ;;; 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)))))))  
   
232  ;;; internal to this file...  ;;; internal to this file...
233  (defun convert-to-system-type (type)  (defun convert-to-system-type (type)
234    (case (car type)    (case (car type)
235      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
236                                            (cdr type))))                                            (cdr type))))
237      ((class class-eq) ; class-eq is impossible to do right      ((class class-eq) ; class-eq is impossible to do right
238       #-cmu17 (class-name (cadr type))       (kernel:layout-class (class-wrapper (cadr type))))
      #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))  
239      (eql type)      (eql type)
240      (t (if (null (cdr type))      (t (if (null (cdr type))
241             (car type)             (car type)
242             type))))             type))))
243    
 ;;; 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)))))  
   
244    
245  ;;; *SUBTYPEP  --  Interface  ;;; *SUBTYPEP  --  Interface
246  ;;;  ;;;
# Line 411  Line 271 
271                (t                (t
272                 (subtypep (convert-to-system-type type1)                 (subtypep (convert-to-system-type type1)
273                           (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)))))  
   
274    
275    
276  (defvar *built-in-class-symbols* ())  (defvar *built-in-class-symbols* ())
# Line 522  Line 343 
343  (defun plist-value (object name)  (defun plist-value (object name)
344    (getf (object-plist object) name))    (getf (object-plist object) name))
345    
346  (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)  (defun (setf plist-value) (new-value object name)
347    (if new-value    (if new-value
348        (setf (getf (object-plist object) name) new-value)        (setf (getf (object-plist object) name) new-value)
349        (progn        (progn
# Line 571  Line 392 
392                   list)     ()                       (symbol list sequence t)                   list)     ()                       (symbol list sequence t)
393       nil)))       nil)))
394    
 #+cmu17  
395  (labels ((direct-supers (class)  (labels ((direct-supers (class)
396             (if (typep class 'lisp:built-in-class)             (if (typep class 'lisp:built-in-class)
397                 (kernel:built-in-class-direct-superclasses class)                 (kernel:built-in-class-direct-superclasses class)
# Line 592  Line 412 
412        (let* ((name (car bic))        (let* ((name (car bic))
413               (class (lisp:find-class name)))               (class (lisp:find-class name)))
414          (unless (member name '(t kernel:instance kernel:funcallable-instance          (unless (member name '(t kernel:instance kernel:funcallable-instance
415                                   function))                                   function stream))
416            (res `(,name            (res `(,name
417                   ,(mapcar #'lisp:class-name (direct-supers class))                   ,(mapcar #'lisp:class-name (direct-supers class))
418                   ,(mapcar #'lisp:class-name (direct-subs class))                   ,(mapcar #'lisp:class-name (direct-subs class))
# Line 612  Line 432 
432  (defclass t () ()  (defclass t () ()
433    (:metaclass built-in-class))    (:metaclass built-in-class))
434    
435  #+cmu17  (defclass kernel:instance (t) ()
436  (progn    (:metaclass built-in-class))
437    (defclass kernel:instance (t) ()  
438      (:metaclass built-in-class))  (defclass function (t) ()
439      (:metaclass built-in-class))
   (defclass function (t) ()  
     (:metaclass built-in-class))  
440    
441    (defclass kernel:funcallable-instance (function) ()  (defclass kernel:funcallable-instance (function) ()
442      (:metaclass built-in-class)))    (:metaclass built-in-class))
443    
444  (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) ()  (defclass stream (kernel:instance) ()
445      (:metaclass built-in-class))
446    
447    (defclass slot-object (t) ()
448    (:metaclass slot-class))    (:metaclass slot-class))
449    
450  (defclass structure-object (slot-object) ()  (defclass structure-object (slot-object kernel:instance) ()
451    (:metaclass structure-class))    (:metaclass structure-class))
452    
453  (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object  (defstruct (dead-beef-structure-object
454               (:constructor |STRUCTURE-OBJECT class constructor|)))               (:constructor |STRUCTURE-OBJECT class constructor|)))
455    
456    
457  (defclass standard-object (slot-object) ())  (defclass std-object (slot-object) ()
458      (:metaclass std-class))
459    
460  (defclass metaobject (standard-object) ())  (defclass standard-object (std-object kernel:instance) ())
461    
462  (defclass specializer (metaobject)  (defclass funcallable-standard-object (std-object
463                                           kernel:funcallable-instance)
464         ()
465      (:metaclass funcallable-standard-class))
466    
467    (defclass specializer (standard-object)
468       ((type       ((type
469          :initform nil          :initform nil
470          :reader specializer-type)))          :reader specializer-type)))
471    
472  (defclass definition-source-mixin (standard-object)  (defclass definition-source-mixin (std-object)
473       ((source       ((source
474          :initform (load-truename)          :initform (load-truename)
475          :reader definition-source          :reader definition-source
476          :initarg :definition-source)))          :initarg :definition-source))
477      (:metaclass std-class))
478    
479  (defclass plist-mixin (standard-object)  (defclass plist-mixin (std-object)
480       ((plist       ((plist
481          :initform ()          :initform ()
482          :accessor object-plist)))          :accessor object-plist))
483      (:metaclass std-class))
484    
485  (defclass documentation-mixin (plist-mixin)  (defclass documentation-mixin (plist-mixin)
486       ())       ()
487      (:metaclass std-class))
488    
489  (defclass dependent-update-mixin (plist-mixin)  (defclass dependent-update-mixin (plist-mixin)
490      ())      ()
491      (:metaclass std-class))
492    
493  ;;;  ;;;
494  ;;; 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
# Line 770  Line 601 
601  ;;;  ;;;
602  ;;; Slot definitions.  ;;; Slot definitions.
603  ;;;  ;;;
604  (defclass slot-definition (metaobject)  (defclass slot-definition (standard-object)
605       ((name       ((name
606          :initform nil          :initform nil
607          :initarg :name          :initarg :name
# Line 858  Line 689 
689                                                 effective-slot-definition)                                                 effective-slot-definition)
690    ())    ())
691    
692  (defclass method (metaobject) ())  (defclass method (standard-object) ())
693    
694  (defclass standard-method (definition-source-mixin plist-mixin method)  (defclass standard-method (definition-source-mixin plist-mixin method)
695       ((generic-function       ((generic-function
# Line 906  Line 737 
737  (defclass generic-function (dependent-update-mixin  (defclass generic-function (dependent-update-mixin
738                              definition-source-mixin                              definition-source-mixin
739                              documentation-mixin                              documentation-mixin
740                              metaobject                              funcallable-standard-object)
                             #+cmu17 kernel:funcallable-instance)  
741       ()       ()
742    (:metaclass funcallable-standard-class))    (:metaclass funcallable-standard-class))
743    
# Line 939  Line 769 
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 (standard-object) ())
773    
774  (defclass standard-method-combination  (defclass standard-method-combination
775            (definition-source-mixin method-combination)            (definition-source-mixin method-combination)
# Line 957  Line 787 
787      (eql-specializer eql-specializer-p)      (eql-specializer eql-specializer-p)
788      (class classp)      (class classp)
789      (slot-class slot-class-p)      (slot-class slot-class-p)
790        (std-class std-class-p)
791      (standard-class standard-class-p)      (standard-class standard-class-p)
792      (funcallable-standard-class funcallable-standard-class-p)      (funcallable-standard-class funcallable-standard-class-p)
793      (structure-class structure-class-p)      (structure-class structure-class-p)

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.11.2.4

  ViewVC Help
Powered by ViewVC 1.1.5