/[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.2.2 by pw, Tue May 23 16:38:46 2000 UTC revision 1.11.2.3 by pw, Fri Aug 4 10:34:58 2000 UTC
# Line 70  Line 70 
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 (setf gdefinition) (new-definition name)  (defun (setf gdefinition) (new-definition name)
75    (c::%%defun name new-definition nil)    (c::%%defun name new-definition nil)
76    (c::note-name-defined name :function)    (c::note-name-defined name :function)
# Line 181  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 272  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)  
   (declare (ignore name 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* ())

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

  ViewVC Help
Powered by ViewVC 1.1.5