/[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.16 by dtc, Sun Mar 14 01:14:13 1999 UTC revision 1.17 by pw, Sun May 30 23:13:55 1999 UTC
# Line 72  Line 72 
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    #+cmu (progn    (c::%%defun name new-definition nil)
76            (c::%%defun name new-definition nil)    (c::note-name-defined name :function)
77            (c::note-name-defined name :function)    new-definition)
           new-definition)  
   #-(or cmu)  
   (setf (symbol-function name) new-definition))  
   
   
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 146  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 242  Line 236 
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)
# Line 281  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 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 423  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 464  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))
   (defclass kernel:instance (t) ()  
     (:metaclass built-in-class))  
   
   (defclass function (t) ()  
     (:metaclass built-in-class))  
455    
456    (defclass kernel:funcallable-instance (function) ()  (defclass function (t) ()
457      (:metaclass built-in-class))    (:metaclass built-in-class))
458    
459    (defclass stream (t) ()  (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 (t) ()  (defclass slot-object (t) ()
466    (:metaclass slot-class))    (:metaclass slot-class))
467    
468  (defclass structure-object (slot-object #+cmu17 kernel:instance) ()  (defclass structure-object (slot-object kernel:instance) ()
469    (:metaclass structure-class))    (:metaclass structure-class))
470    
471  (defstruct (dead-beef-structure-object  (defstruct (dead-beef-structure-object
# Line 491  Line 475 
475  (defclass std-object (slot-object) ()  (defclass std-object (slot-object) ()
476    (:metaclass std-class))    (:metaclass std-class))
477    
478  (defclass standard-object (std-object #+cmu17 kernel:instance) ())  (defclass standard-object (std-object kernel:instance) ())
479    
480  (defclass funcallable-standard-object (std-object  (defclass funcallable-standard-object (std-object
481                                         #+cmu17 kernel:funcallable-instance)                                         kernel:funcallable-instance)
482       ()       ()
483    (:metaclass funcallable-standard-class))    (:metaclass funcallable-standard-class))
484    

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

  ViewVC Help
Powered by ViewVC 1.1.5