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

adjust the implementation of 'contract-out' so that it does some

Browse Source 
checking of the syntax (that it can) and then just throws everything
to the end of the module, instead of trying to have it figure out
what the actually provided variables are at the beginning.

closes PR 12295
This commit is contained in:
Robby Findler 2011-10-24 07:13:37 -05:00
parent ab45f4f1db
commit a1654f1532
3 changed files with 153 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/racket/contract/private/out.rkt
View File

@ -17,30 +17,13 @@
(raise-syntax-error #f (raise-syntax-error #f
"allowed only in relative phase-level 0" "allowed only in relative phase-level 0"
stx)) stx))
;; lifts need to go after lifts for `provide's:
(define lifts null) ;; check for syntax errors
;; use `provide/contract' expander: (true-provide/contract stx #t 'contract-out)
(let ([expanded (true-provide/contract stx (lambda (stx)
(set! lifts (cons stx lifts))))]) (syntax-case stx ()
;; pull out `provide's to return, and lift [(_ . args)
;; the rest as a module-end declaration: (syntax-local-lift-module-end-declaration
(define-values (decls provides) #`(provide/contract . args))])
(let loop ([expanded expanded])
(syntax-case expanded (begin provide) #`(combine-out))))
[(begin expr ...)
(let ([boths
(map (lambda (e)
(define-values (ds ps) (loop e))
(cons ds ps))
(syntax->list #'(expr ...)))])
(values (apply append (map car boths))
(apply append (map cdr boths))))]
[(provide p ...)
(values null (syntax->list #'(p ...)))]
[else
(values (list expanded) null)])))
(for ([decl (in-list decls)])
(syntax-local-lift-module-end-declaration decl))
(for ([decl (in-list (reverse lifts))])
(syntax-local-lift-module-end-declaration decl))
#`(combine-out #,@provides)))))

160
collects/racket/contract/private/provide.rkt
View File

@ -92,8 +92,8 @@
[name (identifier? #'name) #'saved-id] [name (identifier? #'name) #'saved-id]
[(set! id arg) [(set! id arg)
(raise-syntax-error (raise-syntax-error
'provide/contract 'contract/out
"cannot set! a provide/contract variable" "cannot set! a contract/out variable"
stx #'id)] stx #'id)]
[(name . more) [(name . more)
(with-syntax ([app (datum->syntax stx '#%app)]) (with-syntax ([app (datum->syntax stx '#%app)])
@ -103,7 +103,7 @@
;; expressions: ;; expressions:
(quasisyntax/loc stx (#%expression #,stx))))))) (quasisyntax/loc stx (#%expression #,stx)))))))
(define-for-syntax (true-provide/contract provide-stx lift-end-declaration) (define-for-syntax (true-provide/contract provide-stx just-check-errors? who)
(syntax-case provide-stx () (syntax-case provide-stx ()
[(_ p/c-ele ...) [(_ p/c-ele ...)
(let () (let ()
@ -131,7 +131,7 @@
[(ormap (λ (x) (bound-identifier=? (car ids) x)) (cdr ids)) [(ormap (λ (x) (bound-identifier=? (car ids) x)) (cdr ids))
(let ([dups (filter (λ (x) (bound-identifier=? (car ids) x)) (let ([dups (filter (λ (x) (bound-identifier=? (car ids) x))
ids)]) ids)])
(raise-syntax-error 'provide/contract (raise-syntax-error who
"duplicate identifiers" "duplicate identifiers"
provide-stx provide-stx
(car dups) (car dups)
@ -154,7 +154,7 @@
(or (eq? '#:exists (syntax-e #'exists)) (eq? '#:∃ (syntax-e #'exists))) (or (eq? '#:exists (syntax-e #'exists)) (eq? '#:∃ (syntax-e #'exists)))
(cond (cond
[(null? (cdr clauses)) [(null? (cdr clauses))
(raise-syntax-error 'provide/conract (raise-syntax-error who
(format "expected either a single variable or a sequence of variables to follow ~a, but found nothing" (format "expected either a single variable or a sequence of variables to follow ~a, but found nothing"
(syntax-e #'exists)) (syntax-e #'exists))
provide-stx provide-stx
@ -163,27 +163,31 @@
(syntax-case (cadr clauses) () (syntax-case (cadr clauses) ()
[x [x
(identifier? #'x) (identifier? #'x)
(with-syntax ([(x-gen) (generate-temporaries #'(x))]) (if just-check-errors?
(cons (code-for-one-exists-id #'x #'x-gen) (loop (cddr clauses) exists-binders)
(loop (cddr clauses) (with-syntax ([(x-gen) (generate-temporaries #'(x))])
(add-a-binder #'x #'x-gen exists-binders))))] (cons (code-for-one-exists-id #'x #'x-gen)
(loop (cddr clauses)
(add-a-binder #'x #'x-gen exists-binders)))))]
[(x ...) [(x ...)
(andmap identifier? (syntax->list #'(x ...))) (andmap identifier? (syntax->list #'(x ...)))
(with-syntax ([(x-gen ...) (generate-temporaries #'(x ...))]) (if just-check-errors?
(append (map code-for-one-exists-id (loop (cddr clauses) exists-binders)
(syntax->list #'(x ...)) (with-syntax ([(x-gen ...) (generate-temporaries #'(x ...))])
(syntax->list #'(x-gen ...))) (append (map code-for-one-exists-id
(loop (cddr clauses) (syntax->list #'(x ...))
(let loop ([binders exists-binders] (syntax->list #'(x-gen ...)))
[xs (syntax->list #'(x ...))] (loop (cddr clauses)
[x-gens (syntax->list #'(x-gen ...))]) (let loop ([binders exists-binders]
(cond [xs (syntax->list #'(x ...))]
[(null? xs) binders] [x-gens (syntax->list #'(x-gen ...))])
[else (loop (add-a-binder (car xs) (car x-gens) binders) (cond
(cdr xs) [(null? xs) binders]
(cdr x-gens))])))))] [else (loop (add-a-binder (car xs) (car x-gens) binders)
(cdr xs)
(cdr x-gens))]))))))]
[else [else
(raise-syntax-error 'provide/contract (raise-syntax-error who
(format "expected either a single variable or a sequence of variables to follow ~a" (format "expected either a single variable or a sequence of variables to follow ~a"
(syntax-e #'exists)) (syntax-e #'exists))
provide-stx provide-stx
@ -193,44 +197,50 @@
(identifier? (syntax new-name))) (identifier? (syntax new-name)))
(begin (begin
(add-to-dups-table #'new-name) (add-to-dups-table #'new-name)
(cons (code-for-one-id provide-stx (if just-check-errors?
(syntax this-name) #f (loop (cdr clauses) exists-binders)
(add-exists-binders (syntax contract) exists-binders) (cons (code-for-one-id provide-stx
(syntax new-name)) (syntax this-name) #f
(loop (cdr clauses) exists-binders)))] (add-exists-binders (syntax contract) exists-binders)
(syntax new-name))
(loop (cdr clauses) exists-binders))))]
[(rename this-name new-name contract) [(rename this-name new-name contract)
(identifier? (syntax this-name)) (identifier? (syntax this-name))
(raise-syntax-error 'provide/contract (raise-syntax-error who
"malformed rename clause, expected an identifier" "malformed rename clause, expected an identifier"
provide-stx provide-stx
(syntax new-name))] (syntax new-name))]
[(rename this-name new-name contract) [(rename this-name new-name contract)
(identifier? (syntax new-name)) (identifier? (syntax new-name))
(raise-syntax-error 'provide/contract (raise-syntax-error who
"malformed rename clause, expected an identifier" "malformed rename clause, expected an identifier"
provide-stx provide-stx
(syntax this-name))] (syntax this-name))]
[(rename . _) [(rename . _)
(raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)] (raise-syntax-error who "malformed rename clause" provide-stx clause)]
[(struct struct-name ((field-name contract) ...)) [(struct struct-name ((field-name contract) ...))
(and (well-formed-struct-name? (syntax struct-name)) (and (well-formed-struct-name? (syntax struct-name))
(andmap identifier? (syntax->list (syntax (field-name ...))))) (andmap identifier? (syntax->list (syntax (field-name ...)))))
(let ([sc (build-struct-code provide-stx (begin
(syntax struct-name)
(syntax->list (syntax (field-name ...)))
(map (λ (x) (add-exists-binders x exists-binders))
(syntax->list (syntax (contract ...)))))])
(add-to-dups-table #'struct-name) (add-to-dups-table #'struct-name)
(cons sc (loop (cdr clauses) exists-binders)))] (if just-check-errors?
(loop (cdr clauses) exists-binders)
(let ([sc (build-struct-code provide-stx
(syntax struct-name)
(syntax->list (syntax (field-name ...)))
(map (λ (x) (add-exists-binders x exists-binders))
(syntax->list (syntax (contract ...)))))])
(cons sc (loop (cdr clauses) exists-binders)))))]
[(struct name) [(struct name)
(identifier? (syntax name)) (identifier? (syntax name))
(raise-syntax-error 'provide/contract (raise-syntax-error who
"missing fields" "missing fields"
provide-stx provide-stx
clause)] clause)]
[(struct name . rest) [(struct name . rest)
(not (well-formed-struct-name? (syntax name))) (not (well-formed-struct-name? (syntax name)))
(raise-syntax-error 'provide/contract "name must be an identifier or two identifiers with parens around them" (raise-syntax-error who
"name must be an identifier or two identifiers with parens around them"
provide-stx provide-stx
(syntax name))] (syntax name))]
[(struct name (fields ...)) [(struct name (fields ...))
@ -240,21 +250,21 @@
(identifier? (syntax x)) (identifier? (syntax x))
(void)] (void)]
[(x y) [(x y)
(raise-syntax-error 'provide/contract (raise-syntax-error who
"malformed struct field, expected identifier" "malformed struct field, expected identifier"
provide-stx provide-stx
(syntax x))] (syntax x))]
[else [else
(raise-syntax-error 'provide/contract (raise-syntax-error who
"malformed struct field" "malformed struct field"
provide-stx provide-stx
field)])) field)]))
(syntax->list (syntax (fields ...)))) (syntax->list (syntax (fields ...))))
;; if we didn't find a bad field something is wrong! ;; if we didn't find a bad field something is wrong!
(raise-syntax-error 'provide/contract "internal error.1" provide-stx clause)] (raise-syntax-error who "internal error.1" provide-stx clause)]
[(struct name . fields) [(struct name . fields)
(raise-syntax-error 'provide/contract (raise-syntax-error who
"malformed struct fields" "malformed struct fields"
provide-stx provide-stx
clause)] clause)]
@ -262,19 +272,21 @@
(identifier? (syntax name)) (identifier? (syntax name))
(begin (begin
(add-to-dups-table #'name) (add-to-dups-table #'name)
(cons (code-for-one-id provide-stx (if just-check-errors?
(syntax name) #f (loop (cdr clauses) exists-binders)
(add-exists-binders (syntax contract) (cons (code-for-one-id provide-stx
exists-binders) (syntax name) #f
#f) (add-exists-binders (syntax contract)
(loop (cdr clauses) exists-binders)))] exists-binders)
#f)
(loop (cdr clauses) exists-binders))))]
[(name contract) [(name contract)
(raise-syntax-error 'provide/contract (raise-syntax-error who
"expected identifier" "expected identifier"
provide-stx provide-stx
(syntax name))] (syntax name))]
[unk [unk
(raise-syntax-error 'provide/contract (raise-syntax-error who
"malformed clause" "malformed clause"
provide-stx provide-stx
(syntax unk))]))]))) (syntax unk))]))])))
@ -355,7 +367,7 @@
(let ([unknown-info (let ([unknown-info
(λ (what names) (λ (what names)
(raise-syntax-error (raise-syntax-error
'provide/contract who
(format "cannot determine ~a, found ~s" what names) (format "cannot determine ~a, found ~s" what names)
provide-stx provide-stx
struct-name))]) struct-name))])
@ -375,7 +387,7 @@
(unless (equal? (length selector-ids) (unless (equal? (length selector-ids)
(length field-contract-ids)) (length field-contract-ids))
(raise-syntax-error 'provide/contract (raise-syntax-error who
(format "found ~a field~a in struct, but ~a contract~a" (format "found ~a field~a in struct, but ~a contract~a"
(length selector-ids) (length selector-ids)
(if (= 1 (length selector-ids)) "" "s") (if (= 1 (length selector-ids)) "" "s")
@ -415,7 +427,7 @@
(string-length selector-str))] (string-length selector-str))]
[field-name-is (format "~a" (syntax-e field-name))]) [field-name-is (format "~a" (syntax-e field-name))])
(unless (equal? field-name-should-be field-name-is) (unless (equal? field-name-should-be field-name-is)
(raise-syntax-error 'provide/contract (raise-syntax-error who
(format "expected field name to be ~a, but found ~a" (format "expected field name to be ~a, but found ~a"
field-name-should-be field-name-should-be
field-name-is) field-name-is)
@ -591,7 +603,7 @@
[(and (not (null? fields)) [(and (not (null? fields))
(not (last fields))) (not (last fields)))
(raise-syntax-error (raise-syntax-error
'provide/contract who
"cannot determine the number of fields in super struct" "cannot determine the number of fields in super struct"
provide-stx provide-stx
struct-name)] struct-name)]
@ -604,7 +616,7 @@
(let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))]) (let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))])
(cond (cond
[m (cadr m)] [m (cadr m)]
[else (raise-syntax-error 'contract-base.rkt [else (raise-syntax-error who
"unable to cope with a struct supertype whose predicate doesn't end with `?'" "unable to cope with a struct supertype whose predicate doesn't end with `?'"
orig-stx)])))) orig-stx)]))))
@ -720,7 +732,7 @@
'provide/contract-original-contract 'provide/contract-original-contract
(vector #'external-name #'ctrct))]) (vector #'external-name #'ctrct))])
(lift-end-declaration (syntax-local-lift-module-end-declaration
#`(begin #`(begin
(unless extra-test (unless extra-test
(contract contract-id id pos-module-source 'ignored 'id (contract contract-id id pos-module-source 'ignored 'id
@ -758,21 +770,25 @@
struct-id-mapping struct-id-mapping
selector-id selector-id
(id-for-one-id #f #f selector-id)))))) (id-for-one-id #f #f selector-id))))))
(for ([clause (in-list p/c-clauses)])
(syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(struct a ((fld ctc) ...))
(identifier? #'a)
(add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))]
[(struct (a b) ((fld ctc) ...))
(add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
[_ (void)]))
(with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]) (cond
(signal-dup-syntax-error) [just-check-errors?
(syntax (code-for-each-clause p/c-clauses)
(begin (signal-dup-syntax-error)]
(define pos-module-source (quote-module-name)) [else
bodies ...))))])) (for ([clause (in-list p/c-clauses)])
(syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(struct a ((fld ctc) ...))
(identifier? #'a)
(add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))]
[(struct (a b) ((fld ctc) ...))
(add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
[_ (void)]))
(with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)])
(syntax
(begin
(define pos-module-source (quote-module-name))
bodies ...)))]))]))
(define-syntax (provide/contract stx) (define-syntax (provide/contract stx)
(define s-l-c (syntax-local-context)) (define s-l-c (syntax-local-context))
@ -781,7 +797,7 @@
#`(begin (define-values () (values)) ;; force us into the 'module' local context #`(begin (define-values () (values)) ;; force us into the 'module' local context
#,stx)] #,stx)]
[(module) ;; the good case [(module) ;; the good case
(true-provide/contract stx syntax-local-lift-module-end-declaration)] (true-provide/contract stx #f 'provide/contract)]
[else ;; expression or internal definition [else ;; expression or internal definition
(raise-syntax-error 'provide/contract (raise-syntax-error 'provide/contract
(format "not allowed in a ~a context" (format "not allowed in a ~a context"

65
collects/tests/racket/contract-test.rktl
View File

@ -67,6 +67,7 @@
(void) (void)
(let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
(list ',new-expression '(void))))))) (list ',new-expression '(void)))))))
(let/ec k (let/ec k
(contract-eval (contract-eval
`(,test (void) `(,test (void)
@ -85,16 +86,40 @@
',(rewrite expression k))))) ',(rewrite expression k)))))
;; rewrites `provide/contract' to use `contract-out' ;; rewrites `provide/contract' to use `contract-out'
(define (rewrite-out exp) (define (rewrite-out orig-exp)
(let loop ([exp exp]) (let loop ([exp orig-exp])
(cond (match exp
[(null? exp) null] [`(module ,modname ,lang ,bodies ...)
[(list? exp) (define at-beginning '())
(case (car exp)
[(provide/contract) `(provide (contract-out . ,(cdr exp)))] ;; remove (and save) the provide/contract declarations
[else (map loop exp)])] (define removed-bodies
[(pair? exp) (cons (loop (car exp)) (apply
(loop (cdr exp)))] append
(for/list ([body (in-list bodies)])
(match body
[`(provide/contract . ,args)
(set! at-beginning (cons `(provide (contract-out . ,args))
at-beginning))
(list)]
[else
(list body)]))))
;; insert the provide/contract (rewrite to contract-out) after the
;; first require that has 'contract' in it
(define inserted-bodies
(apply
append
(for/list ([body (in-list removed-bodies)])
(match body
[`(require ,(? (λ (x) (and (symbol? x) (regexp-match #rx"contract" (symbol->string x)))) mod))
(cons body (reverse at-beginning))]
[else
(list body)]))))
`(module ,modname ,lang ,@inserted-bodies)]
[(? list?)
(map loop exp)]
[else exp]))) [else exp])))
;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test. ;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test.
@ -11625,6 +11650,26 @@ so that propagation occurs.
(eval '(f 10))) (eval '(f 10)))
11) 11)
(test/spec-passed/result
'contract-out2
'(begin
(eval '(module contract-out2-m racket/base
(require racket/contract)
(provide (contract-out (struct s ([x integer?]))))
(struct s (x))))
(eval '(require 'contract-out2-m))
(eval '(s-x (s 11))))
11)
;; expect the syntax errors in the right order
(contract-syntax-error-test
'contract-out3
'(eval '(module contract-out3-m racket/base
(require racket/contract)
(provide (contract-out garbage))
(λ)))
#rx"contract-out")
; ;
; ;
; ;