diff --git a/code/type.lisp b/code/type.lisp index a395d726878110de4c4cd8862b66d6c1144b8bf7..f817ba9af577d4775b98920b656eaa93b3fc5114 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.1 1993/02/04 22:37:05 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.2 1993/02/08 22:22:18 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -217,6 +217,7 @@ (declare (ignore type1 type2)) (values nil t)) + ;;; The union or intersection of two FUNCTION types is FUNCTION. ;;; (define-type-method (function :simple-union) (type1 type2) @@ -227,6 +228,9 @@ (declare (ignore type1 type2)) (values (specifier-type 'function) t)) +(define-type-method (function :complex-intersection) (type1 type2) + (vanilla-intersection type1 type2)) + ;;; ### Not very real, but good enough for redefining transforms according to ;;; type: @@ -690,10 +694,15 @@ (declare (type ctype type1 type2)) (if (eq type1 type2) type1 - (or (invoke-type-method :simple-union :complex-union - type1 type2 - :default nil) - (make-union-type (list type1 type2))))) + (let ((res (invoke-type-method :simple-union :complex-union + type1 type2 + :default :vanilla))) + (cond ((eq res :vanilla) + (or (vanilla-union type1 type2) + (make-union-type (list type1 type2)))) + (res) + (t + (make-union-type (list type1 type2))))))) ;;; Type-Intersection -- Interface @@ -837,82 +846,52 @@ ;;;; Builtin types. -;;; The NAMED-TYPE is used to represent * and NIL, which are the two non-class -;;; primitive types. +;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be +;;; super or sub types of all types, not just classes and * & NIL aren't +;;; classes anyway, so it wouldn't make much sense to make them built-in +;;; classes. ;;; -(defstruct (named-type (:include ctype) +(defstruct (named-type (:include ctype + (:class-info (type-class-or-lose 'named))) (:print-function %print-type)) (name nil :type symbol)) -(define-type-class wild) -(defvar *wild-type*) -(cold-load-init - (setq *wild-type* - (make-named-type :name '* :class-info (type-class-or-lose 'wild))) - (setf (info type kind '*) :primitive) - (setf (info type builtin '*) *wild-type*)) +(define-type-class named) -(define-type-method (wild :simple-subtypep :simple-intersection :simple-=) - (type1 type2) - (declare (ignore type1 type2)) - (error "Shouldn't happen.")) - -(define-type-method (wild :complex-subtypep-arg1) (type1 type2) - (declare (ignore type1 type2)) - (values nil t)) - -(define-type-method (wild :complex-subtypep-arg2) (type1 type2) - (declare (ignore type1 type2)) - (values t t)) - -(define-type-method (wild :complex-union) (type1 type2) - (declare (ignore type1 type2)) - (values *wild-type* t)) - -(define-type-method (wild :complex-intersection) (type1 type2) - (declare (ignore type1)) - (values type2 t)) - -(define-type-method (wild :unparse) (x) - (declare (ignore x)) - '*) - -(define-type-class bottom) +(defvar *wild-type*) (defvar *empty-type*) -(cold-load-init - (setq *empty-type* - (make-named-type :class-info (type-class-or-lose 'bottom) - :name 'nil)) - (setf (info type kind nil) :primitive) - (setf (info type builtin nil) *empty-type*)) - -(define-type-method (bottom :simple-subtypep :simple-intersection :simple-=) - (type1 type2) - (declare (ignore type1 type2)) - (error "Shouldn't happen.")) - -(define-type-method (bottom :complex-subtypep-arg1) (type1 type2) - (declare (ignore type1 type2)) - (values t t)) - -(define-type-method (bottom :complex-subtypep-arg2) (type1 type2) - (declare (ignore type1 type2)) - (values nil t)) - -(define-type-method (bottom :complex-union) (type1 type2) - (declare (ignore type2)) - (values type1 t)) - -(define-type-method (bottom :complex-intersection) (type1 type2) - (declare (ignore type1 type2)) - (values *empty-type* t)) +(defvar *universal-type*) -(define-type-method (bottom :unparse) (x) - (declare (ignore x)) - 'nil) +(cold-load-init + (macrolet ((frob (name var) + `(progn + (setq ,var (make-named-type :name ',name)) + (setf (info type kind ',name) :primitive) + (setf (info type builtin ',name) ,var)))) + (frob * *wild-type*) + (frob nil *empty-type*) + (frob t *universal-type*))) + +(define-type-method (named :simple-=) (type1 type2) + (eq type1 type2)) + +(define-type-method (named :simple-subtypep) (type1 type2) + (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) + +(define-type-method (named :complex-subtypep-arg1) (type1 type2) + (assert (not (hairy-type-p type2))) + (values (eq type1 *empty-type*) t)) + +(define-type-method (named :complex-subtypep-arg2) (type1 type2) + (if (hairy-type-p type1) + (values nil nil) + (values (not (eq type2 *empty-type*)) t))) + +(define-type-method (named :complex-intersection) (type1 type2) + (vanilla-intersection type1 type2)) -(defvar *universal-type*) -(cold-load-init (setq *universal-type* (specifier-type 't))) +(define-type-method (named :unparse) (x) + (named-type-name x)) ;;;; Hairy and unknown types: @@ -1831,14 +1810,6 @@ ;;;; Union types: -#+reload -(define-type-method (structure :simple-union) (t1 t2) - (vanilla-union t1 t2)) - -#+reload -(define-type-method (named :simple-union) (t1 t2) - (vanilla-union t1 t2)) - ;;; The Union-Type represents uses of the OR type specifier which can't be ;;; canonicalized to something simpler. Canonical form: ;;; @@ -2125,17 +2096,18 @@ (defun ctypep (obj type) (declare (type ctype type)) (etypecase type - ((or numeric-type named-type member-type array-type - #+reload structure-type) + ((or numeric-type named-type member-type array-type built-in-class) (values (%typep obj type) t)) (class - (if #-ns-boot(%instancep obj) + (if #-ns-boot(if (csubtypep type (specifier-type 'generic-function)) + (funcallable-instance-p obj) + (%instancep obj)) #+ns-boot(structurep obj) (if (eq (class-layout type) (info type compiler-layout (class-name type))) (values (typep obj type) t) - (values nil nil))) - (values nil t)) + (values nil nil)) + (values nil t))) (union-type (dolist (mem (union-type-types type) (values nil t)) (multiple-value-bind (val win) @@ -2280,7 +2252,7 @@ ;;; ;;; A type specifier. -(deftype type-specifier () '(or list symbol)) +(deftype type-specifier () '(or list symbol class)) ;;; ;;; An index into an array. Also used for sequence index. (deftype index () `(integer 0 (,array-dimension-limit)))