fixed 10866 for _first-order_ abuse of clauses
This commit is contained in:
parent
0e632187a0
commit
ae5c682e10
|
@ -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)
|
||||
|
|
|
@ -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)))))
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in New Issue
Block a user