/[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.2 by pw, Tue May 23 16:38:46 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 300  Line 205 
205  (defun make-eql-predicate (eql-object)  (defun make-eql-predicate (eql-object)
206    #'(lambda (object) (eql eql-object object)))    #'(lambda (object) (eql eql-object object)))
207    
 #|| ; 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))  
   
208    
209  ;;; Internal to this file.  ;;; Internal to this file.
210  ;;;  ;;;
# Line 339  Line 230 
230          (t          (t
231           (error "~s is not a type" type))))           (error "~s is not a type" type))))
232    
 ;;; 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)))))))  
   
233  ;;; internal to this file...  ;;; internal to this file...
234  (defun convert-to-system-type (type)  (defun convert-to-system-type (type)
235    (case (car type)    (case (car type)
236      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
237                                            (cdr type))))                                            (cdr type))))
238      ((class class-eq) ; class-eq is impossible to do right      ((class class-eq) ; class-eq is impossible to do right
239       #-cmu17 (class-name (cadr type))       (kernel:layout-class (class-wrapper (cadr type))))
      #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))  
240      (eql type)      (eql type)
241      (t (if (null (cdr type))      (t (if (null (cdr type))
242             (car type)             (car type)
243             type))))             type))))
244    
 ;;; 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)))))  
   
245    
246  ;;; *SUBTYPEP  --  Interface  ;;; *SUBTYPEP  --  Interface
247  ;;;  ;;;
# Line 413  Line 274 
274                           (convert-to-system-type type2))))))))                           (convert-to-system-type type2))))))))
275    
276  (defun do-satisfies-deftype (name predicate)  (defun do-satisfies-deftype (name predicate)
277    #+cmu17 (declare (ignore name predicate))    (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))))  
278    
279  (defun make-type-predicate-name (name &optional kind)  (defun make-type-predicate-name (name &optional kind)
280    (if (symbol-package name)    (if (symbol-package name)
# Line 522  Line 361 
361  (defun plist-value (object name)  (defun plist-value (object name)
362    (getf (object-plist object) name))    (getf (object-plist object) name))
363    
364  (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)  (defun (setf plist-value) (new-value object name)
365    (if new-value    (if new-value
366        (setf (getf (object-plist object) name) new-value)        (setf (getf (object-plist object) name) new-value)
367        (progn        (progn
# Line 571  Line 410 
410                   list)     ()                       (symbol list sequence t)                   list)     ()                       (symbol list sequence t)
411       nil)))       nil)))
412    
 #+cmu17  
413  (labels ((direct-supers (class)  (labels ((direct-supers (class)
414             (if (typep class 'lisp:built-in-class)             (if (typep class 'lisp:built-in-class)
415                 (kernel:built-in-class-direct-superclasses class)                 (kernel:built-in-class-direct-superclasses class)
# Line 592  Line 430 
430        (let* ((name (car bic))        (let* ((name (car bic))
431               (class (lisp:find-class name)))               (class (lisp:find-class name)))
432          (unless (member name '(t kernel:instance kernel:funcallable-instance          (unless (member name '(t kernel:instance kernel:funcallable-instance
433                                   function))                                   function stream))
434            (res `(,name            (res `(,name
435                   ,(mapcar #'lisp:class-name (direct-supers class))                   ,(mapcar #'lisp:class-name (direct-supers class))
436                   ,(mapcar #'lisp:class-name (direct-subs class))                   ,(mapcar #'lisp:class-name (direct-subs class))
# Line 612  Line 450 
450  (defclass t () ()  (defclass t () ()
451    (:metaclass built-in-class))    (:metaclass built-in-class))
452    
453  #+cmu17  (defclass kernel:instance (t) ()
454  (progn    (:metaclass built-in-class))
455    (defclass kernel:instance (t) ()  
456      (:metaclass built-in-class))  (defclass function (t) ()
457      (:metaclass built-in-class))
   (defclass function (t) ()  
     (:metaclass built-in-class))  
458    
459    (defclass kernel:funcallable-instance (function) ()  (defclass kernel:funcallable-instance (function) ()
460      (:metaclass built-in-class)))    (:metaclass built-in-class))
461    
462    (defclass stream (t) ()
463      (:metaclass built-in-class))
464    
465  (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) ()  (defclass slot-object (t) ()
466    (:metaclass slot-class))    (:metaclass slot-class))
467    
468  (defclass structure-object (slot-object) ()  (defclass structure-object (slot-object kernel:instance) ()
469    (:metaclass structure-class))    (:metaclass structure-class))
470    
471  (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object  (defstruct (dead-beef-structure-object
472               (:constructor |STRUCTURE-OBJECT class constructor|)))               (:constructor |STRUCTURE-OBJECT class constructor|)))
473    
474    
475  (defclass standard-object (slot-object) ())  (defclass std-object (slot-object) ()
476      (:metaclass std-class))
477    
478  (defclass metaobject (standard-object) ())  (defclass standard-object (std-object kernel:instance) ())
479    
480  (defclass specializer (metaobject)  (defclass funcallable-standard-object (std-object
481                                           kernel:funcallable-instance)
482         ()
483      (:metaclass funcallable-standard-class))
484    
485    (defclass specializer (standard-object)
486       ((type       ((type
487          :initform nil          :initform nil
488          :reader specializer-type)))          :reader specializer-type)))
489    
490  (defclass definition-source-mixin (standard-object)  (defclass definition-source-mixin (std-object)
491       ((source       ((source
492          :initform (load-truename)          :initform (load-truename)
493          :reader definition-source          :reader definition-source
494          :initarg :definition-source)))          :initarg :definition-source))
495      (:metaclass std-class))
496    
497  (defclass plist-mixin (standard-object)  (defclass plist-mixin (std-object)
498       ((plist       ((plist
499          :initform ()          :initform ()
500          :accessor object-plist)))          :accessor object-plist))
501      (:metaclass std-class))
502    
503  (defclass documentation-mixin (plist-mixin)  (defclass documentation-mixin (plist-mixin)
504       ())       ()
505      (:metaclass std-class))
506    
507  (defclass dependent-update-mixin (plist-mixin)  (defclass dependent-update-mixin (plist-mixin)
508      ())      ()
509      (:metaclass std-class))
510    
511  ;;;  ;;;
512  ;;; 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 619 
619  ;;;  ;;;
620  ;;; Slot definitions.  ;;; Slot definitions.
621  ;;;  ;;;
622  (defclass slot-definition (metaobject)  (defclass slot-definition (standard-object)
623       ((name       ((name
624          :initform nil          :initform nil
625          :initarg :name          :initarg :name
# Line 858  Line 707 
707                                                 effective-slot-definition)                                                 effective-slot-definition)
708    ())    ())
709    
710  (defclass method (metaobject) ())  (defclass method (standard-object) ())
711    
712  (defclass standard-method (definition-source-mixin plist-mixin method)  (defclass standard-method (definition-source-mixin plist-mixin method)
713       ((generic-function       ((generic-function
# Line 906  Line 755 
755  (defclass generic-function (dependent-update-mixin  (defclass generic-function (dependent-update-mixin
756                              definition-source-mixin                              definition-source-mixin
757                              documentation-mixin                              documentation-mixin
758                              metaobject                              funcallable-standard-object)
                             #+cmu17 kernel:funcallable-instance)  
759       ()       ()
760    (:metaclass funcallable-standard-class))    (:metaclass funcallable-standard-class))
761    
# Line 939  Line 787 
787    (:default-initargs :method-class *the-class-standard-method*    (:default-initargs :method-class *the-class-standard-method*
788                       :method-combination *standard-method-combination*))                       :method-combination *standard-method-combination*))
789    
790  (defclass method-combination (metaobject) ())  (defclass method-combination (standard-object) ())
791    
792  (defclass standard-method-combination  (defclass standard-method-combination
793            (definition-source-mixin method-combination)            (definition-source-mixin method-combination)
# Line 957  Line 805 
805      (eql-specializer eql-specializer-p)      (eql-specializer eql-specializer-p)
806      (class classp)      (class classp)
807      (slot-class slot-class-p)      (slot-class slot-class-p)
808        (std-class std-class-p)
809      (standard-class standard-class-p)      (standard-class standard-class-p)
810      (funcallable-standard-class funcallable-standard-class-p)      (funcallable-standard-class funcallable-standard-class-p)
811      (structure-class structure-class-p)      (structure-class structure-class-p)

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

  ViewVC Help
Powered by ViewVC 1.1.5