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

Adding current unit contract work over here.

Browse Source 
svn: r12743
This commit is contained in:
Stevie Strickland 2008-12-08 17:06:53 +00:00
parent 8c4789a627
commit bf5dddbd13
2 changed files with 53 additions and 14 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,8 +57,10 @@
;; - (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))
;; - (list (listof int/ext) (listof def) (listof def) (listof ctc-pair))
;; A tagged-sig is
;; - (listof (cons #f siginfo) (cons #f identifier) sig)
;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
@ -95,8 +97,9 @@
;; (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 orig-binder)
(define-struct/proc signature (siginfo vars val-defs stx-defs ctc-pairs orig-binder)
(lambda (_ stx)
(parameterize ((error-syntax stx))
(raise-stx-err "illegal use of signature name"))))
@ -219,6 +222,7 @@
(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)])
@ -243,7 +247,12 @@
(cons (map (λ (id) (cons id id))
(car stx))
(cdr stx)))
stxs)))))
stxs)
(map
(λ (cp)
(cons (cons (car cp) (car cp))
(cdr cp)))
cps)))))
(define (sig-names sig)
(append (car sig)
@ -264,12 +273,18 @@
(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-def f g x)) (caddr sig))
(map (lambda (x) (map-ctc-pair f g x)) (cadddr sig))))
;; An import-spec is one of
;; - signature-name

44
collects/mzlib/unit.ss
View File

@ -123,7 +123,8 @@
(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-sid . ext-sid) ...) . sbody) ...)
(((int-cid . ext-cid) . cbody) ...))
(map-sig (lambda (x) x)
(make-syntax-introducer)
sig)])
@ -164,13 +165,17 @@
(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-val-defs super-stx-defs super-ctc-pairs)
(if super-sigid
(let* ([super-sig (lookup-signature super-sigid)]
[super-siginfo (signature-siginfo super-sig)])
@ -180,17 +185,20 @@
(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))))
(values '() '() '() '() '() '())))
(map introduce-def (signature-stx-defs super-sig))
(map introduce-ctc-pair (signature-ctc-pairs super-sig))))
(values '() '() '() '() '() '() '())))
(let loop ((sig-exprs ses)
(bindings null)
(val-defs null)
(stx-defs null))
(stx-defs null)
(ctc-pairs 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
@ -202,7 +210,8 @@
((super-name ...) super-names)
((var ...) all-bindings)
((((vid ...) . vbody) ...) all-val-defs)
((((sid ...) . sbody) ...) all-stx-defs))
((((sid ...) . sbody) ...) all-stx-defs)
(((cid . cbody) ...) all-ctc-pairs))
#`(begin
(define signature-tag (gensym))
(define-syntax #,sigid
@ -221,12 +230,25 @@
((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)
(syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
(x
(identifier? #'x)
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs))
(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)))
((x . y)
(and (identifier? #'x)
(or (module-identifier=? #'x #'define-values)
@ -248,7 +270,8 @@
(if (module-identifier=? #'x #'define-syntaxes)
(cons (cons (syntax->list #'(name ...)) b)
stx-defs)
stx-defs))))))))
stx-defs)
ctc-pairs)))))))
((x . y)
(let ((trans
(set!-trans-extract
@ -266,7 +289,8 @@
(loop (append results (cdr sig-exprs))
bindings
val-defs
stx-defs))))
stx-defs
ctc-pairs))))
(x (raise-stx-err
"expected either an identifier or signature form"
#'x))))))))