diff --git a/collects/mzlib/private/contract-helpers.ss b/collects/mzlib/private/contract-helpers.ss index 5584bb3ad5..9813dc80d0 100644 --- a/collects/mzlib/private/contract-helpers.ss +++ b/collects/mzlib/private/contract-helpers.ss @@ -1,6 +1,7 @@ (module contract-helpers mzscheme - (provide module-source-as-symbol build-src-loc-string mangle-id + (provide module-source-as-symbol build-src-loc-string + mangle-id mangle-id-for-maker build-struct-names nums-up-to add-name-prop @@ -33,6 +34,24 @@ (format "-~a" (syntax-object->datum id))) ids))))))) + (define (mangle-id-for-maker main-stx prefix id . ids) + (let ([id-w/out-make (regexp-replace #rx"^make-" (format "~a" (syntax-object->datum id)) "")]) + (datum->syntax-object + #f + (string->symbol + (string-append + "make-" + prefix + (format + "-~a~a" + id-w/out-make + (apply + string-append + (map + (lambda (id) + (format "-~a" (syntax-object->datum id))) + ids)))))))) + ;; (cons X (listof X)) -> (listof X) ;; returns the elements of `l', minus the last element ;; special case: if l is an improper list, it leaves off diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index cf59a8070a..6b1c3af61c 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -18,6 +18,7 @@ add struct contracts for immutable structs? "contract-opt-guts.ss" (lib "list.ss") (lib "stx.ss" "syntax") + (lib "etc.ss") (lib "name.ss" "syntax")) (require (lib "etc.ss") @@ -461,7 +462,8 @@ add struct contracts for immutable structs? (build-constructor-contract stx field-contract-ids predicate-id) - #f)] + #f + #t)] [(field-contracts ...) field-contracts] [(field-contract-ids ...) field-contract-ids]) (with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))] @@ -548,14 +550,18 @@ add struct contracts for immutable structs? provide-stx struct-name)] [else - (cons (cons (length fields) (constructor->struct-name constructor)) + (cons (cons (length fields) (constructor->struct-name provide-stx constructor)) (loop (list-ref parent-info 5)))]))])))) - (define (constructor->struct-name stx) + (define (constructor->struct-name orig-stx stx) (and stx (let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))]) - (and m - (cadr m))))) + (cond + [m (cadr m)] + [else (raise-syntax-error 'contract.ss + "unable to cope with a struct maker whose name doesn't begin with `make-'" + orig-stx)])))) + ;; extract-parent-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) @@ -626,40 +632,44 @@ add struct contracts for immutable structs? ;; given the syntax for an identifier and a contract, ;; builds a begin expression for the entire contract and provide ;; the first syntax object is used for source locations - (define (code-for-one-id/new-name stx id ctrct user-rename-id) - (with-syntax ([id-rename (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))))) + (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)))))) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) (syntax diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index a1cf55d5c1..16ddbe0cc1 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4874,6 +4874,37 @@ so that propagation occurs. (eval '(require pc18-pos)) (eval '(make-s)))) + (test/spec-passed/result + 'provide/contract19 + '(begin + (eval '(module pc19-a mzscheme + (require (lib "contract.ss")) + (define-struct a (x)) + (provide/contract [struct a ([x number?])]))) + + (eval '(module pc19-b mzscheme + (require pc19-a + (lib "contract.ss")) + (define-struct (b a) (y)) + (provide/contract [struct (b a) ([x number?] [y number?])]))) + + (eval '(module pc19-c mzscheme + (require pc19-b + (lib "contract.ss")) + + (define-struct (c b) (z)) + (provide/contract [struct (c b) ([x number?] [y number?] [z number?])]))) + + (eval' (module pc19-d mzscheme + (require pc19-a pc19-c) + (define pc19-ans (a-x (make-c 1 2 3))) + (provide pc19-ans))) + + (eval '(require pc19-d)) + (eval 'pc19-ans)) + 1) + + (contract-error-test #'(begin (eval '(module pce1-bug mzscheme