Warn when wrapping constants with THE of multiple value types

[sbcl.git] / src / compiler / ir1-translators.lisp

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index f79a734..7bd2bfb 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -42,7 +42,10 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL."
     ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
     ;; order of the following two forms is important
     (setf (lvar-dest pred-lvar) node)
-    (ir1-convert start pred-ctran pred-lvar test)
+    (multiple-value-bind (context count) (possible-rest-arg-context test)
+      (if context
+          (ir1-convert start pred-ctran pred-lvar `(%rest-true ,test ,context ,count))
+          (ir1-convert start pred-ctran pred-lvar test)))
     (link-node-to-previous-ctran node pred-ctran)
 
     (let ((start-block (ctran-block pred-ctran)))
@@ -198,11 +201,11 @@ extent of the block."
   #!+sb-doc
   "TAGBODY {tag | statement}*
 
-Define tags for use with GO. The STATEMENTS are evaluated in order ,skipping
+Define tags for use with GO. The STATEMENTS are evaluated in order, skipping
 TAGS, and NIL is returned. If a statement contains a GO to a defined TAG
 within the lexical scope of the form, then control is transferred to the next
-statement following that tag. A TAG must an integer or a symbol. A STATEMENT
-must be a list. Other objects are illegal within the body."
+statement following that tag. A TAG must be an integer or a symbol. A
+STATEMENT must be a list. Other objects are illegal within the body."
   (start-block start)
   (ctran-starts-block next)
   (let* ((dummy (make-ctran))
@@ -352,7 +355,7 @@ Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL,
   "MACROLET ({(name lambda-list form*)}*) body-form*
 
 Evaluate the BODY-FORMS in an environment with the specified local macros
-defined. Name is the local macro name, LAMBDA-LIST is a DEFMACRO style
+defined. NAME is the local macro name, LAMBDA-LIST is a DEFMACRO style
 destructuring lambda list, and the FORMS evaluate to the expansion."
   (funcall-in-macrolet-lexenv
    definitions
@@ -476,15 +479,37 @@ body, references to a NAME will effectively be replaced with the EXPANSION."
 Return VALUE without evaluating it."
   (reference-constant start next result thing))
 \f
+(defun name-context ()
+  ;; Name of the outermost non-NIL BLOCK, or the source namestring
+  ;; of the source file.
+  (let ((context
+          (or (car (find-if (lambda (b)
+                              (let ((name (pop b)))
+                                (and name
+                                     ;; KLUDGE: High debug adds this block on
+                                     ;; some platforms.
+                                     #!-unwind-to-frame-and-call-vop
+                                     (neq 'return-value-tag name)
+                                     ;; KLUDGE: CATCH produces blocks whose
+                                     ;; cleanup is :CATCH.
+                                     (neq :catch (cleanup-kind (entry-cleanup (pop b)))))))
+                            (lexenv-blocks *lexenv*) :from-end t))
+              *source-namestring*
+              (let ((p (or *compile-file-truename* *load-truename*)))
+                (when p (namestring p))))))
+    (when context
+      (list :in context))))
+
 ;;;; FUNCTION and NAMED-LAMBDA
 (defun name-lambdalike (thing)
   (case (car thing)
     ((named-lambda)
      (or (second thing)
-         `(lambda ,(third thing))))
+         `(lambda ,(third thing) ,(name-context))))
     ((lambda)
-     `(lambda ,(second thing)))
+     `(lambda ,(second thing) ,@(name-context)))
     ((lambda-with-lexenv)
+     ;; FIXME: Get the original DEFUN name here.
      `(lambda ,(fifth thing)))
     (otherwise
      (compiler-error "Not a valid lambda expression:~%  ~S"
@@ -579,7 +604,7 @@ be a lambda expression."
         (cond (cname
                `(global-function ,cname))
               (give-up
-               (give-up-ir1-transform give-up))
+               (give-up-ir1-transform "not known to be a function"))
               (t
                `(%coerce-callable-to-fun ,lvar-name))))))
 \f
@@ -622,8 +647,9 @@ be a lambda expression."
 (define-source-transform funcall (function &rest args)
   `(%funcall ,(ensure-source-fun-form function) ,@args))
 
-(deftransform %coerce-callable-to-fun ((thing) * *)
-  (ensure-lvar-fun-form thing 'thing "optimize away possible call to FDEFINITION at runtime"))
+(deftransform %coerce-callable-to-fun ((thing) * * :node node)
+  "optimize away possible call to FDEFINITION at runtime"
+  (ensure-lvar-fun-form thing 'thing t))
 
 (define-source-transform %coerce-callable-to-fun (thing)
   (ensure-source-fun-form thing t))
@@ -814,10 +840,11 @@ lexically apparent function definition in the enclosing environment."
     (multiple-value-bind (names defs)
         (extract-flet-vars definitions 'flet)
       (let ((fvars (mapcar (lambda (n d)
-                             (ir1-convert-lambda d
-                                                 :source-name n
-                                                 :maybe-add-debug-catch t
-                                                 :debug-name (debug-name 'flet n)))
+                             (ir1-convert-lambda
+                              d :source-name n
+                                :maybe-add-debug-catch t
+                                :debug-name
+                                (debug-name 'flet n t)))
                            names defs)))
         (processing-decls (decls nil fvars next result)
           (let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
@@ -852,7 +879,7 @@ other."
                           (ir1-convert-lambda def
                                               :source-name name
                                               :maybe-add-debug-catch t
-                                              :debug-name (debug-name 'labels name)))
+                                              :debug-name (debug-name 'labels name t)))
                         names defs))))
 
         ;; Modify all the references to the dummy function leaves so
@@ -885,6 +912,8 @@ other."
                     (values-subtypep (make-single-value-type (leaf-type value))
                                      type))
                (and (sb!xc:constantp value)
+                    (or (not (values-type-p type))
+                        (values-type-may-be-single-value-p type))
                     (ctypep (constant-form-value value)
                             (single-value-type type))))
            (ir1-convert start next result value))