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

Start on adding contracts to units. Here we're just adding contract(ed) forms,

Browse Source 
but they're not (yet) used further in.

svn: r12711
This commit is contained in:
Stevie Strickland 2008-12-05 17:47:37 +00:00
parent 2fc429dbda
commit 1b4d2cb7bf
2 changed files with 34 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -95,8 +95,9 @@
;; (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 orig-binder) (define-struct/proc signature (siginfo vars val-defs stx-defs ctc-pairs 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"))))

41
collects/mzlib/unit.ss
View File

@ -164,13 +164,17 @@
(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-val-defs super-stx-defs super-ctc-pairs)
(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)])
@ -180,17 +184,20 @@
(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))
(values '() '() '() '() '() '()))) (map introduce-ctc-pair (signature-ctc-pairs super-sig))))
(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
@ -202,7 +209,8 @@
((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
@ -221,12 +229,25 @@
((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) (syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
(x (x
(identifier? #'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) ((x . y)
(and (identifier? #'x) (and (identifier? #'x)
(or (module-identifier=? #'x #'define-values) (or (module-identifier=? #'x #'define-values)
@ -248,7 +269,8 @@
(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
@ -266,7 +288,8 @@
(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))))))))