/[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.10 by phg, Mon Feb 8 17:32:44 1993 UTC revision 1.11 by pw, Thu Feb 6 21:24:04 1997 UTC
# Line 34  Line 34 
34  (defvar *defmethod-times*  '(load eval))  (defvar *defmethod-times*  '(load eval))
35  (defvar *defgeneric-times* '(load eval))  (defvar *defgeneric-times* '(load eval))
36    
37  (defvar *boot-state* ())                        ;NIL  ; defvar is now actually in macros
38    ;(defvar *boot-state* ())                       ;NIL
39                                                  ;EARLY                                                  ;EARLY
40                                                  ;BRAID                                                  ;BRAID
41                                                  ;COMPLETE                                                  ;COMPLETE
# Line 74  Line 75 
75                         (non-setf-var . non-setf-case)                         (non-setf-var . non-setf-case)
76                         (setf-var . setf-case))                         (setf-var . setf-case))
77    (declare (indentation 1 1))    (declare (indentation 1 1))
78      #+setf (declare (ignore setf-var setf-case))
79    (once-only (spec)    (once-only (spec)
80      `(cond (#-setf (symbolp ,spec) #+setf t      `(cond (#-setf (symbolp ,spec) #+setf t
81              (let ((,non-setf-var ,spec)) ,@non-setf-case))              (let ((,non-setf-var ,spec)) ,@non-setf-case))
# Line 212  Line 214 
214                      *the-wrapper-of-complex* *the-wrapper-of-character*                      *the-wrapper-of-complex* *the-wrapper-of-character*
215                      *the-wrapper-of-bit-vector* *the-wrapper-of-array*))                      *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
216    
217    ;;;; Type specifier hackery:
218    
219    ;;; internal to this file.
220  (defun coerce-to-class (class &optional make-forward-referenced-class-p)  (defun coerce-to-class (class &optional make-forward-referenced-class-p)
221    (if (symbolp class)    (if (symbolp class)
222        (or (find-class class (not make-forward-referenced-class-p))        (or (find-class class (not make-forward-referenced-class-p))
223            (ensure-class class))            (ensure-class class))
224        class))        class))
225    
226    ;;; Interface
227  (defun specializer-from-type (type &aux args)  (defun specializer-from-type (type &aux args)
228    (when (consp type)    (when (consp type)
229      (setq args (cdr type) type (car type)))      (setq args (cdr type) type (car type)))
# Line 229  Line 235 
235                                           :object (coerce-to-class (car args))))                                           :object (coerce-to-class (car args))))
236                 (class-eq (class-eq-specializer (coerce-to-class (car args))))                 (class-eq (class-eq-specializer (coerce-to-class (car args))))
237                 (eql      (intern-eql-specializer (car args))))))                 (eql      (intern-eql-specializer (car args))))))
238            #+cmu17
239            ((and (null args) (typep type 'lisp:class))
240             (or (kernel:class-pcl-class type)
241                 (find-structure-class (lisp:class-name type))))
242          ((specializerp type) type)))          ((specializerp type) type)))
243    
244    ;;; interface
245  (defun type-from-specializer (specl)  (defun type-from-specializer (specl)
246    (cond ((eq specl 't)    (cond ((eq specl 't)
247           't)           't)
# Line 299  Line 310 
310    `(satisfies ,(make-class-eq-predicate class)))    `(satisfies ,(make-class-eq-predicate class)))
311  ||#  ||#
312    
313  #-excl  #-(or excl cmu17)
314  (deftype eql (type-object)  (deftype eql (type-object)
315    `(member ,type-object))    `(member ,type-object))
316    
317    
318    ;;; Internal to this file.
319  ;;;  ;;;
320  ;;; These functions are a pale imitiation of their namesake.  They accept  ;;; These functions are a pale imitiation of their namesake.  They accept
321  ;;; class objects or types where they should.  ;;; class objects or types where they should.
# Line 328  Line 339 
339          (t          (t
340           (error "~s is not a type" type))))           (error "~s is not a type" type))))
341    
342    ;;; Not used...
343    #+nil
344  (defun unparse-type-list (tlist)  (defun unparse-type-list (tlist)
345    (mapcar #'unparse-type tlist))    (mapcar #'unparse-type tlist))
346    
347    ;;; Not used...
348    #+nil
349  (defun unparse-type (type)  (defun unparse-type (type)
350    (if (atom type)    (if (atom type)
351        (if (specializerp type)        (if (specializerp type)
# Line 342  Line 357 
357          (class (class-name (cadr type)))          (class (class-name (cadr type)))
358          (t `(,(car type) ,@(unparse-type-list (cdr type)))))))          (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
359    
360    ;;; internal to this file...
361  (defun convert-to-system-type (type)  (defun convert-to-system-type (type)
362    (case (car type)    (case (car type)
363      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type))))      ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
364      (class (class-name (cadr type))) ; it had better be a named class                                            (cdr type))))
365      (class-eq (class-name (cadr type))) ; this one is impossible to do right      ((class class-eq) ; class-eq is impossible to do right
366         #-cmu17 (class-name (cadr type))
367         #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))
368      (eql type)      (eql type)
369      (t (if (null (cdr type))      (t (if (null (cdr type))
370             (car type)             (car type)
371             type))))             type))))
372    
373    ;;; not used...
374    #+nil
375  (defun *typep (object type)  (defun *typep (object type)
376    (setq type (*normalize-type type))    (setq type (*normalize-type type))
377    (cond ((member (car type) '(eql wrapper-eq class-eq class))    (cond ((member (car type) '(eql wrapper-eq class-eq class))
# Line 361  Line 381 
381          (t          (t
382           (typep object (convert-to-system-type type)))))           (typep object (convert-to-system-type type)))))
383    
384    
385    ;;; *SUBTYPEP  --  Interface
386    ;;;
387  ;Writing the missing NOT and AND clauses will improve  ;Writing the missing NOT and AND clauses will improve
388  ;the quality of code generated by generate-discrimination-net, but  ;the quality of code generated by generate-discrimination-net, but
389  ;calling subtypep in place of just returning (values nil nil) can be  ;calling subtypep in place of just returning (values nil nil) can be
# Line 390  Line 413 
413                           (convert-to-system-type type2))))))))                           (convert-to-system-type type2))))))))
414    
415  (defun do-satisfies-deftype (name predicate)  (defun do-satisfies-deftype (name predicate)
416      #+cmu17 (declare (ignore name predicate))
417    #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)    #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
418    (let* ((specifier `(satisfies ,predicate))    (let* ((specifier `(satisfies ,predicate))
419           (expand-fn #'(lambda (&rest ignore)           (expand-fn #'(lambda (&rest ignore)
# Line 406  Line 430 
430          (setf (get name 'excl::deftype-expander) expand-fn)          (setf (get name 'excl::deftype-expander) expand-fn)
431          #+:coral          #+:coral
432          (setf (get name 'ccl::deftype-expander) expand-fn)))          (setf (get name 'ccl::deftype-expander) expand-fn)))
433    #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral)    #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17)
434    ;; This is the default for ports for which we don't know any    ;; This is the default for ports for which we don't know any
435    ;; better.  Note that for most ports, providing this definition    ;; better.  Note that for most ports, providing this definition
436    ;; should just speed up class definition.  It shouldn't have an    ;; should just speed up class definition.  It shouldn't have an
# Line 547  Line 571 
571                   list)     ()                       (symbol list sequence t)                   list)     ()                       (symbol list sequence t)
572       nil)))       nil)))
573    
574    #+cmu17
575    (labels ((direct-supers (class)
576               (if (typep class 'lisp:built-in-class)
577                   (kernel:built-in-class-direct-superclasses class)
578                   (let ((inherits (kernel:layout-inherits
579                                    (kernel:class-layout class))))
580                     (list (svref inherits (1- (length inherits)))))))
581             (direct-subs (class)
582               (ext:collect ((res))
583                 (let ((subs (kernel:class-subclasses class)))
584                   (when subs
585                     (ext:do-hash (sub v subs)
586                       (declare (ignore v))
587                       (when (member class (direct-supers sub))
588                         (res sub)))))
589                 (res))))
590      (ext:collect ((res))
591        (dolist (bic kernel::built-in-classes)
592          (let* ((name (car bic))
593                 (class (lisp:find-class name)))
594            (unless (member name '(t kernel:instance kernel:funcallable-instance
595                                     function))
596              (res `(,name
597                     ,(mapcar #'lisp:class-name (direct-supers class))
598                     ,(mapcar #'lisp:class-name (direct-subs class))
599                     ,(map 'list #'(lambda (x)
600                                     (lisp:class-name (kernel:layout-class x)))
601                           (reverse
602                            (kernel:layout-inherits
603                             (kernel:class-layout class))))
604                     ,(let ((found (assoc name *built-in-classes*)))
605                        (if found (fifth found) 42)))))))
606        (setq *built-in-classes* (res))))
607    
608    
609  ;;;  ;;;
610  ;;; The classes that define the kernel of the metabraid.  ;;; The classes that define the kernel of the metabraid.
# Line 554  Line 612 
612  (defclass t () ()  (defclass t () ()
613    (:metaclass built-in-class))    (:metaclass built-in-class))
614    
615  (defclass slot-object (t) ()  #+cmu17
616    (progn
617      (defclass kernel:instance (t) ()
618        (:metaclass built-in-class))
619    
620      (defclass function (t) ()
621        (:metaclass built-in-class))
622    
623      (defclass kernel:funcallable-instance (function) ()
624        (:metaclass built-in-class)))
625    
626    (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) ()
627    (:metaclass slot-class))    (:metaclass slot-class))
628    
629  (defclass structure-object (slot-object) ()  (defclass structure-object (slot-object) ()
630    (:metaclass structure-class))    (:metaclass structure-class))
631    
632  (defstruct (structure-object  (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object
633               (:constructor |STRUCTURE-OBJECT class constructor|)))               (:constructor |STRUCTURE-OBJECT class constructor|)))
634    
635    
636  (defclass standard-object (slot-object) ())  (defclass standard-object (slot-object) ())
637    
638  (defclass metaobject (standard-object) ())  (defclass metaobject (standard-object) ())
# Line 836  Line 906 
906  (defclass generic-function (dependent-update-mixin  (defclass generic-function (dependent-update-mixin
907                              definition-source-mixin                              definition-source-mixin
908                              documentation-mixin                              documentation-mixin
909                              metaobject)                              metaobject
910                                #+cmu17 kernel:funcallable-instance)
911       ()       ()
912    (:metaclass funcallable-standard-class))    (:metaclass funcallable-standard-class))
913    

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

  ViewVC Help
Powered by ViewVC 1.1.5