1.0.35.11: Minor cleanup in MAKE-FUN-TYPE / MAKE-VALUES-TYPE

[sbcl.git] / src / code / late-type.lisp

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index ea1fdaa..190c42b 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -358,11 +358,44 @@
     (result)))
 
 (!def-type-translator function (&optional (args '*) (result '*))
-  (make-fun-type :args args
-                 :returns (coerce-to-values (values-specifier-type result))))
+  (let ((result (coerce-to-values (values-specifier-type result))))
+    (if (eq args '*)
+        (if (eq result *wild-type*)
+            (specifier-type 'function)
+            (make-fun-type :wild-args t :returns result))
+        (multiple-value-bind (required optional rest keyp keywords allowp)
+            (parse-args-types args)
+          (if (and (null required)
+                   (null optional)
+                   (eq rest *universal-type*)
+                   (not keyp))
+              (if (eq result *wild-type*)
+                  (specifier-type 'function)
+                  (make-fun-type :wild-args t :returns result))
+              (make-fun-type :required required
+                             :optional optional
+                             :rest rest
+                             :keyp keyp
+                             :keywords keywords
+                             :allowp allowp
+                             :returns result))))))
 
 (!def-type-translator values (&rest values)
-  (make-values-type :args values))
+  (if (eq values '*)
+      *wild-type*
+      (multiple-value-bind (required optional rest keyp keywords allowp llk-p)
+          (parse-args-types values)
+        (declare (ignore keywords))
+        (cond (keyp
+               (error "&KEY appeared in a VALUES type specifier ~S."
+                      `(values ,@values)))
+              (llk-p
+               (make-values-type :required required
+                                 :optional optional
+                                 :rest rest
+                                 :allowp allowp))
+              (t
+               (make-short-values-type required))))))
 \f
 ;;;; VALUES types interfaces
 ;;;;
@@ -1349,7 +1382,15 @@
            (values nil nil)))))
 
 (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
-  (invoke-complex-subtypep-arg1-method type1 type2))
+  (let ((specifier (hairy-type-specifier type2)))
+    (cond
+      ((and (consp specifier) (eql (car specifier) 'satisfies))
+       (case (cadr specifier)
+         ((keywordp) (if (type= type1 (specifier-type 'symbol))
+                         (values nil t)
+                         (invoke-complex-subtypep-arg1-method type1 type2)))
+         (t (invoke-complex-subtypep-arg1-method type1 type2))))
+      (t (invoke-complex-subtypep-arg1-method type1 type2)))))
 
 (!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
   (declare (ignore type1 type2))
@@ -1531,11 +1572,26 @@
        (aver (not (eq (type-union not1 not2) *universal-type*)))
        nil))))
 
+(defun maybe-complex-array-refinement (type1 type2)
+  (let* ((ntype (negation-type-type type2))
+         (ndims (array-type-dimensions ntype))
+         (ncomplexp (array-type-complexp ntype))
+         (nseltype (array-type-specialized-element-type ntype))
+         (neltype (array-type-element-type ntype)))
+    (if (and (eql ndims '*) (null ncomplexp)
+             (eql neltype *wild-type*) (eql nseltype *wild-type*))
+        (make-array-type :dimensions (array-type-dimensions type1)
+                         :complexp t
+                         :element-type (array-type-element-type type1)
+                         :specialized-element-type (array-type-specialized-element-type type1)))))
+
 (!define-type-method (negation :complex-intersection2) (type1 type2)
   (cond
     ((csubtypep type1 (negation-type-type type2)) *empty-type*)
     ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
      type1)
+    ((and (array-type-p type1) (array-type-p (negation-type-type type2)))
+     (maybe-complex-array-refinement type1 type2))
     (t nil)))
 
 (!define-type-method (negation :simple-union2) (type1 type2)
@@ -2343,21 +2399,31 @@ used for a COMPLEX component.~:@>"
         (complexp (array-type-complexp type)))
     (cond ((eq dims '*)
            (if (eq eltype '*)
-               (if complexp 'array 'simple-array)
-               (if complexp `(array ,eltype) `(simple-array ,eltype))))
+               (ecase complexp
+                 ((t) '(and array (not simple-array)))
+                 ((:maybe) 'array)
+                 ((nil) 'simple-array))
+               (ecase complexp
+                 ((t) `(and (array ,eltype) (not simple-array)))
+                 ((:maybe) `(array ,eltype))
+                 ((nil) `(simple-array ,eltype)))))
           ((= (length dims) 1)
            (if complexp
-               (if (eq (car dims) '*)
-                   (case eltype
-                     (bit 'bit-vector)
-                     ((base-char #!-sb-unicode character) 'base-string)
-                     (* 'vector)
-                     (t `(vector ,eltype)))
-                   (case eltype
-                     (bit `(bit-vector ,(car dims)))
-                     ((base-char #!-sb-unicode character)
-                      `(base-string ,(car dims)))
-                     (t `(vector ,eltype ,(car dims)))))
+               (let ((answer
+                      (if (eq (car dims) '*)
+                          (case eltype
+                            (bit 'bit-vector)
+                            ((base-char #!-sb-unicode character) 'base-string)
+                            (* 'vector)
+                            (t `(vector ,eltype)))
+                          (case eltype
+                            (bit `(bit-vector ,(car dims)))
+                            ((base-char #!-sb-unicode character)
+                             `(base-string ,(car dims)))
+                            (t `(vector ,eltype ,(car dims)))))))
+                 (if (eql complexp :maybe)
+                     answer
+                     `(and ,answer (not simple-array))))
                (if (eq (car dims) '*)
                    (case eltype
                      (bit 'simple-bit-vector)
@@ -2371,9 +2437,10 @@ used for a COMPLEX component.~:@>"
                      ((t) `(simple-vector ,(car dims)))
                      (t `(simple-array ,eltype ,dims))))))
           (t
-           (if complexp
-               `(array ,eltype ,dims)
-               `(simple-array ,eltype ,dims))))))
+           (ecase complexp
+             ((t) `(and (array ,eltype ,dims) (not simple-array)))
+             ((:maybe) `(array ,eltype ,dims))
+             ((nil) `(simple-array ,eltype ,dims)))))))
 
 (!define-type-method (array :simple-subtypep) (type1 type2)
   (let ((dims1 (array-type-dimensions type1))