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 by pw, Tue Aug 8 14:42:30 2000 UTC
# Line 59  Line 59 
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))  
            ((and (listp ,spec)  
                  (eq (car ,spec) 'setf)  
                  (symbolp (cadr ,spec)))  
             (let ((,setf-var (cadr ,spec))) ,@setf-case))  
               "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))  
   #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol))  
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))  
   #+cmu (progn  
           (c::%%defun name new-definition nil)  
           (c::note-name-defined name :function)  
   #-(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))))  
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*
89                      *the-class-slot-object*                      *the-class-slot-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))))))
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)))
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.    (declare (ignorable name))
195  ;The satisfies predicate has to be a symbol.  There is no way to    #+nil ;; This is causing problems with native compile of defcombin.lisp
196  ;construct such a symbol from a class object if class names change.    (when (and (eq *boot-state* 'complete)
197  (defun class-predicate (class)               (null (lisp:find-class name nil)))
198    (when (symbolp class) (setq class (find-class class)))      (setf (lisp:find-class name)
199    #'(lambda (object) (memq class (class-precedence-list (class-of object)))))            (lisp::make-standard-class :name name))))
201  (defun make-class-eq-predicate (class)  (defun make-class-eq-predicate (class)
202    (when (symbolp class) (setq class (find-class class)))    (when (symbolp class) (setq class (find-class class)))
# 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)))
 #|| ; 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))  
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))))
 ;;; Not used...  
 (defun unparse-type-list (tlist)  
   (mapcar #'unparse-type tlist))  
 ;;; Not used...  
 (defun unparse-type (type)  
   (if (atom type)  
       (if (specializerp type)  
           (unparse-type (specializer-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))))
 ;;; not used...  
 (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))))  
          (typep object (convert-to-system-type type)))))  
246  ;;; *SUBTYPEP  --  Interface  ;;; *SUBTYPEP  --  Interface
247  ;;;  ;;;
# Line 411  Line 272 
272                (t                (t
273                 (subtypep (convert-to-system-type type1)                 (subtypep (convert-to-system-type type1)
274                           (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))  
     ;; 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)  
         (setf (get name 'excl::deftype-expander) expand-fn)  
         (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"  
                       (package-name (symbol-package name))  
                       (symbol-name name))  
       (make-symbol (format nil  
                            "~@[~A ~]TYPE-PREDICATE ~A"  
                            (symbol-name name)))))  
277  (defvar *built-in-class-symbols* ())  (defvar *built-in-class-symbols* ())
# Line 522  Line 344 
344  (defun plist-value (object name)  (defun plist-value (object name)
345    (getf (object-plist object) name))    (getf (object-plist object) name))
347  (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)  (defun (setf plist-value) (new-value object name)
348    (if new-value    (if new-value
349        (setf (getf (object-plist object) name) new-value)        (setf (getf (object-plist object) name) new-value)
350        (progn        (progn
# Line 571  Line 393 
393                   list)     ()                       (symbol list sequence t)                   list)     ()                       (symbol list sequence t)
394       nil)))       nil)))
396  (labels ((direct-supers (class)  (labels ((direct-supers (class)
397             (if (typep class 'lisp:built-in-class)             (if (typep class 'lisp:built-in-class)
398                 (kernel:built-in-class-direct-superclasses class)                 (kernel:built-in-class-direct-superclasses class)
# Line 592  Line 413 
413        (let* ((name (car bic))        (let* ((name (car bic))
414               (class (lisp:find-class name)))               (class (lisp:find-class name)))
415          (unless (member name '(t kernel:instance kernel:funcallable-instance          (unless (member name '(t kernel:instance kernel:funcallable-instance
416                                   function))                                   function stream))
417            (res `(,name            (res `(,name
418                   ,(mapcar #'lisp:class-name (direct-supers class))                   ,(mapcar #'lisp:class-name (direct-supers class))
419                   ,(mapcar #'lisp:class-name (direct-subs class))                   ,(mapcar #'lisp:class-name (direct-subs class))
# Line 612  Line 433 
433  (defclass t () ()  (defclass t () ()
434    (:metaclass built-in-class))    (:metaclass built-in-class))
436  #+cmu17  (defclass kernel:instance (t) ()
437  (progn    (:metaclass built-in-class))
438    (defclass kernel:instance (t) ()  
439      (:metaclass built-in-class))  (defclass function (t) ()
440      (:metaclass built-in-class))
   (defclass function (t) ()  
     (:metaclass built-in-class))  
442    (defclass kernel:funcallable-instance (function) ()  (defclass kernel:funcallable-instance (function) ()
443      (:metaclass built-in-class)))    (:metaclass built-in-class))
445  (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) ()  (defclass stream (kernel:instance) ()
446      (:metaclass built-in-class))
448    (defclass slot-object (t) ()
449    (:metaclass slot-class))    (:metaclass slot-class))
451  (defclass structure-object (slot-object) ()  (defclass structure-object (slot-object kernel:instance) ()
452    (:metaclass structure-class))    (:metaclass structure-class))
454  (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object  (defstruct (dead-beef-structure-object
455               (:constructor |STRUCTURE-OBJECT class constructor|)))               (:constructor |STRUCTURE-OBJECT class constructor|)))
458  (defclass standard-object (slot-object) ())  (defclass std-object (slot-object) ()
459      (:metaclass std-class))
461  (defclass metaobject (standard-object) ())  (defclass standard-object (std-object kernel:instance) ())
463  (defclass specializer (metaobject)  (defclass funcallable-standard-object (std-object
464                                           kernel:funcallable-instance)
465         ()
466      (:metaclass funcallable-standard-class))
468    (defclass specializer (standard-object)
469       ((type       ((type
470          :initform nil          :initform nil
471          :reader specializer-type)))          :reader specializer-type)))
473  (defclass definition-source-mixin (standard-object)  (defclass definition-source-mixin (std-object)
474       ((source       ((source
475          :initform (load-truename)          :initform (load-truename)
476          :reader definition-source          :reader definition-source
477          :initarg :definition-source)))          :initarg :definition-source))
478      (:metaclass std-class))
480  (defclass plist-mixin (standard-object)  (defclass plist-mixin (std-object)
481       ((plist       ((plist
482          :initform ()          :initform ()
483          :accessor object-plist)))          :accessor object-plist))
484      (:metaclass std-class))
486  (defclass documentation-mixin (plist-mixin)  (defclass documentation-mixin (plist-mixin)
487       ())       ()
488      (:metaclass std-class))
490  (defclass dependent-update-mixin (plist-mixin)  (defclass dependent-update-mixin (plist-mixin)
491      ())      ()
492      (:metaclass std-class))
494  ;;;  ;;;
495  ;;; 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 602 
602  ;;;  ;;;
603  ;;; Slot definitions.  ;;; Slot definitions.
604  ;;;  ;;;
605  (defclass slot-definition (metaobject)  (defclass slot-definition (standard-object)
606       ((name       ((name
607          :initform nil          :initform nil
608          :initarg :name          :initarg :name
# Line 858  Line 690 
690                                                 effective-slot-definition)                                                 effective-slot-definition)
691    ())    ())
693  (defclass method (metaobject) ())  (defclass method (standard-object) ())
695  (defclass standard-method (definition-source-mixin plist-mixin method)  (defclass standard-method (definition-source-mixin plist-mixin method)
696       ((generic-function       ((generic-function
# Line 906  Line 738 
738  (defclass generic-function (dependent-update-mixin  (defclass generic-function (dependent-update-mixin
739                              definition-source-mixin                              definition-source-mixin
740                              documentation-mixin                              documentation-mixin
741                              metaobject                              funcallable-standard-object)
                             #+cmu17 kernel:funcallable-instance)  
742       ()       ()
743    (:metaclass funcallable-standard-class))    (:metaclass funcallable-standard-class))
# Line 939  Line 770 
770    (:default-initargs :method-class *the-class-standard-method*    (:default-initargs :method-class *the-class-standard-method*
771                       :method-combination *standard-method-combination*))                       :method-combination *standard-method-combination*))
773  (defclass method-combination (metaobject) ())  (defclass method-combination (standard-object) ())
775  (defclass standard-method-combination  (defclass standard-method-combination
776            (definition-source-mixin method-combination)            (definition-source-mixin method-combination)
# Line 957  Line 788 
788      (eql-specializer eql-specializer-p)      (eql-specializer eql-specializer-p)
789      (class classp)      (class classp)
790      (slot-class slot-class-p)      (slot-class slot-class-p)
791        (std-class std-class-p)
792      (standard-class standard-class-p)      (standard-class standard-class-p)
793      (funcallable-standard-class funcallable-standard-class-p)      (funcallable-standard-class funcallable-standard-class-p)
794      (structure-class structure-class-p)      (structure-class structure-class-p)

Removed from v.1.11  
changed lines
  Added in v.

  ViewVC Help
Powered by ViewVC 1.1.5