improved error message in response to 10854

svn: r18807

collects/2htdp/private/syn-aux.ss

@@ -25,7 +25,7 @@
   (define msg (format "not a legal clause in a ~a description" legal))
   (define Spec (append AllSpec PartSpec))
   (define kwds (map (compose (curry datum->syntax stx) car) Spec))
-  (define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg (->kwds-in kwds)))
+  (define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
   (duplicates? tag spec)
   (map (lambda (x) 
          (define kw (car x))
@@ -52,10 +52,17 @@
              (duplicates? (rest lox))))])))
 
 ;; check whether rec? occurs, produce list of keywords 
-(define (clauses-use-kwd stx:list ->rec? legal-clause kwd-in?)
+(define (clauses-use-kwd stx:list ->rec? legal-clause kwds)
+  (define kwd-in? (->kwds-in kwds))
+  (define double (string-append legal-clause ", ~a has been redefined"))
   (map (lambda (stx)
          (syntax-case stx ()
            [(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw #'E) (cons #'kw stx))]
+           [(kw . E)
+            (let ([kw (syntax-e #'kw)])
+              (if (member kw (map syntax-e kwds))
+                  (raise-syntax-error #f (format double kw) stx)
+                  (raise-syntax-error #f legal-clause stx)))]
            [_ (raise-syntax-error #f legal-clause stx)]))
        stx:list))
 

collects/2htdp/tests/clause-once.ss

@@ -1,7 +1,6 @@
 #lang scheme/load
 
 ;; purpose: make sure that each clause exists at most once 
-
 ;; (why am I running this in scheme/load for the namespace in eval)
 
 (error-print-source-location #f)

collects/2htdp/tests/on-tick-defined.ss

@@ -0,0 +1,21 @@
+#lang scheme/load
+
+;; purpose: when on-tick or on-xxx has been redefined, 
+;; --- raise more specific error message
+;; (why am I running this in scheme/load for the namespace in eval)
+
+(error-print-source-location #f)
+
+(define legal "on-tick: not a legal clause in a world description")
+(define double ", on-tick has been redefined")
+
+(with-handlers ((exn:fail:syntax? 
+                 (lambda (x) 
+                   (unless 
+                       (string=? (exn-message x) (string-append legal double))
+                     (raise x)))))
+  (eval '(module a scheme 
+           (require 2htdp/universe)
+           (local ((define (run) (big-bang 0 (on-tick on-tick)))
+                   (define (on-tick t) 0))
+             10))))