diff --git a/collects/2htdp/private/syn-aux.ss b/collects/2htdp/private/syn-aux.ss index 30e3a761f4..23e930a0e9 100644 --- a/collects/2htdp/private/syn-aux.ss +++ b/collects/2htdp/private/syn-aux.ss @@ -25,7 +25,7 @@ (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))) + (define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds)) (duplicates? tag spec) (map (lambda (x) (define kw (car x)) @@ -52,10 +52,17 @@ (duplicates? (rest lox))))]))) ;; check whether rec? occurs, produce list of keywords -(define (clauses-use-kwd stx:list ->rec? legal-clause kwd-in?) +(define (clauses-use-kwd stx:list ->rec? legal-clause kwds) + (define kwd-in? (->kwds-in kwds)) + (define double (string-append legal-clause ", ~a has been redefined")) (map (lambda (stx) (syntax-case stx () [(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw #'E) (cons #'kw stx))] + [(kw . E) + (let ([kw (syntax-e #'kw)]) + (if (member kw (map syntax-e kwds)) + (raise-syntax-error #f (format double kw) stx) + (raise-syntax-error #f legal-clause stx)))] [_ (raise-syntax-error #f legal-clause stx)])) stx:list)) diff --git a/collects/2htdp/tests/clause-once.ss b/collects/2htdp/tests/clause-once.ss index 70482fecbd..b82257463d 100644 --- a/collects/2htdp/tests/clause-once.ss +++ b/collects/2htdp/tests/clause-once.ss @@ -1,7 +1,6 @@ #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) (error-print-source-location #f) diff --git a/collects/2htdp/tests/on-tick-defined.ss b/collects/2htdp/tests/on-tick-defined.ss new file mode 100644 index 0000000000..5142ecb13a --- /dev/null +++ b/collects/2htdp/tests/on-tick-defined.ss @@ -0,0 +1,21 @@ +#lang scheme/load + +;; purpose: when on-tick or on-xxx has been redefined, +;; --- raise more specific error message +;; (why am I running this in scheme/load for the namespace in eval) + +(error-print-source-location #f) + +(define legal "on-tick: not a legal clause in a world description") +(define double ", on-tick has been redefined") + +(with-handlers ((exn:fail:syntax? + (lambda (x) + (unless + (string=? (exn-message x) (string-append legal double)) + (raise x))))) + (eval '(module a scheme + (require 2htdp/universe) + (local ((define (run) (big-bang 0 (on-tick on-tick))) + (define (on-tick t) 0)) + 10))))