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

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

@ -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)
@ -156,15 +159,13 @@
(#,ll-define-data name c1 c2 ...)
#,(loop cnt-list (cdr exprs))))]
[(begin e1 ...)
(loop cnt-list (append (syntax-e (syntax (e1 ...)))(cdr exprs)))]
[_else
(quasisyntax/loc (car exprs)
(begin
#,(car exprs)
#,(loop cnt-list (cdr exprs))))]))])))
(loop cnt-list (append (syntax-e (syntax (e1 ...))) (cdr exprs)))]
[_else
(quasisyntax/loc (car exprs)
(begin
#,(car exprs)
#,(loop cnt-list (cdr exprs))))]))])))
;; contract transformations!
;; this is the macro, abstracted over which language level we are using.
;; parse-contracts :
@ -174,26 +175,76 @@
;; ====>>>> (lang-lvl-contract f (number -> number) ...)
;; where ll-contract is either beginner-contract, intermediate-contract, or advanced-contract
;; and (define-data name ....) to (lang-lvl-define-data name ...)
(lambda (stx)
(syntax-case stx ()
[(_ e1 ...)
(let* ([top-level (syntax-e (syntax (e1 ...)))]
[cnt-list (extract-contracts top-level)]
[expr-list (extract-not-contracts top-level)])
(with-syntax ([rest (parse-contract-expressions language-level-contract
language-level-define-data
cnt-list
expr-list)])
(syntax/loc stx (#%plain-module-begin rest))))])))
(values
;; module-begin (for a specific language:)
(lambda (stx)
(syntax-case stx ()
[(_ 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)])
(parse-contract-expressions language-level-contract
language-level-define-data
cnt-list
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))))

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

File diff suppressed because it is too large Load Diff

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

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

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

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

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