>From cd1e7a517ad7c85f0ef960b778a028ad44bb1613 Mon Sep 17 00:00:00 2001
From: LemonBoy <address@hidden>
Date: Mon, 15 May 2017 20:14:42 +0200
Subject: [PATCH 1/2] Use the raw variable name in env lookups and errors

The current-environment and the macro-environment are alists whose keys
are the raw variable names.

Also, reword the error messages a little and add some unit tests.

Signed-off-by: Evan Hanson <address@hidden>
---
 core.scm                | 34 ++++++++++++++++------------------
 distribution/manifest   |  2 ++
 tests/messages-test.scm | 13 +++++++++++++
 tests/messages.expected |  6 ++++++
 tests/runtests.bat      |  6 ++++++
 tests/runtests.sh       |  4 ++++
 tests/scrutiny.expected |  2 +-
 7 files changed, 48 insertions(+), 19 deletions(-)
 create mode 100644 tests/messages-test.scm
 create mode 100644 tests/messages.expected

diff --git a/core.scm b/core.scm
index 4d05fd8e..7c8a2f45 100644
--- a/core.scm
+++ b/core.scm
@@ -1108,24 +1108,22 @@
 				     (set! val
 				       `(let ((,var ,val))
 					  (##core#debug-event "C_DEBUG_GLOBAL_ASSIGN" ',var)
-					  ,var))))
-				 (cond ((##sys#macro? var)
-					(warning
-					 (sprintf "~aassigned global variable `~S' is syntax"
-					   (if ln (sprintf "(~a) - " ln) "")
-					   var))
-					(when undefine-shadowed-macros (##sys#undefine-macro! var)))
-				       ((and ##sys#notices-enabled
-					     (assq var (##sys#current-environment)))
-					(##sys#notice
-					 (sprintf "~aassignment to imported value binding `~S'"
-					   (if ln (sprintf "(~a) - " ln) "")
-					   var))))
-				 (when (keyword? var)
-				   (warning
-				    (sprintf "~aassignment to keyword `~S'"
-				      (if ln (sprintf "(~a) - " ln) "")
-				      var)))
+					  ,var)))
+				   ;; We use `var0` instead of `var` because the {macro,current}-environment
+				   ;; are keyed by the raw and unqualified name
+				   (cond ((##sys#macro? var0 se)
+					  (warning
+					   (sprintf "~aassignment to syntax `~S'"
+					    (if ln (sprintf "(~a) - " ln) "") var0))
+					  (when undefine-shadowed-macros (##sys#undefine-macro! var0)))
+					 ((assq var0 (##sys#current-environment))
+					  (warning
+					   (sprintf "~aassignment to imported value binding `~S'"
+					    (if ln (sprintf "(~a) - " ln) "") var0)))
+					 ((keyword? var0)
+					  (warning
+					   (sprintf "~aassignment to keyword `~S'"
+					    (if ln (sprintf "(~a) - " ln) "") var0)))))
 				 `(set! ,var ,(walk val e se var0 (memq var e) h ln #f))))))
 
 			((##core#debug-event)
diff --git a/distribution/manifest b/distribution/manifest
index 69b81782..ced18000 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -234,6 +234,8 @@ tests/reverser/tags/1.1/reverser.scm
 tests/rev-app.scm
 tests/user-pass-tests.scm
 tests/version-tests.scm
+tests/messages-test.scm
+tests/messages.expected
 tweaks.scm
 Makefile
 Makefile.android
diff --git a/tests/messages-test.scm b/tests/messages-test.scm
new file mode 100644
index 00000000..e41e82fc
--- /dev/null
+++ b/tests/messages-test.scm
@@ -0,0 +1,13 @@
+(module boo *
+  (import scheme)
+  (define var 42))
+
+(module foo *
+  (import scheme chicken boo)
+  (define-syntax bar
+    (syntax-rules ()))
+  (set! bar 42) ;; set!-ing a macro
+  (set! var 42) ;; set!-ing an imported identifier
+  (let ((var #f)) (set! var 42)) ;; set!-ing a local variable
+  (letrec-values ((bar (values)))) ;; shadow a syntax item
+  (let-syntax ((m (syntax-rules ()))) (set! m 42)))
diff --git a/tests/messages.expected b/tests/messages.expected
new file mode 100644
index 00000000..d9213926
--- /dev/null
+++ b/tests/messages.expected
@@ -0,0 +1,6 @@
+
+Warning: (messages-test.scm:9) - assignment to syntax `bar'
+
+Warning: (messages-test.scm:10) - assignment to imported value binding `var'
+
+Warning: (messages-test.scm:13) - assignment to syntax `m'
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 6e1b9928..e3e016db 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -42,6 +42,12 @@ if errorlevel 1 exit /b 1
 a.out
 if errorlevel 1 exit /b 1
 
+echo ======================================== compiler message tests ...
+%compile% -analyze-only messages-test.scm 2>messages.out
+if errorlevel 1 exit /b 1
+fc /lb%FCBUFSIZE% /w messages.expected messages.out
+if errorlevel 1 exit /b 1
+
 echo ======================================== optimizer tests  ...
 %compile% clustering-tests.scm -clustering
 if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 16fcb97f..af45d52f 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -70,6 +70,10 @@ echo "======================================== compiler inlining tests  ..."
 $compile inlining-tests.scm -optimize-level 3
 ./a.out
 
+echo "======================================== compiler message tests ..."
+$compile -analyze-only messages-test.scm 2>messages.out
+diff $DIFF_OPTS messages.expected messages.out
+
 echo "======================================== optimizer tests  ..."
 $compile clustering-tests.scm -clustering
 ./a.out
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 581aa45b..0641540f 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -1,5 +1,5 @@
 
-Note: (scrutiny-tests.scm:31) - assignment to imported value binding `car'
+Warning: (scrutiny-tests.scm:31) - assignment to imported value binding `car'
 
 Note: in local procedure `c',
   in local procedure `b',
-- 
2.11.0