diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index d9be02d95..405806626 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -114,12 +114,19 @@ (define-unary-type-predicate-folder pair? &pair) (define-unary-type-predicate-folder symbol? &symbol) (define-unary-type-predicate-folder variable? &box) -(define-unary-type-predicate-folder vector? &vector) +(define-unary-type-predicate-folder mutable-vector? &mutable-vector) +(define-unary-type-predicate-folder immutable-vector? &immutable-vector) (define-unary-type-predicate-folder struct? &struct) (define-unary-type-predicate-folder string? &string) (define-unary-type-predicate-folder number? &number) (define-unary-type-predicate-folder char? &char) +(define-unary-branch-folder (vector? type min max) + (cond + ((zero? (logand type &vector)) (values #t #f)) + ((type<=? type &vector) (values #t #t)) + (else (values #f #f)))) + (define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1) (cond ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 230c1ebc0..dfd7b92fb 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -101,7 +101,8 @@ &pointer &fluid &pair - &vector + &immutable-vector + &mutable-vector &box &struct &string @@ -115,7 +116,7 @@ &null &nil &false &true &unspecified &undefined &eof ;; Union types. - &exact-integer &exact-number &real &number + &exact-integer &exact-number &real &number &vector ;; Untagged types. &f64 @@ -161,7 +162,8 @@ &pointer &fluid &pair - &vector + &immutable-vector + &mutable-vector &box &struct &string @@ -196,6 +198,9 @@ (define-syntax &number (identifier-syntax (logior &fixnum &bignum &flonum &complex &fraction))) +(define-syntax &vector + (identifier-syntax (logior &immutable-vector &mutable-vector))) + (define-syntax-rule (type<=? x type) (zero? (logand x (lognot type)))) @@ -366,7 +371,7 @@ minimum, and maximum." ((symbol? val) (return &symbol #f)) ((keyword? val) (return &keyword #f)) ((pair? val) (return &pair #f)) - ((vector? val) (return &vector (vector-length val))) + ((vector? val) (return &immutable-vector (vector-length val))) ((string? val) (return &string (string-length val))) ((bytevector? val) (return &bytevector (bytevector-length val))) ((bitvector? val) (return &bitvector (bitvector-length val))) @@ -666,7 +671,8 @@ minimum, and maximum." (define-simple-predicate-inferrer pair? &pair) (define-simple-predicate-inferrer symbol? &symbol) (define-simple-predicate-inferrer variable? &box) -(define-simple-predicate-inferrer vector? &vector) +(define-simple-predicate-inferrer immutable-vector? &immutable-vector) +(define-simple-predicate-inferrer mutable-vector? &mutable-vector) (define-simple-predicate-inferrer struct? &struct) (define-simple-predicate-inferrer string? &string) (define-simple-predicate-inferrer bytevector? &bytevector) @@ -679,6 +685,10 @@ minimum, and maximum." (define-simple-predicate-inferrer compnum? &complex) (define-simple-predicate-inferrer fracnum? &fraction) +(define-predicate-inferrer (vector? val true?) + (define ¬-vector (logand &all-types (lognot &vector))) + (restrict! val (if true? &vector ¬-vector) -inf.0 +inf.0)) + (define-predicate-inferrer (eq? a b true?) ;; We can only propagate information down the true leg. (when true?