X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=3953c543a637e8684e5eac4e5cffcad0ade3e82f;hb=8258b3ef68a2ce4529c4c62e54ad2035193c1a53;hp=695b27a494f4d82a82e5c6387926582d00f513ac;hpb=8c74121c546327088c6693e5d4bf673ac97feb64;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 695b27a..3953c54 100644
--- 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))))))
 
 ;;;; VALUES types interfaces
 ;;;;
@@ -1345,36 +1378,35 @@
         (hairy-spec2 (hairy-type-specifier type2)))
     (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2)
            (values t t))
+          ((maybe-reparse-specifier! type1)
+           (csubtypep type1 type2))
+          ((maybe-reparse-specifier! type2)
+           (csubtypep type1 type2))
           (t
            (values nil nil)))))
 
 (!define-type-method (hairy :complex-subtypep-arg2) (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)))))
+  (if (maybe-reparse-specifier! type2)
+      (csubtypep 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))
-  (values nil nil))
+  (if (maybe-reparse-specifier! type1)
+      (csubtypep type1 type2)
+      (values nil nil)))
 
 (!define-type-method (hairy :complex-=) (type1 type2)
-  (if (and (unknown-type-p type2)
-           (let* ((specifier2 (unknown-type-specifier type2))
-                  (name2 (if (consp specifier2)
-                             (car specifier2)
-                             specifier2)))
-             (info :type :kind name2)))
-      (let ((type2 (specifier-type (unknown-type-specifier type2))))
-        (if (unknown-type-p type2)
-            (values nil nil)
-            (type= type1 type2)))
-  (values nil nil)))
+  (if (maybe-reparse-specifier! type2)
+      (type= type1 type2)
+      (values nil nil)))
 
 (!define-type-method (hairy :simple-intersection2 :complex-intersection2)
                      (type1 type2)
@@ -3342,42 +3374,45 @@ used for a COMPLEX component.~:@>"
 ;;; type without that particular element. This seems too hairy to be
 ;;; worthwhile, given its low utility.
 (defun type-difference (x y)
-  (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
-        (y-types (if (union-type-p y) (union-type-types y) (list y))))
-    (collect ((res))
-      (dolist (x-type x-types)
-        (if (member-type-p x-type)
-            (let ((xset (alloc-xset))
-                  (fp-zeroes nil))
-              (mapc-member-type-members
-               (lambda (elt)
-                 (multiple-value-bind (ok sure) (ctypep elt y)
-                   (unless sure
-                     (return-from type-difference nil))
-                   (unless ok
-                     (if (fp-zero-p elt)
-                         (pushnew elt fp-zeroes)
-                         (add-to-xset elt xset)))))
-               x-type)
-              (unless (and (xset-empty-p xset) (not fp-zeroes))
-                (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
-            (dolist (y-type y-types (res x-type))
-              (multiple-value-bind (val win) (csubtypep x-type y-type)
-                (unless win (return-from type-difference nil))
-                (when val (return))
-                (when (types-equal-or-intersect x-type y-type)
-                  (return-from type-difference nil))))))
-      (let ((y-mem (find-if #'member-type-p y-types)))
-        (when y-mem
+  (if (and (numeric-type-p x) (numeric-type-p y))
+      ;; Numeric types are easy. Are there any others we should handle like this?
+      (type-intersection x (type-negation y))
+      (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
+            (y-types (if (union-type-p y) (union-type-types y) (list y))))
+        (collect ((res))
           (dolist (x-type x-types)
-            (unless (member-type-p x-type)
-              (mapc-member-type-members
-               (lambda (member)
-                 (multiple-value-bind (ok sure) (ctypep member x-type)
-                   (when (or (not sure) ok)
-                     (return-from type-difference nil))))
-               y-mem)))))
-      (apply #'type-union (res)))))
+            (if (member-type-p x-type)
+                (let ((xset (alloc-xset))
+                      (fp-zeroes nil))
+                  (mapc-member-type-members
+                   (lambda (elt)
+                     (multiple-value-bind (ok sure) (ctypep elt y)
+                       (unless sure
+                         (return-from type-difference nil))
+                       (unless ok
+                         (if (fp-zero-p elt)
+                             (pushnew elt fp-zeroes)
+                             (add-to-xset elt xset)))))
+                   x-type)
+                  (unless (and (xset-empty-p xset) (not fp-zeroes))
+                    (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
+                (dolist (y-type y-types (res x-type))
+                  (multiple-value-bind (val win) (csubtypep x-type y-type)
+                    (unless win (return-from type-difference nil))
+                    (when val (return))
+                    (when (types-equal-or-intersect x-type y-type)
+                      (return-from type-difference nil))))))
+          (let ((y-mem (find-if #'member-type-p y-types)))
+            (when y-mem
+              (dolist (x-type x-types)
+                (unless (member-type-p x-type)
+                  (mapc-member-type-members
+                   (lambda (member)
+                     (multiple-value-bind (ok sure) (ctypep member x-type)
+                       (when (or (not sure) ok)
+                         (return-from type-difference nil))))
+                   y-mem)))))
+          (apply #'type-union (res))))))
 
 (!def-type-translator array (&optional (element-type '*)
                                        (dimensions '*))