X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=699271225315364359be4c2ab164a3ab70d19c40;hb=ef8fd235fa2ca39e444710d1bc275acbc8d3279c;hp=930ea76bb560839c1fccbb80419a5d313cfe0a98;hpb=2eee1c446adf860571a0d5e89eb5c547806cda76;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 930ea76..6992712 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -154,6 +154,9 @@ (declare (ignore type1)) (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2))) +(!define-type-method (values :negate) (type) + (error "NOT VALUES too confusing on ~S" (type-specifier type))) + (!define-type-method (values :unparse) (type) (cons 'values (let ((unparsed (unparse-args-types type))) @@ -192,6 +195,9 @@ (defvar *unparse-fun-type-simplify*) (!cold-init-forms (setq *unparse-fun-type-simplify* nil)) +(!define-type-method (function :negate) (type) + (error "NOT FUNCTION too confusing on ~S" (type-specifier type))) + (!define-type-method (function :unparse) (type) (if *unparse-fun-type-simplify* 'function @@ -301,6 +307,10 @@ ((csubtypep type1 (specifier-type 'function)) nil) (t :call-other-method))) (!define-type-method (function :complex-union2) (type1 type2) + (declare (ignore type2)) + ;; TYPE2 is a FUNCTION type. If TYPE1 is a classoid type naming + ;; FUNCTION, then it is the union of the two; otherwise, there is no + ;; special union. (cond ((type= type1 (specifier-type 'function)) type1) (t nil))) @@ -318,6 +328,9 @@ (!define-type-class constant :inherits values) +(!define-type-method (constant :negate) (type) + (error "NOT CONSTANT too confusing on ~S" (type-specifier type))) + (!define-type-method (constant :unparse) (type) `(constant-arg ,(type-specifier (constant-type-type type)))) @@ -898,6 +911,17 @@ (declare (type ctype type)) (funcall (type-class-unparse (type-class-info type)) type)) +(defun-cached (type-negation :hash-function (lambda (type) + (logand (type-hash-value type) + #xff)) + :hash-bits 8 + :values 1 + :default nil + :init-wrapper !cold-init-forms) + ((type eq)) + (declare (type ctype type)) + (funcall (type-class-negate (type-class-info type)) type)) + ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to ;;; early-type.lisp by WHN ca. 19990201.) @@ -1011,11 +1035,6 @@ (!define-type-class named) -(defvar *wild-type*) -(defvar *empty-type*) -(defvar *universal-type*) -(defvar *universal-fun-type*) - (!cold-init-forms (macrolet ((frob (name var) `(progn @@ -1119,11 +1138,21 @@ ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (hierarchical-union2 type1 type2)) +(!define-type-method (named :negate) (x) + (aver (not (eq x *wild-type*))) + (cond + ((eq x *universal-type*) *empty-type*) + ((eq x *empty-type*) *universal-type*) + (t (bug "NAMED type not universal, wild or empty: ~S" x)))) + (!define-type-method (named :unparse) (x) (named-type-name x)) ;;;; hairy and unknown types +(!define-type-method (hairy :negate) (x) + (make-negation-type :type x)) + (!define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) @@ -1189,8 +1218,13 @@ ;;;; negation types +(!define-type-method (negation :negate) (x) + (negation-type-type x)) + (!define-type-method (negation :unparse) (x) - `(not ,(type-specifier (negation-type-type x)))) + (if (type= (negation-type-type x) (specifier-type 'cons)) + 'atom + `(not ,(type-specifier (negation-type-type x))))) (!define-type-method (negation :simple-subtypep) (type1 type2) (csubtypep (negation-type-type type2) (negation-type-type type1))) @@ -1341,123 +1375,7 @@ (type= (negation-type-type type1) (negation-type-type type2))) (!def-type-translator not (typespec) - (let* ((not-type (specifier-type typespec)) - (spec (type-specifier not-type))) - (cond - ;; canonicalize (NOT (NOT FOO)) - ((and (listp spec) (eq (car spec) 'not)) - (specifier-type (cadr spec))) - ;; canonicalize (NOT NIL) and (NOT T) - ((eq not-type *empty-type*) *universal-type*) - ((eq not-type *universal-type*) *empty-type*) - ((and (numeric-type-p not-type) - (null (numeric-type-low not-type)) - (null (numeric-type-high not-type))) - (make-negation-type :type not-type)) - ((numeric-type-p not-type) - (type-union - (make-negation-type - :type (modified-numeric-type not-type :low nil :high nil)) - (cond - ((null (numeric-type-low not-type)) - (modified-numeric-type - not-type - :low (let ((h (numeric-type-high not-type))) - (if (consp h) (car h) (list h))) - :high nil)) - ((null (numeric-type-high not-type)) - (modified-numeric-type - not-type - :low nil - :high (let ((l (numeric-type-low not-type))) - (if (consp l) (car l) (list l))))) - (t (type-union - (modified-numeric-type - not-type - :low nil - :high (let ((l (numeric-type-low not-type))) - (if (consp l) (car l) (list l)))) - (modified-numeric-type - not-type - :low (let ((h (numeric-type-high not-type))) - (if (consp h) (car h) (list h))) - :high nil)))))) - ((intersection-type-p not-type) - (apply #'type-union - (mapcar #'(lambda (x) - (specifier-type `(not ,(type-specifier x)))) - (intersection-type-types not-type)))) - ((union-type-p not-type) - (apply #'type-intersection - (mapcar #'(lambda (x) - (specifier-type `(not ,(type-specifier x)))) - (union-type-types not-type)))) - ((member-type-p not-type) - (let ((members (member-type-members not-type))) - (if (some #'floatp members) - (let (floats) - (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero))) - (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero))) - #!+long-float - (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero))))) - (when (member (car pair) members) - (aver (not (member (cdr pair) members))) - (push (cdr pair) floats) - (setf members (remove (car pair) members))) - (when (member (cdr pair) members) - (aver (not (member (car pair) members))) - (push (car pair) floats) - (setf members (remove (cdr pair) members)))) - (apply #'type-intersection - (if (null members) - *universal-type* - (make-negation-type - :type (make-member-type :members members))) - (mapcar - (lambda (x) - (let ((type (ctype-of x))) - (type-union - (make-negation-type - :type (modified-numeric-type type - :low nil :high nil)) - (modified-numeric-type type - :low nil :high (list x)) - (make-member-type :members (list x)) - (modified-numeric-type type - :low (list x) :high nil)))) - floats))) - (make-negation-type :type not-type)))) - ((and (cons-type-p not-type) - (eq (cons-type-car-type not-type) *universal-type*) - (eq (cons-type-cdr-type not-type) *universal-type*)) - (make-negation-type :type not-type)) - ((cons-type-p not-type) - (type-union - (make-negation-type :type (specifier-type 'cons)) - (cond - ((and (not (eq (cons-type-car-type not-type) *universal-type*)) - (not (eq (cons-type-cdr-type not-type) *universal-type*))) - (type-union - (make-cons-type - (specifier-type `(not ,(type-specifier - (cons-type-car-type not-type)))) - *universal-type*) - (make-cons-type - *universal-type* - (specifier-type `(not ,(type-specifier - (cons-type-cdr-type not-type))))))) - ((not (eq (cons-type-car-type not-type) *universal-type*)) - (make-cons-type - (specifier-type `(not ,(type-specifier - (cons-type-car-type not-type)))) - *universal-type*)) - ((not (eq (cons-type-cdr-type not-type) *universal-type*)) - (make-cons-type - *universal-type* - (specifier-type `(not ,(type-specifier - (cons-type-cdr-type not-type)))))) - (t (bug "Weird CONS type ~S" not-type))))) - (t (make-negation-type :type not-type))))) + (type-negation (specifier-type typespec))) ;;;; numeric types @@ -1476,6 +1394,37 @@ (equalp (numeric-type-high type1) (numeric-type-high type2))) t)) +(!define-type-method (number :negate) (type) + (if (and (null (numeric-type-low type)) (null (numeric-type-high type))) + (make-negation-type :type type) + (type-union + (make-negation-type + :type (modified-numeric-type type :low nil :high nil)) + (cond + ((null (numeric-type-low type)) + (modified-numeric-type + type + :low (let ((h (numeric-type-high type))) + (if (consp h) (car h) (list h))) + :high nil)) + ((null (numeric-type-high type)) + (modified-numeric-type + type + :low nil + :high (let ((l (numeric-type-low type))) + (if (consp l) (car l) (list l))))) + (t (type-union + (modified-numeric-type + type + :low nil + :high (let ((l (numeric-type-low type))) + (if (consp l) (car l) (list l)))) + (modified-numeric-type + type + :low (let ((h (numeric-type-high type))) + (if (consp h) (car h) (list h))) + :high nil))))))) + (!define-type-method (number :unparse) (type) (let* ((complexp (numeric-type-complexp type)) (low (numeric-type-low type)) @@ -2144,7 +2093,7 @@ (multiple-value-bind (equalp certainp) (type= (array-type-element-type type1) (array-type-element-type type2)) - ;; by its nature, the call to TYPE= should never return NIL, + ;; By its nature, the call to TYPE= should never return NIL, ;; T, as we don't know what the UNKNOWN-TYPE will grow up to ;; be. -- CSR, 2002-08-19 (aver (not (and (not equalp) certainp))) @@ -2157,6 +2106,12 @@ (specialized-element-type-maybe type2))) t))) +(!define-type-method (array :negate) (type) + ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the + ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY + ;; NIL) (ARRAY CHAR) ...) equivalent?" -- CSR, 2003-12-10 + (make-negation-type :type type)) + (!define-type-method (array :unparse) (type) (let ((dims (array-type-dimensions type)) (eltype (type-specifier (array-type-element-type type))) @@ -2338,6 +2293,42 @@ (!define-type-class member) +(!define-type-method (member :negate) (type) + (let ((members (member-type-members type))) + (if (some #'floatp members) + (let (floats) + (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero))) + (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero))) + #!+long-float + (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero))))) + (when (member (car pair) members) + (aver (not (member (cdr pair) members))) + (push (cdr pair) floats) + (setf members (remove (car pair) members))) + (when (member (cdr pair) members) + (aver (not (member (car pair) members))) + (push (car pair) floats) + (setf members (remove (cdr pair) members)))) + (apply #'type-intersection + (if (null members) + *universal-type* + (make-negation-type + :type (make-member-type :members members))) + (mapcar + (lambda (x) + (let ((type (ctype-of x))) + (type-union + (make-negation-type + :type (modified-numeric-type type + :low nil :high nil)) + (modified-numeric-type type + :low nil :high (list x)) + (make-member-type :members (list x)) + (modified-numeric-type type + :low (list x) :high nil)))) + floats))) + (make-negation-type :type type)))) + (!define-type-method (member :unparse) (type) (let ((members (member-type-members type))) (cond @@ -2452,6 +2443,10 @@ (!define-type-class intersection) +(!define-type-method (intersection :negate) (type) + (apply #'type-union + (mapcar #'type-negation (intersection-type-types type)))) + ;;; A few intersection types have special names. The others just get ;;; mechanically unparsed. (!define-type-method (intersection :unparse) (type) @@ -2572,13 +2567,17 @@ (!def-type-translator and (&whole whole &rest type-specifiers) (apply #'type-intersection - (mapcar #'specifier-type - type-specifiers))) + (mapcar #'specifier-type type-specifiers))) ;;;; union types (!define-type-class union) +(!define-type-method (union :negate) (type) + (declare (type ctype type)) + (apply #'type-intersection + (mapcar #'type-negation (union-type-types type)))) + ;;; The LIST, FLOAT and REAL types have special names. Other union ;;; types just get mechanically unparsed. (!define-type-method (union :unparse) (type) @@ -2747,7 +2746,33 @@ (let ((car-type (single-value-specifier-type car-type-spec)) (cdr-type (single-value-specifier-type cdr-type-spec))) (make-cons-type car-type cdr-type))) - + +(!define-type-method (cons :negate) (type) + (if (and (eq (cons-type-car-type type) *universal-type*) + (eq (cons-type-cdr-type type) *universal-type*)) + (make-negation-type :type type) + (type-union + (make-negation-type :type (specifier-type 'cons)) + (cond + ((and (not (eq (cons-type-car-type type) *universal-type*)) + (not (eq (cons-type-cdr-type type) *universal-type*))) + (type-union + (make-cons-type + (type-negation (cons-type-car-type type)) + *universal-type*) + (make-cons-type + *universal-type* + (type-negation (cons-type-cdr-type type))))) + ((not (eq (cons-type-car-type type) *universal-type*)) + (make-cons-type + (type-negation (cons-type-car-type type)) + *universal-type*)) + ((not (eq (cons-type-cdr-type type) *universal-type*)) + (make-cons-type + *universal-type* + (type-negation (cons-type-cdr-type type)))) + (t (bug "Weird CONS type ~S" type)))))) + (!define-type-method (cons :unparse) (type) (let ((car-eltype (type-specifier (cons-type-car-type type))) (cdr-eltype (type-specifier (cons-type-cdr-type type)))) @@ -2778,15 +2803,19 @@ (let ((car-type1 (cons-type-car-type type1)) (car-type2 (cons-type-car-type type2)) (cdr-type1 (cons-type-cdr-type type1)) - (cdr-type2 (cons-type-cdr-type type2))) + (cdr-type2 (cons-type-cdr-type type2)) + car-not1 + car-not2) ;; UGH. -- CSR, 2003-02-24 - (macrolet ((frob-car (car1 car2 cdr1 cdr2) + (macrolet ((frob-car (car1 car2 cdr1 cdr2 + &optional (not1 nil not1p)) `(type-union (make-cons-type ,car1 (type-union ,cdr1 ,cdr2)) (make-cons-type (type-intersection ,car2 - (specifier-type - `(not ,(type-specifier ,car1)))) + ,(if not1p + not1 + `(type-negation ,car1))) ,cdr2)))) (cond ((type= car-type1 car-type2) (make-cons-type car-type1 @@ -2798,6 +2827,15 @@ (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) ((csubtypep car-type2 car-type1) (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) + ;; more general case of the above, but harder to compute + ((progn + (setf car-not1 (type-negation car-type1)) + (not (csubtypep car-type2 car-not1))) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) + ((progn + (setf car-not2 (type-negation car-type2)) + (not (csubtypep car-type1 car-not2))) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)) ;; Don't put these in -- consider the effect of taking the ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).