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

few minor improvements to the code generated by the contract library

Browse Source 
svn: r7339
This commit is contained in:
Robby Findler 2007-09-14 21:27:53 +00:00
parent e6b71b6c97
commit 33311ab211
4 changed files with 148 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/private/contract-ds.ss
View File

@ -142,7 +142,7 @@ it around flattened out.
(make-struct-type 'opt-wrap-name (make-struct-type 'opt-wrap-name
#f ;; super struct #f ;; super struct
2 ;; field count 2 ;; field count
field-count ;; auto-field-k (+ 1 field-count) ;; auto-field-k
#f ;; auto-field-v #f ;; auto-field-v
'() ;; prop-value-list '() ;; prop-value-list
inspector)) inspector))

10
collects/mzlib/private/contract-helpers.ss
View File

@ -5,10 +5,18 @@
build-struct-names build-struct-names
nums-up-to nums-up-to
add-name-prop add-name-prop
all-but-last) all-but-last
known-good-contract?)
(require (lib "main-collects.ss" "setup")) (require (lib "main-collects.ss" "setup"))
(define (known-good-contract? id)
(and (identifier? id)
(ormap (λ (x) (module-identifier=? x id))
(list #'integer?
#'boolean?
#'number?))))
(define (add-name-prop name stx) (define (add-name-prop name stx)
(cond (cond
[(identifier? name) [(identifier? name)

190
collects/mzlib/private/contract.ss
View File

@ -85,34 +85,68 @@ improve method arity mismatch contract violation error messages?
(make-set!-transformer (make-set!-transformer
(λ (stx) (λ (stx)
(with-syntax ([contract-id contract-id] (with-syntax ([contract-id contract-id]
[id id] [id id]
[pos-module-source pos-module-source]) [pos-module-source pos-module-source])
(syntax-case stx (set!) (syntax-case stx (set!)
[(set! id body) (raise-syntax-error [(set! id body) (raise-syntax-error
#f #f
"cannot set! provide/contract identifier" "cannot set! provide/contract identifier"
stx stx
(syntax id))] (syntax id))]
[(name arg ...) [(name arg ...)
(syntax/loc stx (syntax/loc stx
((begin-lifted ((begin-lifted
(-contract contract-id (-contract contract-id
id id
pos-module-source pos-module-source
(module-source-as-symbol #'name) (module-source-as-symbol #'name)
(quote-syntax name))) (quote-syntax name)))
arg arg
...))] ...))]
[name [name
(identifier? (syntax name)) (identifier? (syntax name))
(syntax (syntax
(begin-lifted (begin-lifted
(-contract contract-id (-contract contract-id
id id
pos-module-source pos-module-source
(module-source-as-symbol #'name) (module-source-as-symbol #'name)
(quote-syntax name))))]))))) (quote-syntax name))))])))))
#;
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
(make-set!-transformer
(let ([saved-id #f])
(λ (stx)
(unless saved-id
(with-syntax ([contract-id contract-id]
[id id]
[pos-module-source pos-module-source])
(set! saved-id
(syntax-local-introduce
(syntax-local-lift-expression
#'(-contract contract-id
id
pos-module-source
(module-source-as-symbol #'name)
(quote-syntax name)))))))
(with-syntax ([saved-id (syntax-local-introduce saved-id)])
(syntax-case stx (set!)
[(set! id body) (raise-syntax-error
#f
"cannot set! provide/contract identifier"
stx
(syntax id))]
[(name arg ...)
(syntax/loc stx
(saved-id
arg
...))]
[name
(identifier? (syntax name))
(syntax saved-id)]))))))
;; (define/contract id contract expr) ;; (define/contract id contract expr)
;; defines `id' with `contract'; initially binding ;; defines `id' with `contract'; initially binding
;; it to the result of `expr'. These variables may not be set!'d. ;; it to the result of `expr'. These variables may not be set!'d.
@ -286,12 +320,15 @@ improve method arity mismatch contract violation error messages?
(if (null? pp) (if (null? pp)
#f #f
(car (car pp)))))] (car (car pp)))))]
[field-contract-ids (map (λ (field-name) [field-contract-ids (map (λ (field-name field-contract)
(a:mangle-id provide-stx (if (a:known-good-contract? field-contract)
"provide/contract-field-contract" field-contract
field-name (a:mangle-id provide-stx
struct-name)) "provide/contract-field-contract"
field-names)] field-name
struct-name)))
field-names
field-contracts)]
[struct:struct-name [struct:struct-name
(datum->syntax-object (datum->syntax-object
struct-name struct-name
@ -464,8 +501,19 @@ improve method arity mismatch contract violation error messages?
predicate-id) predicate-id)
#f #f
#t)] #t)]
[(field-contract-id-definitions ...)
(filter values (map (λ (field-contract-id field-contract)
(if (a:known-good-contract? field-contract)
#f
(with-syntax ([field-contract-id field-contract-id]
[field-contract field-contract])
#'(define field-contract-id (verify-contract field-contract)))))
field-contract-ids
field-contracts))]
[(field-contracts ...) field-contracts] [(field-contracts ...) field-contracts]
[(field-contract-ids ...) field-contract-ids]) [(field-contract-ids ...) field-contract-ids])
(with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))] (with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))]
[(rev-mutator-new-names ...) (reverse (syntax->list (syntax (mutator-new-names ...))))]) [(rev-mutator-new-names ...) (reverse (syntax->list (syntax (mutator-new-names ...))))])
(with-syntax ([struct-code (with-syntax ([struct-code
@ -496,7 +544,7 @@ improve method arity mismatch contract violation error messages?
(syntax/loc stx (syntax/loc stx
(begin (begin
struct-code struct-code
(define field-contract-ids (verify-contract field-contracts)) ... field-contract-id-definitions ...
selector-codes ... selector-codes ...
mutator-codes ... mutator-codes ...
predicate-code predicate-code
@ -634,49 +682,59 @@ improve method arity mismatch contract violation error messages?
;; the first syntax object is used for source locations ;; the first syntax object is used for source locations
(define code-for-one-id/new-name (define code-for-one-id/new-name
(opt-lambda (stx id ctrct user-rename-id [mangle-for-maker? #f]) (opt-lambda (stx id ctrct user-rename-id [mangle-for-maker? #f])
(with-syntax ([id-rename ((if mangle-for-maker? (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)])
a:mangle-id-for-maker (with-syntax ([id-rename ((if mangle-for-maker?
a:mangle-id) a:mangle-id-for-maker
provide-stx a:mangle-id)
"provide/contract-id" provide-stx
(or user-rename-id id))] "provide/contract-id"
[contract-id (a:mangle-id provide-stx (or user-rename-id id))]
"provide/contract-contract-id" [contract-id (if no-need-to-check-ctrct?
(or user-rename-id id))] ctrct
[pos-module-source (a:mangle-id provide-stx (a:mangle-id provide-stx
"provide/contract-pos-module-source" "provide/contract-contract-id"
(or user-rename-id id))] (or user-rename-id id)))]
[pos-stx (datum->syntax-object id 'here)] [pos-module-source (a:mangle-id provide-stx
[id id] "provide/contract-pos-module-source"
[ctrct (syntax-property ctrct 'inferred-name id)] (or user-rename-id id))]
[external-name (or user-rename-id id)] [pos-stx (datum->syntax-object id 'here)]
[where-stx stx]) [id id]
(with-syntax ([code [ctrct (syntax-property ctrct 'inferred-name id)]
(syntax/loc stx [external-name (or user-rename-id id)]
(begin [where-stx stx])
(provide (rename id-rename external-name)) (with-syntax ([code
(quasisyntax/loc stx
(define pos-module-source (module-source-as-symbol #'pos-stx)) (begin
(define contract-id (verify-contract ctrct)) (provide (rename id-rename external-name))
(define-syntax id-rename (define pos-module-source (module-source-as-symbol #'pos-stx))
(make-provide/contract-transformer (quote-syntax contract-id) #,@(if no-need-to-check-ctrct?
(quote-syntax id) (list)
(quote-syntax pos-module-source)))))]) (list #'(define contract-id (verify-contract ctrct))))
(syntax-local-lift-module-end-declaration (define-syntax id-rename
#'(begin (make-provide/contract-transformer (quote-syntax contract-id)
(-contract contract-id id pos-module-source 'ignored #'id) (quote-syntax id)
(void))) (quote-syntax pos-module-source)))))])
(syntax (code id-rename)))))) (syntax-local-lift-module-end-declaration
#'(begin
(-contract contract-id id pos-module-source 'ignored #'id)
(void)))
(syntax (code id-rename)))))))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(syntax (syntax
(begin (begin
bodies ...))))])) bodies ...))))]))
(define (verify-contract x) (define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ x) (a:known-good-contract? #'x) #'x]
[(_ x) #'(verify-contract/proc x)]))
(define (verify-contract/proc x)
(unless (or (contract? x) (unless (or (contract? x)
(and (procedure? x) (and (procedure? x)
(procedure-arity-includes? x 1))) (procedure-arity-includes? x 1)))

14
collects/tests/mzscheme/contract-test.ss
View File

@ -5151,6 +5151,20 @@ so that propagation occurs.
[struct s ([a number?] [struct s ([a number?]
[b symbol?])])))) [b symbol?])]))))
(test/spec-passed
'provide/contract21
'(begin
(eval '(module provide/contract21a mzscheme
(require (lib "contract.ss"))
(provide/contract [f integer?])
(define f 1)))
(eval '(module provide/contract21b mzscheme
(require-for-syntax provide/contract21a)
(define-syntax (unit-body stx)
f f
#'1)))))
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pce1-bug mzscheme (eval '(module pce1-bug mzscheme