diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 079764d012..f05c7f8691 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -57,10 +57,8 @@ ;; - (cons identifier identifier) ;; A def is ;; - (listof (cons (listof int/ext) syntax-object)) - ;; A ctc-pair is - ;; - (cons int/ext syntax-object) ;; A sig is - ;; - (list (listof int/ext) (listof def) (listof def) (listof ctc-pair)) + ;; - (list (listof int/ext) (listof def) (listof def)) ;; A tagged-sig is ;; - (listof (cons #f siginfo) (cons #f identifier) sig) ;; - (listof (cons symbol siginfo) (cons symbol identifier) sig) @@ -97,9 +95,8 @@ ;; (listof identifier) ;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object)) - ;; (listof (cons identifier syntax-object)) ;; identifier) - (define-struct/proc signature (siginfo vars val-defs stx-defs ctc-pairs orig-binder) + (define-struct/proc signature (siginfo vars val-defs stx-defs orig-binder) (lambda (_ stx) (parameterize ((error-syntax stx)) (raise-stx-err "illegal use of signature name")))) @@ -222,7 +219,6 @@ (vars (signature-vars sig)) (vals (signature-val-defs sig)) (stxs (signature-stx-defs sig)) - (cps (signature-ctc-pairs sig)) (delta-introduce (if bind? (let ([f (syntax-local-make-delta-introducer spec)]) @@ -247,12 +243,7 @@ (cons (map (λ (id) (cons id id)) (car stx)) (cdr stx))) - stxs) - (map - (λ (cp) - (cons (cons (car cp) (car cp)) - (cdr cp))) - cps))))) + stxs))))) (define (sig-names sig) (append (car sig) @@ -273,18 +264,12 @@ (car def)) (g (cdr def)))) - ;; map-ctc-pair : (identifier -> identifier) (syntax-object -> syntax-object) ctc-pair -> ctc-pair - (define (map-ctc-pair f g cp) - (cons (cons (f (caar cp)) (g (cdar cp))) - (g (cdr cp)))) - ;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig ;; applies f to the internal parts, and g to the external parts. (define (map-sig f g sig) (list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig)) (map (lambda (x) (map-def f g x)) (cadr sig)) - (map (lambda (x) (map-def f g x)) (caddr sig)) - (map (lambda (x) (map-ctc-pair f g x)) (cadddr sig)))) + (map (lambda (x) (map-def f g x)) (caddr sig)))) ;; An import-spec is one of ;; - signature-name diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 48ba22921b..593155f322 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -123,8 +123,7 @@ (define-for-syntax (build-val+macro-defs sig) (with-syntax ([(((int-ivar . ext-ivar) ...) ((((int-vid . ext-vid) ...) . vbody) ...) - ((((int-sid . ext-sid) ...) . sbody) ...) - (((int-cid . ext-cid) . cbody) ...)) + ((((int-sid . ext-sid) ...) . sbody) ...)) (map-sig (lambda (x) x) (make-syntax-introducer) sig)]) @@ -165,17 +164,13 @@ (cons (map syntax-local-introduce (car d)) (syntax-local-introduce (cdr d)))) - (define-for-syntax (introduce-ctc-pair cp) - (cons (syntax-local-introduce (car cp)) - (syntax-local-introduce (cdr cp)))) - ;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object (define-for-syntax (build-define-signature sigid super-sigid sig-exprs) (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) (let ([ses (checked-syntax->list sig-exprs)]) (define-values (super-names super-ctimes super-rtimes super-bindings - super-val-defs super-stx-defs super-ctc-pairs) + super-val-defs super-stx-defs) (if super-sigid (let* ([super-sig (lookup-signature super-sigid)] [super-siginfo (signature-siginfo super-sig)]) @@ -185,20 +180,17 @@ (siginfo-rtime-ids super-siginfo)) (map syntax-local-introduce (signature-vars super-sig)) (map introduce-def (signature-val-defs super-sig)) - (map introduce-def (signature-stx-defs super-sig)) - (map introduce-ctc-pair (signature-ctc-pairs super-sig)))) - (values '() '() '() '() '() '() '()))) + (map introduce-def (signature-stx-defs super-sig)))) + (values '() '() '() '() '() '()))) (let loop ((sig-exprs ses) (bindings null) (val-defs null) - (stx-defs null) - (ctc-pairs null)) + (stx-defs null)) (cond ((null? sig-exprs) (let* ([all-bindings (append super-bindings (reverse bindings))] [all-val-defs (append super-val-defs (reverse val-defs))] [all-stx-defs (append super-stx-defs (reverse stx-defs))] - [all-ctc-pairs (append super-ctc-pairs (reverse ctc-pairs))] [dup (check-duplicate-identifier (append all-bindings @@ -210,8 +202,7 @@ ((super-name ...) super-names) ((var ...) all-bindings) ((((vid ...) . vbody) ...) all-val-defs) - ((((sid ...) . sbody) ...) all-stx-defs) - (((cid . cbody) ...) all-ctc-pairs)) + ((((sid ...) . sbody) ...) all-stx-defs)) #`(begin (define signature-tag (gensym)) (define-syntax #,sigid @@ -230,25 +221,12 @@ ((syntax-local-certifier) (quote-syntax sbody))) ...) - (list (cons (quote-syntax cid) - ((syntax-local-certifier) - (quote-syntax cbody))) - ...) (quote-syntax #,sigid)))))))) (else - (syntax-case (car sig-exprs) (define-values define-syntaxes contracted) + (syntax-case (car sig-exprs) (define-values define-syntaxes) (x (identifier? #'x) - (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs ctc-pairs)) - ((x y z) - (and (identifier? #'x) - (module-identifier=? #'x #'contracted) - (identifier? #'y)) - (loop (cdr sig-exprs) - (cons #'y bindings) - val-defs - stx-defs - (cons (cons #'y #'z) ctc-pairs))) + (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs)) ((x . y) (and (identifier? #'x) (or (module-identifier=? #'x #'define-values) @@ -270,8 +248,7 @@ (if (module-identifier=? #'x #'define-syntaxes) (cons (cons (syntax->list #'(name ...)) b) stx-defs) - stx-defs) - ctc-pairs))))))) + stx-defs)))))))) ((x . y) (let ((trans (set!-trans-extract @@ -289,8 +266,7 @@ (loop (append results (cdr sig-exprs)) bindings val-defs - stx-defs - ctc-pairs)))) + stx-defs)))) (x (raise-stx-err "expected either an identifier or signature form" #'x))))))))