suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removing the work that's now on unit-contracts.

Browse Source 
svn: r12744

original commit: 52b76b8dfafcb2f284db19fd6d9b3c8da87420ce
This commit is contained in:
Stevie Strickland 2008-12-08 17:09:33 +00:00
commit 2c7fb0cd5f
1 changed files with 10 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/mzlib/unit.ss
View File

@ -123,8 +123,7 @@
(define-for-syntax (build-val+macro-defs sig) (define-for-syntax (build-val+macro-defs sig)
(with-syntax ([(((int-ivar . ext-ivar) ...) (with-syntax ([(((int-ivar . ext-ivar) ...)
((((int-vid . ext-vid) ...) . vbody) ...) ((((int-vid . ext-vid) ...) . vbody) ...)
((((int-sid . ext-sid) ...) . sbody) ...) ((((int-sid . ext-sid) ...) . sbody) ...))
(((int-cid . ext-cid) . cbody) ...))
(map-sig (lambda (x) x) (map-sig (lambda (x) x)
(make-syntax-introducer) (make-syntax-introducer)
sig)]) sig)])
@ -165,17 +164,13 @@
(cons (map syntax-local-introduce (car d)) (cons (map syntax-local-introduce (car d))
(syntax-local-introduce (cdr 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 ;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object
(define-for-syntax (build-define-signature sigid super-sigid sig-exprs) (define-for-syntax (build-define-signature sigid super-sigid sig-exprs)
(unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs))
(raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
(let ([ses (checked-syntax->list sig-exprs)]) (let ([ses (checked-syntax->list sig-exprs)])
(define-values (super-names super-ctimes super-rtimes super-bindings (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 (if super-sigid
(let* ([super-sig (lookup-signature super-sigid)] (let* ([super-sig (lookup-signature super-sigid)]
[super-siginfo (signature-siginfo super-sig)]) [super-siginfo (signature-siginfo super-sig)])
@ -185,20 +180,17 @@
(siginfo-rtime-ids super-siginfo)) (siginfo-rtime-ids super-siginfo))
(map syntax-local-introduce (signature-vars super-sig)) (map syntax-local-introduce (signature-vars super-sig))
(map introduce-def (signature-val-defs super-sig)) (map introduce-def (signature-val-defs super-sig))
(map introduce-def (signature-stx-defs super-sig)) (map introduce-def (signature-stx-defs super-sig))))
(map introduce-ctc-pair (signature-ctc-pairs super-sig)))) (values '() '() '() '() '() '())))
(values '() '() '() '() '() '() '())))
(let loop ((sig-exprs ses) (let loop ((sig-exprs ses)
(bindings null) (bindings null)
(val-defs null) (val-defs null)
(stx-defs null) (stx-defs null))
(ctc-pairs null))
(cond (cond
((null? sig-exprs) ((null? sig-exprs)
(let* ([all-bindings (append super-bindings (reverse bindings))] (let* ([all-bindings (append super-bindings (reverse bindings))]
[all-val-defs (append super-val-defs (reverse val-defs))] [all-val-defs (append super-val-defs (reverse val-defs))]
[all-stx-defs (append super-stx-defs (reverse stx-defs))] [all-stx-defs (append super-stx-defs (reverse stx-defs))]
[all-ctc-pairs (append super-ctc-pairs (reverse ctc-pairs))]
[dup [dup
(check-duplicate-identifier (check-duplicate-identifier
(append all-bindings (append all-bindings
@ -210,8 +202,7 @@
((super-name ...) super-names) ((super-name ...) super-names)
((var ...) all-bindings) ((var ...) all-bindings)
((((vid ...) . vbody) ...) all-val-defs) ((((vid ...) . vbody) ...) all-val-defs)
((((sid ...) . sbody) ...) all-stx-defs) ((((sid ...) . sbody) ...) all-stx-defs))
(((cid . cbody) ...) all-ctc-pairs))
#`(begin #`(begin
(define signature-tag (gensym)) (define signature-tag (gensym))
(define-syntax #,sigid (define-syntax #,sigid
@ -230,25 +221,12 @@
((syntax-local-certifier) ((syntax-local-certifier)
(quote-syntax sbody))) (quote-syntax sbody)))
...) ...)
(list (cons (quote-syntax cid)
((syntax-local-certifier)
(quote-syntax cbody)))
...)
(quote-syntax #,sigid)))))))) (quote-syntax #,sigid))))))))
(else (else
(syntax-case (car sig-exprs) (define-values define-syntaxes contracted) (syntax-case (car sig-exprs) (define-values define-syntaxes)
(x (x
(identifier? #'x) (identifier? #'x)
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs ctc-pairs)) (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs))
((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)))
((x . y) ((x . y)
(and (identifier? #'x) (and (identifier? #'x)
(or (module-identifier=? #'x #'define-values) (or (module-identifier=? #'x #'define-values)
@ -270,8 +248,7 @@
(if (module-identifier=? #'x #'define-syntaxes) (if (module-identifier=? #'x #'define-syntaxes)
(cons (cons (syntax->list #'(name ...)) b) (cons (cons (syntax->list #'(name ...)) b)
stx-defs) stx-defs)
stx-defs) stx-defs))))))))
ctc-pairs)))))))
((x . y) ((x . y)
(let ((trans (let ((trans
(set!-trans-extract (set!-trans-extract
@ -289,8 +266,7 @@
(loop (append results (cdr sig-exprs)) (loop (append results (cdr sig-exprs))
bindings bindings
val-defs val-defs
stx-defs stx-defs))))
ctc-pairs))))
(x (raise-stx-err (x (raise-stx-err
"expected either an identifier or signature form" "expected either an identifier or signature form"
#'x)))))))) #'x))))))))