From 33311ab2114f97ab5e039daa5ce7599dc89d82e4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 14 Sep 2007 21:27:53 +0000 Subject: [PATCH] few minor improvements to the code generated by the contract library svn: r7339 --- collects/mzlib/private/contract-ds.ss | 2 +- collects/mzlib/private/contract-helpers.ss | 10 +- collects/mzlib/private/contract.ss | 190 ++++++++++++++------- collects/tests/mzscheme/contract-test.ss | 14 ++ 4 files changed, 148 insertions(+), 68 deletions(-) diff --git a/collects/mzlib/private/contract-ds.ss b/collects/mzlib/private/contract-ds.ss index 0e679abfc6..d124abc9a6 100644 --- a/collects/mzlib/private/contract-ds.ss +++ b/collects/mzlib/private/contract-ds.ss @@ -142,7 +142,7 @@ it around flattened out. (make-struct-type 'opt-wrap-name #f ;; super struct 2 ;; field count - field-count ;; auto-field-k + (+ 1 field-count) ;; auto-field-k #f ;; auto-field-v '() ;; prop-value-list inspector)) diff --git a/collects/mzlib/private/contract-helpers.ss b/collects/mzlib/private/contract-helpers.ss index 2e2d3a6bbe..26ba0010a9 100644 --- a/collects/mzlib/private/contract-helpers.ss +++ b/collects/mzlib/private/contract-helpers.ss @@ -5,10 +5,18 @@ build-struct-names nums-up-to add-name-prop - all-but-last) + all-but-last + known-good-contract?) (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) (cond [(identifier? name) diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index b85cc910df..cd44e9b91c 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -85,34 +85,68 @@ improve method arity mismatch contract violation error messages? (make-set!-transformer (λ (stx) (with-syntax ([contract-id contract-id] - [id id] - [pos-module-source pos-module-source]) - (syntax-case stx (set!) - [(set! id body) (raise-syntax-error - #f - "cannot set! provide/contract identifier" - stx - (syntax id))] - [(name arg ...) - (syntax/loc stx - ((begin-lifted - (-contract contract-id - id - pos-module-source - (module-source-as-symbol #'name) - (quote-syntax name))) - arg - ...))] - [name - (identifier? (syntax name)) - (syntax - (begin-lifted + [id id] + [pos-module-source pos-module-source]) + (syntax-case stx (set!) + [(set! id body) (raise-syntax-error + #f + "cannot set! provide/contract identifier" + stx + (syntax id))] + [(name arg ...) + (syntax/loc stx + ((begin-lifted + (-contract contract-id + id + pos-module-source + (module-source-as-symbol #'name) + (quote-syntax name))) + arg + ...))] + [name + (identifier? (syntax name)) + (syntax + (begin-lifted (-contract contract-id id pos-module-source (module-source-as-symbol #'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) ;; defines `id' with `contract'; initially binding ;; 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) #f (car (car pp)))))] - [field-contract-ids (map (λ (field-name) - (a:mangle-id provide-stx - "provide/contract-field-contract" - field-name - struct-name)) - field-names)] + [field-contract-ids (map (λ (field-name field-contract) + (if (a:known-good-contract? field-contract) + field-contract + (a:mangle-id provide-stx + "provide/contract-field-contract" + field-name + struct-name))) + field-names + field-contracts)] [struct:struct-name (datum->syntax-object struct-name @@ -464,8 +501,19 @@ improve method arity mismatch contract violation error messages? predicate-id) #f #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-contract-ids ...) field-contract-ids]) + (with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))] [(rev-mutator-new-names ...) (reverse (syntax->list (syntax (mutator-new-names ...))))]) (with-syntax ([struct-code @@ -496,7 +544,7 @@ improve method arity mismatch contract violation error messages? (syntax/loc stx (begin struct-code - (define field-contract-ids (verify-contract field-contracts)) ... + field-contract-id-definitions ... selector-codes ... mutator-codes ... predicate-code @@ -634,49 +682,59 @@ improve method arity mismatch contract violation error messages? ;; the first syntax object is used for source locations (define code-for-one-id/new-name (opt-lambda (stx id ctrct user-rename-id [mangle-for-maker? #f]) - (with-syntax ([id-rename ((if mangle-for-maker? - a:mangle-id-for-maker - a:mangle-id) - provide-stx - "provide/contract-id" - (or user-rename-id id))] - [contract-id (a:mangle-id provide-stx - "provide/contract-contract-id" - (or user-rename-id id))] - [pos-module-source (a:mangle-id provide-stx - "provide/contract-pos-module-source" - (or user-rename-id id))] - [pos-stx (datum->syntax-object id 'here)] - [id id] - [ctrct (syntax-property ctrct 'inferred-name id)] - [external-name (or user-rename-id id)] - [where-stx stx]) - (with-syntax ([code - (syntax/loc stx - (begin - (provide (rename id-rename external-name)) - - (define pos-module-source (module-source-as-symbol #'pos-stx)) - (define contract-id (verify-contract ctrct)) - - (define-syntax id-rename - (make-provide/contract-transformer (quote-syntax contract-id) - (quote-syntax id) - (quote-syntax pos-module-source)))))]) - - (syntax-local-lift-module-end-declaration - #'(begin - (-contract contract-id id pos-module-source 'ignored #'id) - (void))) - - (syntax (code id-rename)))))) + (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]) + (with-syntax ([id-rename ((if mangle-for-maker? + a:mangle-id-for-maker + a:mangle-id) + provide-stx + "provide/contract-id" + (or user-rename-id id))] + [contract-id (if no-need-to-check-ctrct? + ctrct + (a:mangle-id provide-stx + "provide/contract-contract-id" + (or user-rename-id id)))] + [pos-module-source (a:mangle-id provide-stx + "provide/contract-pos-module-source" + (or user-rename-id id))] + [pos-stx (datum->syntax-object id 'here)] + [id id] + [ctrct (syntax-property ctrct 'inferred-name id)] + [external-name (or user-rename-id id)] + [where-stx stx]) + (with-syntax ([code + (quasisyntax/loc stx + (begin + (provide (rename id-rename external-name)) + + (define pos-module-source (module-source-as-symbol #'pos-stx)) + #,@(if no-need-to-check-ctrct? + (list) + (list #'(define contract-id (verify-contract ctrct)))) + + (define-syntax id-rename + (make-provide/contract-transformer (quote-syntax contract-id) + (quote-syntax id) + (quote-syntax pos-module-source)))))]) + + (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 ...))))]) (syntax (begin 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) (and (procedure? x) (procedure-arity-includes? x 1))) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 84b0cdcd61..b1bf78ec81 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -5151,6 +5151,20 @@ so that propagation occurs. [struct s ([a number?] [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 #'(begin (eval '(module pce1-bug mzscheme