From 00c8a934b9f53a66b4e7248a93f21d9fb2517361 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Sat, 21 Jan 2017 14:10:24 +0300
Subject: [PATCH] Provide context for type errors during variable binding.

(funcall (lambda (y) (declare (double-float y)) y) 10)
=>
The value
  10
is not of type
  DOUBLE-FLOAT
when binding Y
---
 src/code/condition.lisp       | 15 ++++++++++-----
 src/code/defstruct.lisp       |  4 ++--
 src/compiler/ir1opt.lisp      |  5 +++--
 src/compiler/ir1util.lisp     |  4 ++--
 src/compiler/locall.lisp      |  3 ++-
 tests/macroexpand.impure.lisp |  2 +-
 6 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index ef56bc95f..dc50debef 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -515,11 +515,16 @@
 (define-condition storage-condition (serious-condition) ())
 
 (defun decode-type-error-context (context)
-  (typecase context
-    ((cons (eql :struct))
-     (format nil "when setting slot ~s of structure ~s"
-             (third context) (second context)))
-    (t context)))
+  (if (consp context)
+      (case (car context)
+        (:struct
+         (format nil "when setting slot ~s of structure ~s"
+                 (cddr context) (cadr context)))
+        (:bind
+         (format nil "when binding ~s"
+                 (cdr context)))
+        (t context))
+      context))
 
 (define-condition type-error (error)
   ((datum :reader type-error-datum :initarg :datum)
diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index a6a3c21a7..de3a9ab97 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -1047,7 +1047,7 @@ unless :NAMED is also specified.")))
                        (if (eq type-spec t)
                            newval
                            `(the-context ,type-spec
-                                         (:struct ,(dd-name dd) ,(dsd-name dsd))
+                                         (:struct ,(dd-name dd) . ,(dsd-name dsd))
                                          ,newval))))
                 (ecase function
                   (:setf
@@ -1630,7 +1630,7 @@ or they must be declared locally notinline at each call site.~@:>"
                                 (if (eq type t)
                                     var
                                     `(the-context ,type
-                                                  (:struct ,(dd-name dd) ,(dsd-name dsd))
+                                                  (:struct ,(dd-name dd) . ,(dsd-name dsd))
                                                   ,var))))
                             (dd-slots dd) lambda-list))))))
   (destructuring-bind (llks &optional req opt rest keys aux) args
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index bbd613594..132b3da0f 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -313,13 +313,14 @@
 ;;; splitting off DEST a new CAST node; old LVAR will deliver values
 ;;; to CAST. If we improve the assertion, we set TYPE-CHECK and
 ;;; TYPE-ASSERTED to guarantee that the new assertion will be checked.
-(defun assert-lvar-type (lvar type policy)
+(defun assert-lvar-type (lvar type policy &optional context)
   (declare (type lvar lvar) (type ctype type))
   (unless (values-subtypep (lvar-derived-type lvar) type)
     (let ((internal-lvar (make-lvar))
           (dest (lvar-dest lvar)))
       (substitute-lvar internal-lvar lvar)
-      (let ((cast (insert-cast-before dest lvar type policy)))
+      (let ((cast (insert-cast-before dest lvar type policy
+                                      context)))
         (use-lvar cast internal-lvar)
         t))))
 
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 8956e7c22..78765c9ed 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -406,11 +406,11 @@
            (unlink-node node))))
 
 ;;; Make a CAST and insert it into IR1 before node NEXT.
-(defun insert-cast-before (next lvar type policy)
+(defun insert-cast-before (next lvar type policy &optional context)
   (declare (type node next) (type lvar lvar) (type ctype type))
   (with-ir1-environment-from-node next
     (let* ((ctran (node-prev next))
-           (cast (make-cast lvar type policy))
+           (cast (make-cast lvar type policy context))
            (internal-ctran (make-ctran)))
       (setf (ctran-next ctran) cast
             (node-prev cast) ctran)
diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index b58d35b92..fa6419f20 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -37,7 +37,8 @@
   (loop with policy = (lexenv-policy (node-lexenv call))
         for args on (basic-combination-args call)
         and var in (lambda-vars fun)
-        do (assert-lvar-type (car args) (leaf-type var) policy)
+        do (assert-lvar-type (car args) (leaf-type var) policy
+                             (cons :bind (lambda-var-%source-name var)))
         do (unless (leaf-refs var)
              (flush-dest (car args))
              (setf (car args) nil)))
diff --git a/tests/macroexpand.impure.lisp b/tests/macroexpand.impure.lisp
index ee21a4029..aed94fb02 100644
--- a/tests/macroexpand.impure.lisp
+++ b/tests/macroexpand.impure.lisp
@@ -225,7 +225,7 @@
   (assert (equal (macroexpand-1 '(setf (foo-a x) 3))
                  `(sb-kernel:%instance-set (the foo x)
                                            ,sb-vm:instance-data-start
-                                           (sb-kernel:the-context fixnum (:struct foo a) 3))))
+                                           (sb-kernel:the-context fixnum (:struct foo . a) 3))))
 
   ;; Lexical definition of (SETF FOO-A) inhibits source-transform.
   ;; This is not required behavior - SETF of structure slots
-- 
2.11.4.GIT