suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

teaching-langauge error message improvements

Browse Source 
svn: r1197
This commit is contained in:
Matthew Flatt 2005-11-01 20:13:10 +00:00
parent 28afce07b0
commit 81dc642c4e
5 changed files with 1034 additions and 870 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/lang/private/contracts/contracts-module-begin.ss
View File

@ -2,13 +2,16 @@
(require "contracts.ss") (require "contracts.ss")
(require-for-syntax (lib "list.ss")) (require-for-syntax (lib "list.ss")
(lib "boundmap.ss" "syntax"))
(provide beginner-module-begin intermediate-module-begin advanced-module-begin) (provide beginner-module-begin intermediate-module-begin advanced-module-begin)
(define-syntaxes (beginner-module-begin intermediate-module-begin advanced-module-begin) (define-syntaxes (beginner-module-begin intermediate-module-begin advanced-module-begin
beginner-continue intermediate-continue advanced-continue)
(let () (let ()
(define (parse-contracts language-level-contract language-level-define-data) (define (parse-contracts language-level-contract language-level-define-data
module-begin-continue-id)
;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to ;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to
;; a contract declaration. Syntax: (contract function-name (domain ... -> range)) ;; a contract declaration. Syntax: (contract function-name (domain ... -> range))
(define extract-contracts (define extract-contracts
@ -138,8 +141,8 @@
(syntax (begin )) (syntax (begin ))
(raise-syntax-error 'contracts "this contract has no corresponding def" (car cnt-list)))] (raise-syntax-error 'contracts "this contract has no corresponding def" (car cnt-list)))]
[else [else
; (let ([expanded (local-expand (car exprs) (syntax-local-context) local-expand-stop-list)]) (let ([expanded (car exprs)])
(let ([expanded (local-expand (car exprs) 'module local-expand-stop-list)])
(syntax-case expanded (begin define-values define-data) (syntax-case expanded (begin define-values define-data)
[(define-values (func) e1 ...) [(define-values (func) e1 ...)
(contract-defined? cnt-list expanded) (contract-defined? cnt-list expanded)
@ -156,15 +159,13 @@
(#,ll-define-data name c1 c2 ...) (#,ll-define-data name c1 c2 ...)
#,(loop cnt-list (cdr exprs))))] #,(loop cnt-list (cdr exprs))))]
[(begin e1 ...) [(begin e1 ...)
(loop cnt-list (append (syntax-e (syntax (e1 ...)))(cdr exprs)))] (loop cnt-list (append (syntax-e (syntax (e1 ...))) (cdr exprs)))]
[_else [_else
(quasisyntax/loc (car exprs) (quasisyntax/loc (car exprs)
(begin (begin
#,(car exprs) #,(car exprs)
#,(loop cnt-list (cdr exprs))))]))]))) #,(loop cnt-list (cdr exprs))))]))])))
;; contract transformations! ;; contract transformations!
;; this is the macro, abstracted over which language level we are using. ;; this is the macro, abstracted over which language level we are using.
;; parse-contracts : ;; parse-contracts :
@ -175,25 +176,75 @@
;; where ll-contract is either beginner-contract, intermediate-contract, or advanced-contract ;; where ll-contract is either beginner-contract, intermediate-contract, or advanced-contract
;; and (define-data name ....) to (lang-lvl-define-data name ...) ;; and (define-data name ....) to (lang-lvl-define-data name ...)
(values
;; module-begin (for a specific language:)
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ e1 ...) [(_ e1 ...)
(let* ([top-level (syntax-e (syntax (e1 ...)))] ;; module-begin-continue takes a sequence of expanded
;; exprs and a sequence of to-expand exprs; that way,
;; the module-expansion machinery can be used to handle
;; requires, etc.:
#`(#%plain-module-begin
(#,module-begin-continue-id () (e1 ...) ()))]))
;; module-continue (for a specific language:)
(lambda (stx)
(syntax-case stx ()
[(_ (e1 ...) () (defined-id ...))
;; Local-expanded all body elements, lifted out requires, etc.
;; Now process the result.
(begin
;; The expansion for contracts breaks the way that beginner-define, etc.,
;; check for duplicate definitions, so we have to re-check here.
;; A better strategy might be to turn every define into a define-syntax
;; to redirect the binding, and then the identifier-binding check in
;; beginner-define, etc. will work.
(let ([defined-ids (make-bound-identifier-mapping)])
(for-each (lambda (id)
(when (bound-identifier-mapping-get defined-ids id (lambda () #f))
(raise-syntax-error
#f
"this name was defined previously and cannot be re-defined"
id))
(bound-identifier-mapping-put! defined-ids id #t))
(reverse (syntax->list #'(defined-id ...)))))
;; Now handle contracts:
(let* ([top-level (reverse (syntax->list (syntax (e1 ...))))]
[cnt-list (extract-contracts top-level)] [cnt-list (extract-contracts top-level)]
[expr-list (extract-not-contracts top-level)]) [expr-list (extract-not-contracts top-level)])
(with-syntax ([rest (parse-contract-expressions language-level-contract (parse-contract-expressions language-level-contract
language-level-define-data language-level-define-data
cnt-list cnt-list
expr-list)]) expr-list)))]
(syntax/loc stx (#%plain-module-begin rest))))]))) [(_ e1s (e2 . e3s) def-ids)
(let ([e2 (local-expand #'e2 'module local-expand-stop-list)])
;; Lift out certain forms to make them visible to the module
;; expander:
(syntax-case e2 (require define-syntaxes define-values-for-syntax define-values begin)
[(require . __)
#`(begin #,e2 (_ e1s e3s def-ids))]
[(define-syntaxes (id ...) . __)
#`(begin #,e2 (_ e1s e3s (id ... . def-ids)))]
[(define-values-for-syntax . __)
#`(begin #,e2 (_ e1s e3s def-ids))]
[(begin b1 ...)
#`(_ e1s (b1 ... . e3s) def-ids)]
[(define-values (id ...) . __)
#`(_ (#,e2 . e1s) e3s (id ... . def-ids))]
[else
#`(_ (#,e2 . e1s) e3s def-ids)]))]))))
(define parse-beginner-contract/func (define-values (parse-beginner-contract/func continue-beginner-contract/func)
(parse-contracts #'beginner-contract #'beginner-define-data)) (parse-contracts #'beginner-contract #'beginner-define-data #'beginner-continue))
(define parse-intermediate-contract/func (define-values (parse-intermediate-contract/func continue-intermediate-contract/func)
(parse-contracts #'intermediate-contract #'intermediate-define-data)) (parse-contracts #'intermediate-contract #'intermediate-define-data #'intermediate-continue))
(define parse-advanced-contract/func (define-values (parse-advanced-contract/func continue-advanced-contract/func)
(parse-contracts #'advanced-contract #'advanced-define-data)) (parse-contracts #'advanced-contract #'advanced-define-data #'advanced-continue))
(values parse-beginner-contract/func (values parse-beginner-contract/func
parse-intermediate-contract/func parse-intermediate-contract/func
parse-advanced-contract/func)))) parse-advanced-contract/func
continue-beginner-contract/func
continue-intermediate-contract/func
continue-advanced-contract/func))))

174
collects/lang/private/teach.ss
View File

@ -1,10 +1,8 @@
;; Implements the Teaching languages, at least in terms of the ;; Implements the syntactic forms for the HtDP teaching languages. The
;; forms. The reader-level aspects of the language (e.g., ;; reader-level aspects of the language (e.g., case-sensitivity) are
;; case-sensitivity) are not implemented here, and the procedures are ;; not implemented here, and the procedures are in a separate
;; in a separate module. Also, the "reference to uninitialized module ;; module.
;; identifier" message must be replaced with an "identifier used before
;; its definition was evaluated" error that omits the name.
;; To a first approximation, this module is one big error-checking ;; To a first approximation, this module is one big error-checking
;; routine. In other words, most of the syntax implementations are ;; routine. In other words, most of the syntax implementations are
@ -16,12 +14,24 @@
;; - Report errors according to a left-to-right reading; e.g., the ;; - Report errors according to a left-to-right reading; e.g., the
;; error in `(define 1 2 3)' is "expected an identifier, found 1", ;; error in `(define 1 2 3)' is "expected an identifier, found 1",
;; not "expected two parts after `define', but found three". ;; not "expected two parts after `define', but found three".
;; - Left-to-right reporting sometimes requires an explicit expression ;; - The error message should always explain what is wrong, not simply
;; check (via `local-expand') before reporting some other error. For ;; state a fact. For example, "f defined previously, so it cannot
;; example, in the expression (define (f x) + 1 2), the reported ;; be re-defined here" is a good error message; in contrast, "found
;; error should be for a misuse of "+", not that there are two extra ;; second definition of f here" doesn't say what's wrong with a second
;; parts in the definition. Avoid using `local-expand' if there's ;; definition.
;; no error, however.
;; Left-to-right reporting sometimes requires an explicit expression
;; check before reporting some other error. For example, in the
;; expression (cond [true + 1 2]), the reported error should ideally
;; be for a misuse of "+", not that there are two extra parts in the
;; clause. This check requires local-expanding, so it doesn't work
;; when checkign top-level forms like `define' (because not all of the
;; definitions are ready, yet). For other cases, ensure that the
;; expansion is in an expression position (not the top level) and use
;; the `local-expand-for-error' function instead of `local-expand' to
;; help declare that the expansion is merely for left-to-right error
;; reporting. As always, avoid using `local-expand' if there's no
;; error.
(module teach mzscheme (module teach mzscheme
(require (lib "etc.ss") (require (lib "etc.ss")
@ -169,6 +179,12 @@
(raise-syntax-error form msg stx detail) (raise-syntax-error form msg stx detail)
(raise-syntax-error form msg stx)))) (raise-syntax-error form msg stx))))
(define (binding-in-this-module? b)
(and (list? b)
(module-path-index? (car b))
(let-values ([(path base) (module-path-index-split (car b))])
(and (not path) (not base)))))
;; The syntax error when a form's name doesn't follow a "(" ;; The syntax error when a form's name doesn't follow a "("
(define (bad-use-error name stx) (define (bad-use-error name stx)
(teach-syntax-error (teach-syntax-error
@ -242,12 +258,6 @@
(define (check-definition-new who stx name defn) (define (check-definition-new who stx name defn)
(check-definitions-new who stx (list name) defn)) (check-definitions-new who stx (list name) defn))
(define (binding-in-this-module? b)
(and (list? b)
(module-path-index? (car b))
(let-values ([(path base) (module-path-index-split (car b))])
(and (not path) (not base)))))
;; Check context for a `define' before even trying to ;; Check context for a `define' before even trying to
;; expand ;; expand
(define-struct expanding-for-intermediate-local ()) (define-struct expanding-for-intermediate-local ())
@ -257,6 +267,19 @@
(and (pair? ctx) (and (pair? ctx)
(expanding-for-intermediate-local? (car ctx)))))) (expanding-for-intermediate-local? (car ctx))))))
(define (local-expand-for-error stx ctx stops)
;; This function should only be called in an 'expression
;; context. In case we mess up, avoid bogus error messages.
(when (memq (syntax-local-context) '(expression))
(local-expand stx ctx stops)))
(define (ensure-expression stx k)
(if (memq (syntax-local-context) '(expression))
(k)
(syntax-property #`(values #,stx)
'stepper-skipto
(list syntax-e cdr syntax-e cdr car))))
;; Use to generate nicer error messages than direct pattern ;; Use to generate nicer error messages than direct pattern
;; matching. The `where' argument is an English description ;; matching. The `where' argument is an English description
;; of the portion of the larger expression where a single ;; of the portion of the larger expression where a single
@ -278,7 +301,7 @@
;; have to stop at advanced-set!, in case it's used with ;; have to stop at advanced-set!, in case it's used with
;; one of the identifiers in will-bind. ;; one of the identifiers in will-bind.
(when will-bind (when will-bind
(local-expand (car exprs) 'expression (cons #'advanced-set! (local-expand-for-error (car exprs) 'expression (cons #'advanced-set!
will-bind))) will-bind)))
;; First expression seems ok, report an error for 2nd and later: ;; First expression seems ok, report an error for 2nd and later:
(teach-syntax-error (teach-syntax-error
@ -448,7 +471,9 @@
(check-single-result-expr (syntax->list (syntax (expr ...))) (check-single-result-expr (syntax->list (syntax (expr ...)))
#f #f
stx stx
names) ;; can't local-expand function body, because
;; not all top-level defns are ready:
#f)
(check-definition-new (check-definition-new
'define 'define
@ -476,7 +501,9 @@
(syntax-e (syntax name))) (syntax-e (syntax name)))
stx stx
exprs exprs
(list (syntax name))))] ;; can't local-expand RHS, because
;; not all top-level defns are ready:
#f))]
;; Bad name/header: ;; Bad name/header:
[(_ non-name expr ...) [(_ non-name expr ...)
(teach-syntax-error (teach-syntax-error
@ -847,6 +874,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (beginner-cond/proc stx) (define (beginner-cond/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_) [(_)
(teach-syntax-error (teach-syntax-error
@ -867,8 +897,8 @@
(begin (begin
(unless (and (identifier? (syntax question)) (unless (and (identifier? (syntax question))
(module-identifier=? (syntax question) #'beginner-else)) (module-identifier=? (syntax question) #'beginner-else))
(local-expand (syntax question) 'expression null)) (local-expand-for-error (syntax question) 'expression null))
(local-expand (syntax answer) 'expression null))]))) (local-expand-for-error (syntax answer) 'expression null))])))
clauses)))]) clauses)))])
(let ([checked-clauses (let ([checked-clauses
(map (map
@ -911,9 +941,9 @@
;; the question and first answer (if any) are ok: ;; the question and first answer (if any) are ok:
(unless (and (identifier? (car parts)) (unless (and (identifier? (car parts))
(module-identifier=? (car parts) #'beginner-else)) (module-identifier=? (car parts) #'beginner-else))
(local-expand (car parts) 'expression null)) (local-expand-for-error (car parts) 'expression null))
(unless (null? (cdr parts)) (unless (null? (cdr parts))
(local-expand (cadr parts) 'expression null)) (local-expand-for-error (cadr parts) 'expression null))
;; question and answer (if any) are ok, raise a count-based exception: ;; question and answer (if any) are ok, raise a count-based exception:
(teach-syntax-error (teach-syntax-error
'cond 'cond
@ -936,7 +966,7 @@
(syntax [else error-call]))))]) (syntax [else error-call]))))])
(with-syntax ([clauses clauses]) (with-syntax ([clauses clauses])
(syntax/loc stx (cond . clauses))))))] (syntax/loc stx (cond . clauses))))))]
[_else (bad-use-error 'cond stx)])) [_else (bad-use-error 'cond stx)]))))
(define beginner-else/proc (define beginner-else/proc
(make-set!-transformer (make-set!-transformer
@ -957,9 +987,14 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (beginner-if/proc stx) (define (beginner-if/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ test then else) [(_ test then else)
(with-syntax ([new-test (syntax-property (syntax (verify-boolean test 'if)) 'stepper-skipto (list syntax-e cdr syntax-e cdr car))]) (with-syntax ([new-test (syntax-property (syntax (verify-boolean test 'if))
'stepper-skipto
(list syntax-e cdr syntax-e cdr car))])
(syntax/loc stx (syntax/loc stx
(if new-test (if new-test
then then
@ -973,7 +1008,7 @@
"expected one question expression and two answer expressions, but found ~a expression~a" "expected one question expression and two answer expressions, but found ~a expression~a"
(if (zero? n) "no" n) (if (zero? n) "no" n)
(if (= n 1) "" "s")))] (if (= n 1) "" "s")))]
[_else (bad-use-error 'if stx)])) [_else (bad-use-error 'if stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; or, and ;; or, and
@ -987,6 +1022,9 @@
[(and) 'comes-from-and])]) [(and) 'comes-from-and])])
(with-syntax ([swhere where]) (with-syntax ([swhere where])
(lambda (stx) (lambda (stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ . clauses) [(_ . clauses)
(let ([n (length (syntax->list (syntax clauses)))]) (let ([n (length (syntax->list (syntax clauses)))])
@ -1020,7 +1058,7 @@
stepper-tag) stepper-tag)
'stepper-and/or-clauses-consumed 'stepper-and/or-clauses-consumed
clauses-consumed))))] clauses-consumed))))]
[_else (bad-use-error where stx)])))))]) [_else (bad-use-error where stx)])))))))])
(values (mk 'or) (mk 'and)))) (values (mk 'or) (mk 'and))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1047,6 +1085,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (intermediate-local/proc stx) (define (intermediate-local/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ (definition ...) . exprs) [(_ (definition ...) . exprs)
(let ([defns (syntax->list (syntax (definition ...)))] (let ([defns (syntax->list (syntax (definition ...)))]
@ -1190,7 +1231,7 @@
stx stx
#f #f
"expected a parenthesized definition sequence after `local', but nothing's there")] "expected a parenthesized definition sequence after `local', but nothing's there")]
[_else (bad-use-error 'local stx)])) [_else (bad-use-error 'local stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; letrec and let (intermediate) ;; letrec and let (intermediate)
@ -1200,6 +1241,9 @@
;; put all error checking in `bad-let-form'. ;; put all error checking in `bad-let-form'.
(define (intermediate-letrec/proc stx) (define (intermediate-letrec/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ ([name rhs-expr] ...) expr) [(_ ([name rhs-expr] ...) expr)
(let ([names (syntax->list (syntax (name ...)))]) (let ([names (syntax->list (syntax (name ...)))])
@ -1227,9 +1271,12 @@
([(tmp-id) rhs-expr] ([(tmp-id) rhs-expr]
...) ...)
expr)))] expr)))]
[_else (bad-let-form 'letrec stx stx)])) [_else (bad-let-form 'letrec stx stx)]))))
(define (intermediate-let/proc stx) (define (intermediate-let/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ ([name rhs-expr] ...) expr) [(_ ([name rhs-expr] ...) expr)
(let ([names (syntax->list (syntax (name ...)))]) (let ([names (syntax->list (syntax (name ...)))])
@ -1256,9 +1303,12 @@
(quote-syntax tmp-id))] (quote-syntax tmp-id))]
...) ...)
expr))))] expr))))]
[_else (bad-let-form 'let stx stx)])) [_else (bad-let-form 'let stx stx)]))))
(define (intermediate-let*/proc stx) (define (intermediate-let*/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ () expr) [(_ () expr)
(syntax-property (syntax-property
@ -1278,7 +1328,7 @@
expr)))) expr))))
'stepper-hint 'stepper-hint
'comes-from-let*))] 'comes-from-let*))]
[_else (bad-let-form 'let* stx stx)])) [_else (bad-let-form 'let* stx stx)]))))
;; Helper function: allows `beginner-lambda' instead ;; Helper function: allows `beginner-lambda' instead
;; of rejecting it: ;; of rejecting it:
@ -1385,6 +1435,9 @@
(let ([mk (let ([mk
(lambda (empty-ok?) (lambda (empty-ok?)
(lambda (stx) (lambda (stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ fname ([name rhs-expr] ...) expr) [(_ fname ([name rhs-expr] ...) expr)
(and (identifier/non-kw? (syntax fname)) (and (identifier/non-kw? (syntax fname))
@ -1434,7 +1487,7 @@
#f #f
"expected a function name after `recur', but nothing's there")] "expected a function name after `recur', but nothing's there")]
[_else [_else
(bad-use-error 'recur stx)])))]) (bad-use-error 'recur stx)])))))])
(values (mk #f) (mk #t)))) (values (mk #f) (mk #t))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1442,6 +1495,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (intermediate-lambda/proc stx) (define (intermediate-lambda/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ arg-seq lexpr ...) [(_ arg-seq lexpr ...)
(syntax-case (syntax arg-seq) () [(arg ...) #t][_else #f]) (syntax-case (syntax arg-seq) () [(arg ...) #t][_else #f])
@ -1490,7 +1546,7 @@
#f #f
"expected a sequence of argument names after `lambda', but nothing's there")] "expected a sequence of argument names after `lambda', but nothing's there")]
[_else [_else
(bad-use-error 'lambda stx)])) (bad-use-error 'lambda stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; quote (intermediate) ;; quote (intermediate)
@ -1505,7 +1561,8 @@
"after the `quote' keyword" "after the `quote' keyword"
stx stx
(syntax->list (syntax (expr ...))) (syntax->list (syntax (expr ...)))
null) ;; Don't expand expr!
#f)
(syntax (quote expr ...)))] (syntax (quote expr ...)))]
[_else (bad-use-error 'quote stx)]))) [_else (bad-use-error 'quote stx)])))
@ -1589,6 +1646,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (intermediate-time/proc stx) (define (intermediate-time/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ . exprs) [(_ . exprs)
(check-single-expression 'time (check-single-expression 'time
@ -1601,7 +1661,7 @@
'stepper-skipto 'stepper-skipto
(list syntax-e cdr car syntax-e car syntax-e cdr car syntax-e cdr syntax-e cdr car syntax-e cdr cdr car))] (list syntax-e cdr car syntax-e car syntax-e cdr car syntax-e cdr syntax-e cdr car syntax-e cdr cdr car))]
[_else [_else
(bad-use-error 'time stx)])) (bad-use-error 'time stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define (advanced) ;; define (advanced)
@ -1638,6 +1698,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (advanced-lambda/proc stx) (define (advanced-lambda/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ (name ...) . exprs) [(_ (name ...) . exprs)
(let ([names (syntax->list (syntax (name ...)))]) (let ([names (syntax->list (syntax (name ...)))])
@ -1678,13 +1741,16 @@
#f #f
"expected a sequence of argument names after `lambda', but nothing's there")] "expected a sequence of argument names after `lambda', but nothing's there")]
[_else [_else
(bad-use-error 'lambda stx)])) (bad-use-error 'lambda stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; application (advanced) ;; application (advanced)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (advanced-app/proc stx) (define (advanced-app/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ rator rand ...) [(_ rator rand ...)
(syntax/loc stx (#%app rator rand ...))] (syntax/loc stx (#%app rator rand ...))]
@ -1695,7 +1761,7 @@
#f #f
"expected a defined name or a primitive operation name after an ~ "expected a defined name or a primitive operation name after an ~
open parenthesis, but nothing's there")] open parenthesis, but nothing's there")]
[_else (bad-use-error '#%app stx)])) [_else (bad-use-error '#%app stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set! (advanced) ;; set! (advanced)
@ -1709,6 +1775,9 @@
(let ([proc (let ([proc
(lambda (continuing?) (lambda (continuing?)
(lambda (stx) (lambda (stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ id expr ...) [(_ id expr ...)
(identifier? (syntax id)) (identifier? (syntax id))
@ -1784,7 +1853,7 @@
stx stx
(syntax id) (syntax id)
"expected a defined name after `set!', but nothing's there")] "expected a defined name after `set!', but nothing's there")]
[_else (bad-use-error 'set! stx)])))]) [_else (bad-use-error 'set! stx)])))))])
(values (proc #f) (values (proc #f)
(proc #t)))) (proc #t))))
@ -1796,6 +1865,9 @@
(let ([mk (let ([mk
(lambda (who target-stx) (lambda (who target-stx)
(lambda (stx) (lambda (stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ q expr ...) [(_ q expr ...)
(let ([exprs (syntax->list (syntax (expr ...)))]) (let ([exprs (syntax->list (syntax (expr ...)))])
@ -1816,7 +1888,7 @@
"expected a question expression after `~a', but nothing's there" "expected a question expression after `~a', but nothing's there"
who)] who)]
[_else [_else
(bad-use-error who stx)])))]) (bad-use-error who stx)])))))])
(values (mk 'when (quote-syntax when)) (values (mk 'when (quote-syntax when))
(mk 'unless (quote-syntax unless))))) (mk 'unless (quote-syntax unless)))))
@ -1832,6 +1904,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (advanced-let/proc stx) (define (advanced-let/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ name ids body) [(_ name ids body)
(identifier/non-kw? (syntax name)) (identifier/non-kw? (syntax name))
@ -1846,7 +1921,7 @@
[(_ . rest) [(_ . rest)
(syntax/loc stx (intermediate-let . rest))] (syntax/loc stx (intermediate-let . rest))]
[_else [_else
(bad-use-error 'let stx)])) (bad-use-error 'let stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; begin (advanced) ;; begin (advanced)
@ -1888,6 +1963,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (advanced-case/proc stx) (define (advanced-case/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_) [(_)
(teach-syntax-error (teach-syntax-error
@ -1984,7 +2062,7 @@
[else (cons (car clauses) (loop (cdr clauses)))]))]) [else (cons (car clauses) (loop (cdr clauses)))]))])
(with-syntax ([clauses clauses]) (with-syntax ([clauses clauses])
(syntax/loc stx (case v-expr . clauses)))))] (syntax/loc stx (case v-expr . clauses)))))]
[_else (bad-use-error 'case stx)])) [_else (bad-use-error 'case stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; delay (advanced) ;; delay (advanced)
@ -1992,6 +2070,9 @@
(define advanced-delay/proc (define advanced-delay/proc
(lambda (stx) (lambda (stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ expr ...) [(_ expr ...)
(begin (begin
@ -2001,7 +2082,7 @@
(syntax->list (syntax (expr ...))) (syntax->list (syntax (expr ...)))
null) null)
(syntax (delay expr ...)))] (syntax (delay expr ...)))]
[_else (bad-use-error 'delay stx)]))) [_else (bad-use-error 'delay stx)])))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; shared (advanced) ;; shared (advanced)
@ -2012,6 +2093,9 @@
(define advanced-shared/proc (define advanced-shared/proc
(lambda (stx) (lambda (stx)
(ensure-expression
stx
(lambda ()
;; Helper for the main implementation ;; Helper for the main implementation
(define (make-check-cdr name) (define (make-check-cdr name)
(with-syntax ([name name]) (with-syntax ([name name])
@ -2080,4 +2164,4 @@
[_else (bad-use-error 'shared stx)]) [_else (bad-use-error 'shared stx)])
;; The main implementation ;; The main implementation
(include (build-path up up "mzlib" "private" "shared-body.ss")))))) (include (build-path up up "mzlib" "private" "shared-body.ss"))))))))

20
collects/tests/mzscheme/beg-adv.ss
View File

@ -65,6 +65,8 @@
(htdp-test 9 'app-f (f 4)) (htdp-test 9 'app-f (f 4))
(htdp-top (define f2 (lambda (y) (+ x y)))) (htdp-top (define f2 (lambda (y) (+ x y))))
(htdp-test 15 'app-f (f 10)) (htdp-test 15 'app-f (f 10))
(htdp-top-pop 1)
(htdp-top-pop 1)
(htdp-top (define-struct a0 ())) (htdp-top (define-struct a0 ()))
(htdp-top (define-struct a1 (b))) (htdp-top (define-struct a1 (b)))
@ -145,18 +147,21 @@
(htdp-error-test #'(define (an-example-structure x) 5)) (htdp-error-test #'(define (an-example-structure x) 5))
(htdp-error-test #'(define-struct an-example-structure (y))) (htdp-error-test #'(define-struct an-example-structure (y)))
(htdp-error-test #'(define-struct an-example (structure y))) (htdp-error-test #'(define-struct an-example (structure y)))
(htdp-top-pop 1)
(htdp-top (define an-example-value 12)) (htdp-top (define an-example-value 12))
(htdp-error-test #'(define an-example-value 5)) (htdp-error-test #'(define an-example-value 5))
(htdp-error-test #'(define (an-example-value x) 5)) (htdp-error-test #'(define (an-example-value x) 5))
(htdp-error-test #'(define-struct an-example-value (y))) (htdp-error-test #'(define-struct an-example-value (y)))
(htdp-error-test #'(define-struct an-example (value y))) (htdp-error-test #'(define-struct an-example (value y)))
(htdp-top-pop 1)
(htdp-top (define (an-example-function x) x)) (htdp-top (define (an-example-function x) x))
(htdp-error-test #'(define an-example-function 5)) (htdp-error-test #'(define an-example-function 5))
(htdp-error-test #'(define (an-example-function x) 5)) (htdp-error-test #'(define (an-example-function x) 5))
(htdp-error-test #'(define-struct an-example-function (y))) (htdp-error-test #'(define-struct an-example-function (y)))
(htdp-error-test #'(define-struct an-example (function y))) (htdp-error-test #'(define-struct an-example (function y)))
(htdp-top-pop 1)
(htdp-test #t 'equal? (equal? 1 1)) (htdp-test #t 'equal? (equal? 1 1))
(htdp-test #t 'equal? (equal? (list 1) (list 1))) (htdp-test #t 'equal? (equal? (list 1) (list 1)))
@ -184,3 +189,18 @@
(htdp-test #t 'equal~? (equal~? (make-a1 #i2.0) (make-a1 2) #i0.2)) (htdp-test #t 'equal~? (equal~? (make-a1 #i2.0) (make-a1 2) #i0.2))
(htdp-test #f 'equal~? (equal~? (make-a1 #i2.3) (make-a1 2) #i0.2)) (htdp-test #f 'equal~? (equal~? (make-a1 #i2.3) (make-a1 2) #i0.2))
(htdp-top-pop 1)
(htdp-top-pop 1)
(htdp-top-pop 1)
;; Error messages
(htdp-top (define my-x 5))
(htdp-top (define (my-f x) (+ x 5)))
(htdp-syntax-test #'(cond [true my-x 5]) #rx"found a clause with 3 parts")
(htdp-syntax-test #'(define foo17 my-x 5) #rx"found one extra part")
(htdp-syntax-test #'(my-y 17) #rx"not defined, not an argument, and not a primitive name")
(htdp-syntax-test #'(cond [true my-y 17]) #rx"not defined, not an argument, and not a primitive name")
(htdp-syntax-test #'(define my-f 12) #rx"cannot be re-defined")
(htdp-syntax-test #'(define my-x 12) #rx"cannot be re-defined")
(htdp-top-pop 1)
(htdp-top-pop 1)

4
collects/tests/mzscheme/beg-bega.ss
View File

@ -23,4 +23,6 @@
(htdp-error-test #'1) (htdp-error-test #'1)
(htdp-top-pop 1) (htdp-top-pop 1)
(htdp-top (define (my-f x) (+ x 5)))
(htdp-syntax-test #'my-f #rx"a procedure, so it must be applied")
(htdp-top-pop 1)

15
collects/tests/mzscheme/htdp-test.ss
View File

@ -1,8 +1,4 @@
(define (htdp-syntax-test stx)
(syntax-test #`(module m #,current-htdp-lang
#,stx)))
(define body-accum null) (define body-accum null)
(define-syntax (htdp-top stx) (define-syntax (htdp-top stx)
(syntax-case stx (quote) (syntax-case stx (quote)
@ -14,6 +10,17 @@
null null
(cons (car body-accum) (loop (cdr body-accum))))))) (cons (car body-accum) (loop (cdr body-accum)))))))
(define htdp-syntax-test
(case-lambda
[(stx) (htdp-syntax-test stx #rx".")]
[(stx rx)
(error-test #`(module m #,current-htdp-lang
#,@body-accum
#,stx)
(lambda (x)
(and (exn:fail:syntax? x)
(regexp-match rx (exn-message x)))))]))
(define-syntax (htdp-test stx) (define-syntax (htdp-test stx)
(syntax-case stx () (syntax-case stx ()
[(_ expect f . args) [(_ expect f . args)