fixed 10866 for _first-order_ abuse of clauses

This commit is contained in:
Matthias Felleisen 2010-04-20 18:57:17 -04:00
parent 0e632187a0
commit ae5c682e10
3 changed files with 35 additions and 4 deletions

View File

@ -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)

View File

@ -37,4 +37,23 @@
(raise e)))))
(eval '(module a scheme
(require 2htdp/universe)
(big-bang 0 (on-tick add1) stop-when))))
(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)))))

View File

@ -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))