From ae5c682e1050a2f8e1f7c3bc1de976aa8c4b8465 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Tue, 20 Apr 2010 18:57:17 -0400
Subject: [PATCH] fixed 10866 for _first-order_ abuse of clauses

---
 collects/2htdp/private/syn-aux.ss       | 14 +++++++++++++-
 collects/2htdp/tests/on-tick-defined.ss | 21 ++++++++++++++++++++-
 collects/2htdp/universe.ss              |  4 ++--
 3 files changed, 35 insertions(+), 4 deletions(-)

diff --git a/collects/2htdp/private/syn-aux.ss b/collects/2htdp/private/syn-aux.ss
index b72537a49b..ef78916ece 100644
--- a/collects/2htdp/private/syn-aux.ss
+++ b/collects/2htdp/private/syn-aux.ss
@@ -53,6 +53,8 @@
   transform the clauses into the initial arguments specification 
   for a new expression that instantiates the appropriate class
   
+  ensure that the initial state (state0) is not in the shape of a clause
+
   ensure that all clauses mention only keywords specified in AllSpec or PartSpec
   move the contracts from AppSpecl and PartSpec to the clauses 
   
@@ -60,12 +62,13 @@
   
   if anything fails, use the legal keyword to specialize the error message
 |#
-(define (->args tag stx clauses AllSpec PartSpec ->rec? legal)
+(define (->args tag stx state0 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))
   (duplicates? tag spec)
+  (not-a-clause tag stx state0 kwds)
   (map (lambda (x) 
          (define kw (car x))
          (define-values (key coercion)
@@ -78,6 +81,15 @@
          (list key (coercion (cdr x))))
        spec))
 
+;; Symbol Syntax Syntax [Listof Kw] -> true
+;; effect: if state0 looks like a clause, raise special error 
+(define (not-a-clause tag stx state0 kwds)
+  (syntax-case state0 ()
+    [(kw . E) 
+     ((->kwds-in kwds) #'kw) 
+     (raise-syntax-error tag "missing initial state" stx)]
+    [_ #t]))
+
 ;; Symbol [Listof kw] -> true
 ;; effect: raise syntax error about duplicated clause 
 (define (duplicates? tag lox)
diff --git a/collects/2htdp/tests/on-tick-defined.ss b/collects/2htdp/tests/on-tick-defined.ss
index f9a3efb3d3..2946379b5f 100644
--- a/collects/2htdp/tests/on-tick-defined.ss
+++ b/collects/2htdp/tests/on-tick-defined.ss
@@ -37,4 +37,23 @@
                      (raise e)))))
   (eval '(module a scheme
            (require 2htdp/universe)
-           (big-bang 0 (on-tick add1) stop-when))))
\ No newline at end of file
+           (big-bang 0 (on-tick add1) stop-when))))
+
+;; -----------------------------------------------------------------------------
+;; purpose: catch illegal big-bang use w/o world expression
+
+(with-handlers ((exn:fail:syntax? 
+                 (lambda (x) 
+                   (unless (string=? (exn-message x) "big-bang: missing initial state")
+                     (raise x)))))
+  (eval '(module a scheme 
+           (require 2htdp/universe)
+	   (big-bang (on-key add1)))))
+
+(with-handlers ((exn:fail:syntax? 
+                 (lambda (x) 
+                   (unless (string=? (exn-message x) "universe: missing initial state")
+                     (raise x)))))
+  (eval '(module a scheme 
+           (require 2htdp/universe)
+	   (universe (on-msg sub1) (on-new add1)))))
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index 31caf74d13..4e71f1a4c2 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -179,7 +179,7 @@
                    [(V) (set! rec? #'V)]
                    [_ (err '#'record? stx)])))]
             [args 
-             (->args 'big-bang stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
+             (->args 'big-bang stx (syntax w) (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
        #`(let* ([esp (make-eventspace)]
                 [thd (eventspace-handler-thread esp)])
            (with-handlers ((exn:break? (lambda (x) (break-thread thd))))
@@ -276,7 +276,7 @@
     [(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
     [(universe u bind ...)
      (let*
-         ([args (->args 'universe stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
+         ([args (->args 'universe stx (syntax u) (syntax (bind ...)) AllSpec UniSpec void "universe")]
           [domain (map (compose syntax-e car) args)])
        (cond
          [(not (memq 'on-new domain))