X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=62aa72ebee8864eed8fc7ac4926c26bbc595d471;hb=1540c1c1d517c58fa9a41629beb65cdce7dfafb6;hp=22ca449cd136dd4305a70abc1dedcbf37e769770;hpb=736f5ba61a8a87df309df7c51b05f0a27f42df4c;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 22ca449..62aa72e 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -244,28 +244,48 @@
 ;;; complain about absence of manifest winnage.
 (declaim (ftype (function (list fixnum fun-type) (values)) check-key-args))
 (defun check-key-args (args pre-key type)
-  (do ((key (nthcdr pre-key args) (cddr key))
-       (n (1+ pre-key) (+ n 2)))
-      ((null key))
-    (declare (fixnum n))
-    (let ((k (car key)))
-      (cond
-       ((not (check-arg-type k (specifier-type 'symbol) n)))
-       ((not (constant-lvar-p k))
-        (note-unwinnage "The ~:R argument (in keyword position) is not a ~
-                         constant."
-                        n))
-       (t
-        (let* ((name (lvar-value k))
-               (info (find name (fun-type-keywords type)
-                           :key #'key-info-name)))
-          (cond ((not info)
-                 (unless (fun-type-allowp type)
-                   (note-lossage "~S is not a known argument keyword."
-                                 name)))
-                (t
-                 (check-arg-type (second key) (key-info-type info)
-                                 (1+ n)))))))))
+  (let (lossages allow-other-keys)
+    (do ((key (nthcdr pre-key args) (cddr key))
+         (n (1+ pre-key) (+ n 2)))
+        ((null key))
+      (declare (fixnum n))
+      (let ((k (first key))
+            (v (second key)))
+        (cond
+          ((not (check-arg-type k (specifier-type 'symbol) n)))
+          ((not (constant-lvar-p k))
+           (note-unwinnage "~@<The ~:R argument (in keyword position) is not ~
+                            a constant, weakening keyword argument ~
+                            checking.~:@>" n)
+           ;; An unknown key may turn out to be :ALLOW-OTHER-KEYS at runtime,
+           ;; so we cannot signal full warnings for keys that look bad.
+           (unless allow-other-keys
+             (setf allow-other-keys :maybe)))
+          (t
+           (let* ((name (lvar-value k))
+                  (info (find name (fun-type-keywords type)
+                              :key #'key-info-name)))
+             (cond ((eq name :allow-other-keys)
+                    (unless allow-other-keys
+                      (if (constant-lvar-p v)
+                          (setf allow-other-keys (if (lvar-value v)
+                                                     :yes
+                                                     :no))
+                          (setf allow-other-keys :maybe))))
+                   ((not info)
+                    (unless (fun-type-allowp type)
+                      (pushnew name lossages :test #'eq)))
+                   (t
+                    (check-arg-type (second key) (key-info-type info)
+                                    (1+ n)))))))))
+    (when (and lossages (member allow-other-keys '(nil :no)))
+      (setf lossages (nreverse lossages))
+      (if (cdr lossages)
+          (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>"
+                        (butlast lossages)
+                        (car (last lossages)))
+          (note-lossage "~S is not a known argument keyword."
+                        (car lossages)))))
   (values))
 
 ;;; Construct a function type from a definition.
@@ -607,7 +627,6 @@
       (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
     (flet ((frob (x y what)
              (unless (eq x y)
-               (break "~S" type)
                (note-lossage
                 "The definition ~:[doesn't have~;has~] ~A, but ~
                  ~A ~:[doesn't~;does~]."
@@ -832,19 +851,39 @@
       (let ((name (key-info-name key)))
         (do ((arg args (cddr arg)))
             ((null arg))
-          (when (eq (lvar-value (first arg)) name)
-            (funcall fun (second arg) (key-info-type key))))))))
+          (let ((keyname (first arg)))
+            (when (and (constant-lvar-p keyname)
+                       (eq (lvar-value keyname) name))
+              (funcall fun (second arg) (key-info-type key)))))))))
 
 ;;; Assert that CALL is to a function of the specified TYPE. It is
 ;;; assumed that the call is legal and has only constants in the
 ;;; keyword positions.
-(defun assert-call-type (call type)
+(defun assert-call-type (call type &optional (trusted t))
   (declare (type combination call) (type fun-type type))
-  (derive-node-type call (fun-type-returns type))
-  (let ((policy (lexenv-policy (node-lexenv call))))
+  (let ((policy (lexenv-policy (node-lexenv call)))
+        (returns (fun-type-returns type)))
+    (if trusted
+        (derive-node-type call returns)
+        (let ((lvar (node-lvar call)))
+          ;; If the value is used in a non-tail position, and the lvar
+          ;; is a single-use, assert the type. Multiple use sites need
+          ;; to be elided because the assertion has to apply to all
+          ;; uses. Tail positions are elided because the assertion
+          ;; would cause us not the be in a tail-position anymore. MV
+          ;; calls are elided because not only are the assertions of
+          ;; less use there, but they can cause the MV call conversion
+          ;; to cause astray.
+          (when (and lvar
+                     (not (return-p (lvar-dest lvar)))
+                     (not (mv-combination-p (lvar-dest lvar)))
+                     (lvar-has-single-use-p lvar))
+            (when (assert-lvar-type lvar returns policy)
+              (reoptimize-lvar lvar)))))
     (map-combination-args-and-types
      (lambda (arg type)
-       (assert-lvar-type arg type policy))
+       (when (assert-lvar-type arg type policy)
+         (unless trusted (reoptimize-lvar arg))))
      call))
   (values))
 
@@ -853,32 +892,95 @@
   (declare (type lvar tag))
   (let ((ctype (lvar-type tag)))
     (when (csubtypep ctype (specifier-type '(or number character)))
-      (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
-                            tends to be unportable because THROW and CATCH ~
-                            use EQ comparison)~@:>"
-                           (lvar-source tag)
-                           (type-specifier (lvar-type tag))))))
-
-(defun %compile-time-type-error (values atype dtype)
+      (let ((sources (lvar-all-sources tag)))
+        (if (singleton-p sources)
+            (compiler-style-warn
+             "~@<using ~S of type ~S as a catch tag (which ~
+                 tends to be unportable because THROW and CATCH ~
+                 use EQ comparison)~@:>"
+             (first sources)
+             (type-specifier (lvar-type tag)))
+            (compiler-style-warn
+             "~@<using ~{~S~^~#[~; or ~:;, ~]~} in ~S of type ~S ~
+                 as a catch tag (which tends to be unportable ~
+                 because THROW and CATCH use EQ comparison)~@:>"
+             (rest sources) (first sources)
+             (type-specifier (lvar-type tag))))))))
+
+(defun %compile-time-type-error (values atype dtype context)
   (declare (ignore dtype))
-  (if (and (consp atype)
-           (eq (car atype) 'values))
-      (error 'values-type-error :datum values :expected-type atype)
-      (error 'type-error :datum (car values) :expected-type atype)))
+  (destructuring-bind (form . detail) context
+    (if (and (consp atype) (eq (car atype) 'values))
+        (if (singleton-p detail)
+            (error 'simple-type-error
+                   :datum (car values)
+                   :expected-type atype
+                   :format-control
+                   "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in ~2I~_~S ~I~_is ~
+                   not of type ~2I~_~S.~:>"
+                   :format-arguments (list values
+                                           (first detail) form
+                                           atype))
+            (error 'simple-type-error
+                   :datum (car values)
+                   :expected-type atype
+                   :format-control
+                   "~@<Value set ~2I~_[~{~S~^ ~}] ~
+                   ~I~_from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
+                   ~I~_of ~2I~_~S ~I~_in ~2I~_~S ~I~_is not of type ~2I~_~S.~:>"
+                   :format-arguments (list values
+                                           (rest detail) (first detail)
+                                           form
+                                           atype)))
+        (if (singleton-p detail)
+            (error 'simple-type-error
+                   :datum (car values)
+                   :expected-type atype
+                   :format-control "~@<Value of ~S in ~2I~_~S ~I~_is ~2I~_~S, ~
+                                ~I~_not a ~2I~_~S.~:@>"
+                   :format-arguments (list (car detail) form
+                                           (car values)
+                                           atype))
+            (error 'simple-type-error
+                   :datum (car values)
+                   :expected-type atype
+                   :format-control "~@<Value from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
+                                   ~I~_of ~2I~_~S ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~
+                                   ~I~_not a ~2I~_~S.~:@>"
+                   :format-arguments (list (rest detail) (first detail) form
+                                           (car values)
+                                           atype))))))
 
 (defoptimizer (%compile-time-type-error ir2-convert)
-    ((objects atype dtype) node block)
+    ((objects atype dtype context) node block)
   (let ((*compiler-error-context* node))
     (setf (node-source-path node)
           (cdr (node-source-path node)))
-    (destructuring-bind (values atype dtype)
+    (destructuring-bind (values atype dtype context)
         (basic-combination-args node)
       (declare (ignore values))
       (let ((atype (lvar-value atype))
-            (dtype (lvar-value dtype)))
-      (unless (eq atype nil)
-        (warn 'type-warning
-              :format-control
-              "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
-              :format-arguments (list atype dtype)))))
+            (dtype (lvar-value dtype))
+            (detail (cdr (lvar-value context))))
+        (unless (eq atype nil)
+          (if (singleton-p detail)
+              (let ((detail (first detail)))
+                (if (constantp detail)
+                    (warn 'type-warning
+                          :format-control
+                          "~@<Constant ~2I~_~S ~Iconflicts with its ~
+                              asserted type ~2I~_~S.~@:>"
+                          :format-arguments (list (eval detail) atype))
+                    (warn 'type-warning
+                          :format-control
+                          "~@<Derived type of ~S is ~2I~_~S, ~
+                              ~I~_conflicting with ~
+                              its asserted type ~2I~_~S.~@:>"
+                          :format-arguments (list detail dtype atype))))
+              (warn 'type-warning
+                    :format-control
+                    "~@<Derived type of ~2I~_~{~S~^~#[~; and ~:;, ~]~} ~
+                     ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~I~_conflicting with ~
+                     their asserted type ~2I~_~S.~@:>"
+                    :format-arguments (list (rest detail) (first detail) dtype atype))))))
     (ir2-convert-full-call node block)))