From 4d8f6fdeb0bd1b2f24d7d027bc72fd4ded843f83 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 9 Jan 2009 19:50:28 +0000 Subject: [PATCH] Tag the contracts so we know what are truly contracts and which are just placeholder #fs. svn: r13048 original commit: af69c0bbeccf2fab5e11b104cd8bb3a686f343f9 --- collects/mzlib/unit.ss | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index b5fe0fc..8509d92 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -514,7 +514,12 @@ [((eloc ...) ...) (map (lambda (x) (generate-temporaries (car x))) export-sigs)] [((ectc ...) ...) - (map cadddr export-sigs)] + (map (λ (sig) + (map (λ (ctc) + (if ctc + (cons 'contract ctc) + #f)) + (cadddr sig))) export-sigs)] [((import-key import-super-keys ...) ...) (map tagged-info->keys import-tagged-infos)] [((export-key ...) ...) @@ -673,10 +678,12 @@ (when (var-info-syntax? v) (raise-stx-err "cannot export syntax from a unit" name)) (set-var-info-exported?! v loc) - (set-var-info-add-ctc! v (lambda (e) - #`(if #,ctc - (contract #,ctc #,e '#,unit-name 'cant-happen #,(id->contract-src-info var)) - #,e))))) + (when (pair? (syntax-e ctc)) + (set-var-info-add-ctc! + v + (λ (e) + #`(contract #,(cdr (syntax-e ctc)) #,e '#,unit-name + 'cant-happen #,(id->contract-src-info var))))))) (syntax->list (localify #'evars def-ctx)) (syntax->list #'elocs) (syntax->list #'ext-evars)