suzanne.soy/racket
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
This commit is contained in:
Stevie Strickland 2008-12-08 17:09:33 +00:00
parent dd5afccd82
commit 52b76b8dfa
2 changed files with 14 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/mzlib/private/unit-compiletime.ss
View File

@ -57,10 +57,8 @@
;; - (cons identifier identifier) ;; - (cons identifier identifier)
;; A def is ;; A def is
;; - (listof (cons (listof int/ext) syntax-object)) ;; - (listof (cons (listof int/ext) syntax-object))
;; A ctc-pair is
;; - (cons int/ext syntax-object)
;; A sig is ;; 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 ;; A tagged-sig is
;; - (listof (cons #f siginfo) (cons #f identifier) sig) ;; - (listof (cons #f siginfo) (cons #f identifier) sig)
;; - (listof (cons symbol siginfo) (cons symbol identifier) sig) ;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
@ -97,9 +95,8 @@
;; (listof identifier) ;; (listof identifier)
;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object))
;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object))
;; (listof (cons identifier syntax-object))
;; identifier) ;; 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) (lambda (_ stx)
(parameterize ((error-syntax stx)) (parameterize ((error-syntax stx))
(raise-stx-err "illegal use of signature name")))) (raise-stx-err "illegal use of signature name"))))
@ -222,7 +219,6 @@
(vars (signature-vars sig)) (vars (signature-vars sig))
(vals (signature-val-defs sig)) (vals (signature-val-defs sig))
(stxs (signature-stx-defs sig)) (stxs (signature-stx-defs sig))
(cps (signature-ctc-pairs sig))
(delta-introduce (if bind? (delta-introduce (if bind?
(let ([f (syntax-local-make-delta-introducer (let ([f (syntax-local-make-delta-introducer
spec)]) spec)])
@ -247,12 +243,7 @@
(cons (map (λ (id) (cons id id)) (cons (map (λ (id) (cons id id))
(car stx)) (car stx))
(cdr stx))) (cdr stx)))
stxs) stxs)))))
(map
(λ (cp)
(cons (cons (car cp) (car cp))
(cdr cp)))
cps)))))
(define (sig-names sig) (define (sig-names sig)
(append (car sig) (append (car sig)
@ -273,18 +264,12 @@
(car def)) (car def))
(g (cdr 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 ;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig
;; applies f to the internal parts, and g to the external parts. ;; applies f to the internal parts, and g to the external parts.
(define (map-sig f g sig) (define (map-sig f g sig)
(list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car 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)) (cadr sig))
(map (lambda (x) (map-def f g x)) (caddr sig)) (map (lambda (x) (map-def f g x)) (caddr sig))))
(map (lambda (x) (map-ctc-pair f g x)) (cadddr sig))))
;; An import-spec is one of ;; An import-spec is one of
;; - signature-name ;; - signature-name

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))))))))