diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index 95a86172db..373bf6ca8a 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -100,10 +100,12 @@ improve method arity mismatch contract violation error messages? ;; Expand to a use of the lifted expression: (with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))]) (syntax-case stx (set!) - [(name arg ...) (syntax/loc stx (saved-id arg ...))] [name (identifier? (syntax name)) - (syntax saved-id)]))) + (syntax saved-id)] + [(name . more) + (with-syntax ([app (datum->syntax-object stx '#%app)]) + (syntax/loc stx (app saved-id . more)))]))) ;; In case of partial expansion for module-level and internal-defn contexts, ;; delay expansion until it's a good time to lift expressions: (quasisyntax/loc stx (#%expression #,stx))))))) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 3abcba5ff8..17790349f0 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -5211,6 +5211,22 @@ so that propagation occurs. (c:case-> (c:-> integer? integer?) (c:-> integer? integer? integer?)))))) + ;; tests that contracts pick up the #%app from the context + ;; instead of always using the mzscheme #%app. + (test/spec-passed + 'provide/contract25 + '(begin + (eval '(module provide/contract25a mzscheme + (require (lib "contract.ss")) + (provide/contract [seventeen integer?]) + (define seventeen 17))) + (eval '(module provide/contract25b mzscheme + (require provide/contract25a) + (let-syntax ([#%app (syntax-rules () + [(#%app e ...) (list e ...)])]) + (seventeen 18)))) + (eval '(require provide/contract25b)))) + (contract-error-test #'(begin (eval '(module pce1-bug mzscheme