From e0679456e3c3760c950e1fd3b7ec2843a821c1f9 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Tue, 21 Oct 2014 11:04:55 -0400
Subject: [PATCH] make to-draw (alt-kw) error messages more correct, see test
 for flaws; closes PR 14781

please merge with 6.1.1

(cherry picked from commit 4624a99420c07bb6bfff63a6cc5fd7cc02499c95)
---
 .../2htdp/private/define-keywords.rkt         | 12 ++++++++++-
 .../htdp-test/2htdp/tests/error-to-draw.rkt   | 21 +++++++++++++++++++
 pkgs/htdp-pkgs/htdp-test/2htdp/xtest          |  1 +
 3 files changed, 33 insertions(+), 1 deletion(-)
 create mode 100644 pkgs/htdp-pkgs/htdp-test/2htdp/tests/error-to-draw.rkt

diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/define-keywords.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/define-keywords.rkt
index c0cdd4fa36..1dffe64fd8 100644
--- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/define-keywords.rkt
+++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/define-keywords.rkt
@@ -28,7 +28,10 @@
            (provide (rename-out (kw  kw-alt) ...))
            (provide kw ...) 
            (define-syntaxes (kw ...)
-             (values (lambda (x) (raise-syntax-error 'kw "used out of context" x)) ...))
+             (values
+              (lambda (x)
+                (raise-syntax-error (if (equal? 'kw x) 'kw 'kw-alt) "used out of context" x))
+              ...))
            
            ;; a macro for creating functions that instantiate the proper object
            ;; (define-create para ...) :: additional parameters for the new func
@@ -46,3 +49,10 @@
                         (lambda #,(args para*)
                           (lambda ()
                             (new % #,@(body para*)))))))]))))]))
+
+#;
+(define-keywords 
+  new-world
+  '()
+  define-create
+  (on-draw to-draw DEFAULT #'#f values))
\ No newline at end of file
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/error-to-draw.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/error-to-draw.rkt
new file mode 100644
index 0000000000..ee3dd5a94b
--- /dev/null
+++ b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/error-to-draw.rkt
@@ -0,0 +1,21 @@
+#lang racket 
+
+;; fixes PR 14781
+
+(define-namespace-anchor an)
+
+(with-handlers ([exn:fail:syntax? 
+                 ;; succeed quietly if 
+                 (lambda (x)
+                   (unless (regexp-match? "^to-draw" (exn-message x))
+                     (error 'to-draw "got wrong error message: ~e" (exn-message x))))])
+  (eval
+   '(module test racket
+      (require 2htdp/universe)
+      to-draw)
+   (namespace-anchor->namespace an))
+  (error 'to-draw "got no error message"))
+
+;; known problem with the solution: 
+;;    (to-draw on-draw)
+;; will signal the wrong kind of error 
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/xtest b/pkgs/htdp-pkgs/htdp-test/2htdp/xtest
index cd015978ee..3b8eba60a2 100755
--- a/pkgs/htdp-pkgs/htdp-test/2htdp/xtest
+++ b/pkgs/htdp-pkgs/htdp-test/2htdp/xtest
@@ -18,6 +18,7 @@ run run-movie.rkt
 run bad-draw.rkt
 run error-in-tick.rkt
 run error-in-draw.rkt
+run error-to-draw.rkt
 run -t batch-io.rkt
 run -t batch-io2.rkt
 run -t batch-io3.rkt