From 3f20bc5eb62f0a10734cc18ca43e4d82ba44e628 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Wed, 31 Mar 2010 21:59:07 +0000
Subject: [PATCH] fixes 10836

svn: r18700
---
 collects/2htdp/private/syn-aux.ss   | 18 +++++++++++++-
 collects/2htdp/tests/clause-once.ss | 38 +++++++++++++++++++++++++++++
 collects/2htdp/universe.ss          |  4 +--
 3 files changed, 57 insertions(+), 3 deletions(-)
 create mode 100644 collects/2htdp/tests/clause-once.ss

diff --git a/collects/2htdp/private/syn-aux.ss b/collects/2htdp/private/syn-aux.ss
index dfaaffc22e..30e3a761f4 100644
--- a/collects/2htdp/private/syn-aux.ss
+++ b/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 ()
diff --git a/collects/2htdp/tests/clause-once.ss b/collects/2htdp/tests/clause-once.ss
new file mode 100644
index 0000000000..0d81a26068
--- /dev/null
+++ b/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))))))
+
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index 4145ed508c..4d4f575a5c 100644
--- a/collects/2htdp/universe.ss
+++ b/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))