teaching-langauge error message improvements
svn: r1197
This commit is contained in:
Matthew Flatt
parent
28afce07b0
commit
81dc642c4e
|
|
@ -2,13 +2,16 @@
|
|||
|
||||
(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)
|
||||
|
||||
(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 ()
|
||||
(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
|
||||
;; a contract declaration. Syntax: (contract function-name (domain ... -> range))
|
||||
(define extract-contracts
|
||||
|
|
@ -138,8 +141,8 @@
|
|||
(syntax (begin ))
|
||||
(raise-syntax-error 'contracts "this contract has no corresponding def" (car cnt-list)))]
|
||||
[else
|
||||
; (let ([expanded (local-expand (car exprs) (syntax-local-context) local-expand-stop-list)])
|
||||
(let ([expanded (local-expand (car exprs) 'module local-expand-stop-list)])
|
||||
(let ([expanded (car exprs)])
|
||||
|
||||
(syntax-case expanded (begin define-values define-data)
|
||||
[(define-values (func) e1 ...)
|
||||
(contract-defined? cnt-list expanded)
|
||||
|
|
@ -163,8 +166,6 @@
|
|||
#,(car exprs)
|
||||
#,(loop cnt-list (cdr exprs))))]))])))
|
||||
|
||||
|
||||
|
||||
;; contract transformations!
|
||||
;; this is the macro, abstracted over which language level we are using.
|
||||
;; parse-contracts :
|
||||
|
|
@ -175,25 +176,75 @@
|
|||
;; where ll-contract is either beginner-contract, intermediate-contract, or advanced-contract
|
||||
;; and (define-data name ....) to (lang-lvl-define-data name ...)
|
||||
|
||||
(values
|
||||
;; module-begin (for a specific language:)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ 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)]
|
||||
[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
|
||||
cnt-list
|
||||
expr-list)])
|
||||
(syntax/loc stx (#%plain-module-begin rest))))])))
|
||||
expr-list)))]
|
||||
[(_ 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
|
||||
(parse-contracts #'beginner-contract #'beginner-define-data))
|
||||
(define parse-intermediate-contract/func
|
||||
(parse-contracts #'intermediate-contract #'intermediate-define-data))
|
||||
(define parse-advanced-contract/func
|
||||
(parse-contracts #'advanced-contract #'advanced-define-data))
|
||||
(define-values (parse-beginner-contract/func continue-beginner-contract/func)
|
||||
(parse-contracts #'beginner-contract #'beginner-define-data #'beginner-continue))
|
||||
(define-values (parse-intermediate-contract/func continue-intermediate-contract/func)
|
||||
(parse-contracts #'intermediate-contract #'intermediate-define-data #'intermediate-continue))
|
||||
(define-values (parse-advanced-contract/func continue-advanced-contract/func)
|
||||
(parse-contracts #'advanced-contract #'advanced-define-data #'advanced-continue))
|
||||
|
||||
(values parse-beginner-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))))
|
||||
|
|
|
|||
|
|
@ -1,10 +1,8 @@
|
|||
|
||||
;; Implements the Teaching languages, at least in terms of the
|
||||
;; forms. The reader-level aspects of the language (e.g.,
|
||||
;; case-sensitivity) are not implemented here, and the procedures are
|
||||
;; in a separate module. Also, the "reference to uninitialized module
|
||||
;; identifier" message must be replaced with an "identifier used before
|
||||
;; its definition was evaluated" error that omits the name.
|
||||
;; Implements the syntactic forms for the HtDP teaching languages. The
|
||||
;; reader-level aspects of the language (e.g., case-sensitivity) are
|
||||
;; not implemented here, and the procedures are in a separate
|
||||
;; module.
|
||||
|
||||
;; To a first approximation, this module is one big error-checking
|
||||
;; 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
|
||||
;; error in `(define 1 2 3)' is "expected an identifier, found 1",
|
||||
;; not "expected two parts after `define', but found three".
|
||||
;; - Left-to-right reporting sometimes requires an explicit expression
|
||||
;; check (via `local-expand') before reporting some other error. For
|
||||
;; example, in the expression (define (f x) + 1 2), the reported
|
||||
;; error should be for a misuse of "+", not that there are two extra
|
||||
;; parts in the definition. Avoid using `local-expand' if there's
|
||||
;; no error, however.
|
||||
;; - The error message should always explain what is wrong, not simply
|
||||
;; state a fact. For example, "f defined previously, so it cannot
|
||||
;; be re-defined here" is a good error message; in contrast, "found
|
||||
;; second definition of f here" doesn't say what's wrong with a second
|
||||
;; definition.
|
||||
|
||||
;; 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
|
||||
(require (lib "etc.ss")
|
||||
|
|
@ -169,6 +179,12 @@
|
|||
(raise-syntax-error form msg stx detail)
|
||||
(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 "("
|
||||
(define (bad-use-error name stx)
|
||||
(teach-syntax-error
|
||||
|
|
@ -242,12 +258,6 @@
|
|||
(define (check-definition-new who stx 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
|
||||
;; expand
|
||||
(define-struct expanding-for-intermediate-local ())
|
||||
|
|
@ -257,6 +267,19 @@
|
|||
(and (pair? 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
|
||||
;; matching. The `where' argument is an English description
|
||||
;; 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
|
||||
;; one of the identifiers in 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)))
|
||||
;; First expression seems ok, report an error for 2nd and later:
|
||||
(teach-syntax-error
|
||||
|
|
@ -448,7 +471,9 @@
|
|||
(check-single-result-expr (syntax->list (syntax (expr ...)))
|
||||
#f
|
||||
stx
|
||||
names)
|
||||
;; can't local-expand function body, because
|
||||
;; not all top-level defns are ready:
|
||||
#f)
|
||||
|
||||
(check-definition-new
|
||||
'define
|
||||
|
|
@ -476,7 +501,9 @@
|
|||
(syntax-e (syntax name)))
|
||||
stx
|
||||
exprs
|
||||
(list (syntax name))))]
|
||||
;; can't local-expand RHS, because
|
||||
;; not all top-level defns are ready:
|
||||
#f))]
|
||||
;; Bad name/header:
|
||||
[(_ non-name expr ...)
|
||||
(teach-syntax-error
|
||||
|
|
@ -847,6 +874,9 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (beginner-cond/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(teach-syntax-error
|
||||
|
|
@ -867,8 +897,8 @@
|
|||
(begin
|
||||
(unless (and (identifier? (syntax question))
|
||||
(module-identifier=? (syntax question) #'beginner-else))
|
||||
(local-expand (syntax question) 'expression null))
|
||||
(local-expand (syntax answer) 'expression null))])))
|
||||
(local-expand-for-error (syntax question) 'expression null))
|
||||
(local-expand-for-error (syntax answer) 'expression null))])))
|
||||
clauses)))])
|
||||
(let ([checked-clauses
|
||||
(map
|
||||
|
|
@ -911,9 +941,9 @@
|
|||
;; the question and first answer (if any) are ok:
|
||||
(unless (and (identifier? (car parts))
|
||||
(module-identifier=? (car parts) #'beginner-else))
|
||||
(local-expand (car parts) 'expression null))
|
||||
(local-expand-for-error (car parts) 'expression null))
|
||||
(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:
|
||||
(teach-syntax-error
|
||||
'cond
|
||||
|
|
@ -936,7 +966,7 @@
|
|||
(syntax [else error-call]))))])
|
||||
(with-syntax ([clauses clauses])
|
||||
(syntax/loc stx (cond . clauses))))))]
|
||||
[_else (bad-use-error 'cond stx)]))
|
||||
[_else (bad-use-error 'cond stx)]))))
|
||||
|
||||
(define beginner-else/proc
|
||||
(make-set!-transformer
|
||||
|
|
@ -957,9 +987,14 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (beginner-if/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ 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
|
||||
(if new-test
|
||||
then
|
||||
|
|
@ -973,7 +1008,7 @@
|
|||
"expected one question expression and two answer expressions, but found ~a expression~a"
|
||||
(if (zero? n) "no" n)
|
||||
(if (= n 1) "" "s")))]
|
||||
[_else (bad-use-error 'if stx)]))
|
||||
[_else (bad-use-error 'if stx)]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; or, and
|
||||
|
|
@ -987,6 +1022,9 @@
|
|||
[(and) 'comes-from-and])])
|
||||
(with-syntax ([swhere where])
|
||||
(lambda (stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ . clauses)
|
||||
(let ([n (length (syntax->list (syntax clauses)))])
|
||||
|
|
@ -1020,7 +1058,7 @@
|
|||
stepper-tag)
|
||||
'stepper-and/or-clauses-consumed
|
||||
clauses-consumed))))]
|
||||
[_else (bad-use-error where stx)])))))])
|
||||
[_else (bad-use-error where stx)])))))))])
|
||||
(values (mk 'or) (mk 'and))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -1047,6 +1085,9 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (intermediate-local/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ (definition ...) . exprs)
|
||||
(let ([defns (syntax->list (syntax (definition ...)))]
|
||||
|
|
@ -1190,7 +1231,7 @@
|
|||
stx
|
||||
#f
|
||||
"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)
|
||||
|
|
@ -1200,6 +1241,9 @@
|
|||
;; put all error checking in `bad-let-form'.
|
||||
|
||||
(define (intermediate-letrec/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ ([name rhs-expr] ...) expr)
|
||||
(let ([names (syntax->list (syntax (name ...)))])
|
||||
|
|
@ -1227,9 +1271,12 @@
|
|||
([(tmp-id) rhs-expr]
|
||||
...)
|
||||
expr)))]
|
||||
[_else (bad-let-form 'letrec stx stx)]))
|
||||
[_else (bad-let-form 'letrec stx stx)]))))
|
||||
|
||||
(define (intermediate-let/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ ([name rhs-expr] ...) expr)
|
||||
(let ([names (syntax->list (syntax (name ...)))])
|
||||
|
|
@ -1256,9 +1303,12 @@
|
|||
(quote-syntax tmp-id))]
|
||||
...)
|
||||
expr))))]
|
||||
[_else (bad-let-form 'let stx stx)]))
|
||||
[_else (bad-let-form 'let stx stx)]))))
|
||||
|
||||
(define (intermediate-let*/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ () expr)
|
||||
(syntax-property
|
||||
|
|
@ -1278,7 +1328,7 @@
|
|||
expr))))
|
||||
'stepper-hint
|
||||
'comes-from-let*))]
|
||||
[_else (bad-let-form 'let* stx stx)]))
|
||||
[_else (bad-let-form 'let* stx stx)]))))
|
||||
|
||||
;; Helper function: allows `beginner-lambda' instead
|
||||
;; of rejecting it:
|
||||
|
|
@ -1385,6 +1435,9 @@
|
|||
(let ([mk
|
||||
(lambda (empty-ok?)
|
||||
(lambda (stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ fname ([name rhs-expr] ...) expr)
|
||||
(and (identifier/non-kw? (syntax fname))
|
||||
|
|
@ -1434,7 +1487,7 @@
|
|||
#f
|
||||
"expected a function name after `recur', but nothing's there")]
|
||||
[_else
|
||||
(bad-use-error 'recur stx)])))])
|
||||
(bad-use-error 'recur stx)])))))])
|
||||
(values (mk #f) (mk #t))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -1442,6 +1495,9 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (intermediate-lambda/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ arg-seq lexpr ...)
|
||||
(syntax-case (syntax arg-seq) () [(arg ...) #t][_else #f])
|
||||
|
|
@ -1490,7 +1546,7 @@
|
|||
#f
|
||||
"expected a sequence of argument names after `lambda', but nothing's there")]
|
||||
[_else
|
||||
(bad-use-error 'lambda stx)]))
|
||||
(bad-use-error 'lambda stx)]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; quote (intermediate)
|
||||
|
|
@ -1505,7 +1561,8 @@
|
|||
"after the `quote' keyword"
|
||||
stx
|
||||
(syntax->list (syntax (expr ...)))
|
||||
null)
|
||||
;; Don't expand expr!
|
||||
#f)
|
||||
(syntax (quote expr ...)))]
|
||||
[_else (bad-use-error 'quote stx)])))
|
||||
|
||||
|
|
@ -1589,6 +1646,9 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (intermediate-time/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ . exprs)
|
||||
(check-single-expression 'time
|
||||
|
|
@ -1601,7 +1661,7 @@
|
|||
'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))]
|
||||
[_else
|
||||
(bad-use-error 'time stx)]))
|
||||
(bad-use-error 'time stx)]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; define (advanced)
|
||||
|
|
@ -1638,6 +1698,9 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (advanced-lambda/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ (name ...) . exprs)
|
||||
(let ([names (syntax->list (syntax (name ...)))])
|
||||
|
|
@ -1678,13 +1741,16 @@
|
|||
#f
|
||||
"expected a sequence of argument names after `lambda', but nothing's there")]
|
||||
[_else
|
||||
(bad-use-error 'lambda stx)]))
|
||||
(bad-use-error 'lambda stx)]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; application (advanced)
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (advanced-app/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ rator rand ...)
|
||||
(syntax/loc stx (#%app rator rand ...))]
|
||||
|
|
@ -1695,7 +1761,7 @@
|
|||
#f
|
||||
"expected a defined name or a primitive operation name after an ~
|
||||
open parenthesis, but nothing's there")]
|
||||
[_else (bad-use-error '#%app stx)]))
|
||||
[_else (bad-use-error '#%app stx)]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; set! (advanced)
|
||||
|
|
@ -1709,6 +1775,9 @@
|
|||
(let ([proc
|
||||
(lambda (continuing?)
|
||||
(lambda (stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ id expr ...)
|
||||
(identifier? (syntax id))
|
||||
|
|
@ -1784,7 +1853,7 @@
|
|||
stx
|
||||
(syntax id)
|
||||
"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)
|
||||
(proc #t))))
|
||||
|
||||
|
|
@ -1796,6 +1865,9 @@
|
|||
(let ([mk
|
||||
(lambda (who target-stx)
|
||||
(lambda (stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ q expr ...)
|
||||
(let ([exprs (syntax->list (syntax (expr ...)))])
|
||||
|
|
@ -1816,7 +1888,7 @@
|
|||
"expected a question expression after `~a', but nothing's there"
|
||||
who)]
|
||||
[_else
|
||||
(bad-use-error who stx)])))])
|
||||
(bad-use-error who stx)])))))])
|
||||
(values (mk 'when (quote-syntax when))
|
||||
(mk 'unless (quote-syntax unless)))))
|
||||
|
||||
|
|
@ -1832,6 +1904,9 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (advanced-let/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ name ids body)
|
||||
(identifier/non-kw? (syntax name))
|
||||
|
|
@ -1846,7 +1921,7 @@
|
|||
[(_ . rest)
|
||||
(syntax/loc stx (intermediate-let . rest))]
|
||||
[_else
|
||||
(bad-use-error 'let stx)]))
|
||||
(bad-use-error 'let stx)]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; begin (advanced)
|
||||
|
|
@ -1888,6 +1963,9 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (advanced-case/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(teach-syntax-error
|
||||
|
|
@ -1984,7 +2062,7 @@
|
|||
[else (cons (car clauses) (loop (cdr clauses)))]))])
|
||||
(with-syntax ([clauses clauses])
|
||||
(syntax/loc stx (case v-expr . clauses)))))]
|
||||
[_else (bad-use-error 'case stx)]))
|
||||
[_else (bad-use-error 'case stx)]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; delay (advanced)
|
||||
|
|
@ -1992,6 +2070,9 @@
|
|||
|
||||
(define advanced-delay/proc
|
||||
(lambda (stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(begin
|
||||
|
|
@ -2001,7 +2082,7 @@
|
|||
(syntax->list (syntax (expr ...)))
|
||||
null)
|
||||
(syntax (delay expr ...)))]
|
||||
[_else (bad-use-error 'delay stx)])))
|
||||
[_else (bad-use-error 'delay stx)])))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; shared (advanced)
|
||||
|
|
@ -2012,6 +2093,9 @@
|
|||
|
||||
(define advanced-shared/proc
|
||||
(lambda (stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
;; Helper for the main implementation
|
||||
(define (make-check-cdr name)
|
||||
(with-syntax ([name name])
|
||||
|
|
@ -2080,4 +2164,4 @@
|
|||
[_else (bad-use-error 'shared stx)])
|
||||
|
||||
;; The main implementation
|
||||
(include (build-path up up "mzlib" "private" "shared-body.ss"))))))
|
||||
(include (build-path up up "mzlib" "private" "shared-body.ss"))))))))
|
||||
|
|
|
|||
|
|
@ -65,6 +65,8 @@
|
|||
(htdp-test 9 'app-f (f 4))
|
||||
(htdp-top (define f2 (lambda (y) (+ x y))))
|
||||
(htdp-test 15 'app-f (f 10))
|
||||
(htdp-top-pop 1)
|
||||
(htdp-top-pop 1)
|
||||
|
||||
(htdp-top (define-struct a0 ()))
|
||||
(htdp-top (define-struct a1 (b)))
|
||||
|
|
@ -145,18 +147,21 @@
|
|||
(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-top-pop 1)
|
||||
|
||||
(htdp-top (define an-example-value 12))
|
||||
(htdp-error-test #'(define an-example-value 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-top-pop 1)
|
||||
|
||||
(htdp-top (define (an-example-function x) x))
|
||||
(htdp-error-test #'(define an-example-function 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-top-pop 1)
|
||||
|
||||
(htdp-test #t 'equal? (equal? 1 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 #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)
|
||||
|
|
|
|||
|
|
@ -23,4 +23,6 @@
|
|||
(htdp-error-test #'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)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,4 @@
|
|||
|
||||
(define (htdp-syntax-test stx)
|
||||
(syntax-test #`(module m #,current-htdp-lang
|
||||
#,stx)))
|
||||
|
||||
(define body-accum null)
|
||||
(define-syntax (htdp-top stx)
|
||||
(syntax-case stx (quote)
|
||||
|
|
@ -14,6 +10,17 @@
|
|||
null
|
||||
(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)
|
||||
(syntax-case stx ()
|
||||
[(_ expect f . args)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user