fixes 10836

svn: r18700

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

@@ -21,11 +21,12 @@
   
   if anything fails, use the legal keyword to specialize the error message
 |#
-(define (->args stx clauses AllSpec PartSpec ->rec? legal)
+(define (->args tag stx clauses AllSpec PartSpec ->rec? legal)
   (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)))
+  (duplicates? tag spec)
   (map (lambda (x) 
          (define kw (car x))
          (define-values (key coercion)
@@ -36,6 +37,21 @@
          (list key (coercion (cdr x))))
        spec))
 
+;; Symbol [Listof kw] -> true
+;; effect: raise syntax error about duplicated clause 
+(define (duplicates? tag lox)
+  (let duplicates? ([lox lox])
+    (cond
+      [(empty? lox) false]
+      [else
+       (let* ([f (caar lox)]
+              [id (syntax-e f)]
+              [x (memf (lambda (x) (free-identifier=? (car x) f)) (rest lox))])
+         (if x 
+             (raise-syntax-error tag (format "duplicate ~a clause" id) (cdar x))
+             (duplicates? (rest lox))))])))
+
+;; check whether rec? occurs, produce list of keywords 
 (define (clauses-use-kwd stx:list ->rec? legal-clause kwd-in?)
   (map (lambda (stx)
          (syntax-case stx ()

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

@@ -0,0 +1,38 @@
+#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)
+
+(with-handlers ((exn:fail:syntax? 
+                 (lambda (e) 
+                   (define msg (exn-message e))
+                   (unless (string=? msg "big-bang: duplicate on-draw clause")
+                     (raise e)))))
+  (eval '(module a scheme 
+           (require 2htdp/universe)
+           (require 2htdp/image)
+           
+           (define (render1 n) (text (number->string n) 12 "red"))
+           (define (render2 n) (text (number->string n) 10 "blue"))
+           
+           (define (main a)
+             (big-bang 0
+                       (on-draw render1 200 400)
+                       (on-draw render2 400 200)
+                       ; (on-tick sub1)
+                       (on-tick add1))))))
+
+(with-handlers ((exn:fail:syntax? 
+                 (lambda (e) 
+                   (define msg (exn-message e))
+                   (unless (string=? msg "universe: duplicate on-tick clause")
+                     (raise e)))))
+  (eval '(module a scheme 
+           (require 2htdp/universe)
+           
+           (define (main a)
+             (universe 0
+                       (on-tick add1)
+                       (on-tick sub1))))))
+

collects/2htdp/universe.ss

@@ -178,7 +178,7 @@
                    [(V) (set! rec? #'V)]
                    [_ (err '#'record? stx)])))]
             [args 
-             (->args stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
+             (->args 'big-bang stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
        #`(let* ([esp (make-eventspace)]
                 [thd (eventspace-handler-thread esp)])
            (with-handlers ((exn:break? (lambda (x) (break-thread thd))))
@@ -275,7 +275,7 @@
     [(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
     [(universe u bind ...)
      (let*
-         ([args (->args stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
+         ([args (->args 'universe stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
           [domain (map (compose syntax-e car) args)])
        (cond
          [(not (memq 'on-new domain))