X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-type.lisp;h=1b395f1830bda6c792b813412e607f5eb1e038dc;hb=1d881f74d4c2c6099107544a5f337837eb281865;hp=5e95184a09d92da7a4e4c0e61bbe6bbace3cd233;hpb=2dbee6e782b54f8780933790d61a24cdb67b8d04;p=sbcl.git

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 5e95184..1b395f1 100644
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -34,6 +34,26 @@
 (defstruct (unknown-type (:include hairy-type)
                          (:copier nil)))
 
+(defun maybe-reparse-specifier (type)
+  (when (unknown-type-p type)
+    (let* ((spec (unknown-type-specifier type))
+           (name (if (consp spec)
+                     (car spec)
+                     spec)))
+      (when (info :type :kind name)
+        (let ((new-type (specifier-type spec)))
+          (unless (unknown-type-p new-type)
+            new-type))))))
+
+;;; Evil macro.
+(defmacro maybe-reparse-specifier! (type)
+  (assert (symbolp type))
+  (with-unique-names (new-type)
+    `(let ((,new-type (maybe-reparse-specifier ,type)))
+       (when ,new-type
+         (setf ,type ,new-type)
+         t))))
+
 (defstruct (negation-type (:include ctype
                                     (class-info (type-class-or-lose 'negation))
                                     ;; FIXME: is this right?  It's
@@ -114,8 +134,14 @@
             (:include args-type
                       (class-info (type-class-or-lose 'values)))
             (:constructor %make-values-type)
+            (:predicate %values-type-p)
             (:copier nil)))
 
+(declaim (inline value-type-p))
+(defun values-type-p (x)
+  (or (eq x *wild-type*)
+      (%values-type-p x)))
+
 (defun-cached (make-values-type-cached
                :hash-bits 8
                :hash-function (lambda (req opt rest allowp)
@@ -527,6 +553,10 @@
           (cond
            ((and (not (eq spec u))
                  (info :type :builtin spec)))
+           ((and (consp spec) (symbolp (car spec))
+                 (info :type :builtin (car spec))
+                 (let ((expander (info :type :expander (car spec))))
+                   (and expander (values-specifier-type (funcall expander spec))))))
            ((eq (info :type :kind spec) :instance)
             (find-classoid spec))
            ((typep spec 'classoid)
@@ -580,7 +610,7 @@
   "Takes and expands a type specifier once like MACROEXPAND-1.
 Returns two values: the expansion, and a boolean that is true when
 expansion happened."
-  (declare (type-specifier type-specifier))
+  (declare (type type-specifier type-specifier))
   (declare (ignore env))
   (multiple-value-bind (expander lspec)
       (let ((spec type-specifier))
@@ -595,6 +625,9 @@ expansion happened."
                (values nil nil))
               ((symbolp spec)
                (values (info :type :expander spec) (list spec)))
+              ((and (consp spec) (symbolp (car spec)) (info :type :builtin (car spec)))
+               ;; see above
+               (values nil nil))
               ((and (consp spec) (symbolp (car spec)))
                (values (info :type :expander (car spec)) spec))
               (t nil)))
@@ -607,7 +640,7 @@ expansion happened."
   "Takes and expands a type specifier repeatedly like MACROEXPAND.
 Returns two values: the expansion, and a boolean that is true when
 expansion happened."
-  (declare (type-specifier type-specifier))
+  (declare (type type-specifier type-specifier))
   (multiple-value-bind (expansion flag)
       (typexpand-1 type-specifier env)
     (if flag
@@ -617,7 +650,7 @@ expansion happened."
 (defun typexpand-all (type-specifier &optional env)
   #!+sb-doc
   "Takes and expands a type specifier recursively like MACROEXPAND-ALL."
-  (declare (type-specifier type-specifier))
+  (declare (type type-specifier type-specifier))
   (declare (ignore env))
   ;; I first thought this would not be a good implementation because
   ;; it signals an error on e.g. (CONS 1 2) until I realized that
@@ -678,8 +711,7 @@ Experimental."
 (defun %note-type-defined (name)
   (declare (symbol name))
   (note-name-defined name :type)
-  (when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
-    (values-specifier-type-cache-clear))
+  (values-specifier-type-cache-clear)
   (values))