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

Add contracts to unit imports and values imported via

Browse Source 
define-values/invoke-unit.  We still need contracts on unit exports,
and we might want to do the stuff here in a cleaner fashion (particularly
for define-values/invoke-unit).

svn: r12759

original commit: a9be78545d95d72e5076d14369afae8b5774dbad
This commit is contained in:
Stevie Strickland 2008-12-09 22:14:11 +00:00
commit d9d718daa8
2 changed files with 74 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
collects/mzlib/unit.ss
View File

@ -9,7 +9,8 @@
"private/unit-compiletime.ss" "private/unit-compiletime.ss"
"private/unit-syntax.ss") "private/unit-syntax.ss")
(require mzlib/etc (require mzlib/contract
mzlib/etc
"private/unit-keywords.ss" "private/unit-keywords.ss"
"private/unit-runtime.ss") "private/unit-runtime.ss")
@ -124,7 +125,7 @@
(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) ...)) (cbody ...))
(map-sig (lambda (x) x) (map-sig (lambda (x) x)
(make-syntax-introducer) (make-syntax-introducer)
sig)]) sig)])
@ -165,17 +166,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 super-ctcs)
(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)])
@ -186,19 +183,23 @@
(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)))) (map (lambda (ctc)
(if ctc
(syntax-local-introduce ctc)
ctc))
(signature-ctcs 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)) (ctcs 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))] [all-ctcs (append super-ctcs (reverse ctcs))]
[dup [dup
(check-duplicate-identifier (check-duplicate-identifier
(append all-bindings (append all-bindings
@ -210,8 +211,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,16 +230,18 @@
((syntax-local-certifier) ((syntax-local-certifier)
(quote-syntax sbody))) (quote-syntax sbody)))
...) ...)
(list (cons (quote-syntax cid) (list #,@(map (lambda (c)
((syntax-local-certifier) (if c
(quote-syntax cbody))) #`((syntax-local-certifier)
...) (quote-syntax #,c))
#'#f))
all-ctcs))
(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 contracted)
(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 (cons #f ctcs)))
((x y z) ((x y z)
(and (identifier? #'x) (and (identifier? #'x)
(module-identifier=? #'x #'contracted) (module-identifier=? #'x #'contracted)
@ -248,7 +250,7 @@
(cons #'y bindings) (cons #'y bindings)
val-defs val-defs
stx-defs stx-defs
(cons (cons #'y #'z) ctc-pairs))) (cons #'z ctcs)))
((x . y) ((x . y)
(and (identifier? #'x) (and (identifier? #'x)
(or (module-identifier=? #'x #'define-values) (or (module-identifier=? #'x #'define-values)
@ -271,7 +273,7 @@
(cons (cons (syntax->list #'(name ...)) b) (cons (cons (syntax->list #'(name ...)) b)
stx-defs) stx-defs)
stx-defs) stx-defs)
ctc-pairs))))))) ctcs)))))))
((x . y) ((x . y)
(let ((trans (let ((trans
(set!-trans-extract (set!-trans-extract
@ -290,7 +292,7 @@
bindings bindings
val-defs val-defs
stx-defs stx-defs
ctc-pairs)))) ctcs))))
(x (raise-stx-err (x (raise-stx-err
"expected either an identifier or signature form" "expected either an identifier or signature form"
#'x)))))))) #'x))))))))
@ -449,6 +451,13 @@
(define-for-syntax process-unit-export (define-for-syntax process-unit-export
(process-unit-import/export process-tagged-export)) (process-unit-import/export process-tagged-export))
(define-for-syntax (make-import-unboxing loc ctc name)
(if ctc
(quasisyntax/loc (error-syntax)
(quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name)))
(quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc)))))
;; build-unit : syntax-object -> ;; build-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
;; constructs the code for a unit expression. stx must be ;; constructs the code for a unit expression. stx must be
@ -525,11 +534,17 @@
(let-values ([(iloc ...) (let-values ([(iloc ...)
(vector->values (hash-table-get import-table import-key) 0 icount)] (vector->values (hash-table-get import-table import-key) 0 icount)]
...) ...)
(letrec-syntaxes ([(int-ivar ...) (letrec-syntaxes (#,@(map (lambda (ivs ils ics)
(make-id-mappers (quasisyntax/loc (error-syntax)
(quote-syntax (unbox iloc)) [#,ivs
...)] (make-id-mappers
... #,@(map (lambda (l c)
(make-import-unboxing l c #'name))
(syntax->list ils)
ics))]))
(syntax->list #'((int-ivar ...) ...))
(syntax->list #'((iloc ...) ...))
(map cadddr import-sigs))
[(int-evar ...) [(int-evar ...)
(make-id-mappers (make-id-mappers
(quote-syntax (unbox eloc)) (quote-syntax (unbox eloc))
@ -1205,9 +1220,12 @@
(map (map
(lambda (os ov) (lambda (os ov)
(map (map
(lambda (i) (lambda (i c)
#`(vector-ref #,ov #,i)) (if c
(iota (length (car os))))) #`(contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))
#`(unbox (vector-ref #,ov #,i))))
(iota (length (car os)))
(cadddr os)))
out-sigs out-sigs
out-vec))) out-vec)))
(quasisyntax/loc stx (quasisyntax/loc stx
@ -1225,7 +1243,7 @@
((unit-go unit-tmp)))) ((unit-go unit-tmp))))
(let ([out-vec (hash-table-get export-table key1)] ...) (let ([out-vec (hash-table-get export-table key1)] ...)
(unit-fn #f) (unit-fn #f)
(values (unbox out-code) ... ...)))))) (values out-code ... ...))))))
(define-syntaxes . renames) ... (define-syntaxes . renames) ...
(define-syntaxes (mac-name ...) mac-body) ... ... (define-syntaxes (mac-name ...) mac-body) ... ...
(define-values (val-name ...) val-body) ... ...))))) (define-values (val-name ...) val-body) ... ...)))))

51
collects/net/url-unit.ss
View File

@ -103,30 +103,33 @@
;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
(define (http://getpost-impure-port get? url post-data strings) (define (http://getpost-impure-port get? url post-data strings)
(let*-values (define proxy (assoc (url-scheme url) (current-proxy-servers)))
([(proxy) (assoc (url-scheme url) (current-proxy-servers))] (define-values (server->client client->server) (make-ports url proxy))
[(server->client client->server) (make-ports url proxy)] (define access-string
[(access-string) (url->string (url->string
(if proxy (if proxy
url url
(make-url #f #f #f #f ;; RFCs 1945 and 2616 say:
(url-path-absolute? url) ;; Note that the absolute path cannot be empty; if none is present in
(url-path url) ;; the original URI, it must be given as "/" (the server root).
(url-query url) (let-values ([(abs? path)
(url-fragment url))))]) (if (null? (url-path url))
(define (println . xs) (values #t (list (make-path/param "" '())))
(for-each (lambda (x) (display x client->server)) xs) (values (url-path-absolute? url) (url-path url)))])
(display "\r\n" client->server)) (make-url #f #f #f #f abs? path (url-query url) (url-fragment url))))))
(println (if get? "GET " "POST ") access-string " HTTP/1.0") (define (println . xs)
(println "Host: " (url-host url) (for-each (lambda (x) (display x client->server)) xs)
(let ([p (url-port url)]) (if p (format ":~a" p) ""))) (display "\r\n" client->server))
(when post-data (println "Content-Length: " (bytes-length post-data))) (println (if get? "GET " "POST ") access-string " HTTP/1.0")
(for-each println strings) (println "Host: " (url-host url)
(println) (let ([p (url-port url)]) (if p (format ":~a" p) "")))
(when post-data (display post-data client->server)) (when post-data (println "Content-Length: " (bytes-length post-data)))
(flush-output client->server) (for-each println strings)
(tcp-abandon-port client->server) (println)
server->client)) (when post-data (display post-data client->server))
(flush-output client->server)
(tcp-abandon-port client->server)
server->client)
(define (file://->path url [kind (system-path-convention-type)]) (define (file://->path url [kind (system-path-convention-type)])
(let ([strs (map path/param-path (url-path url))] (let ([strs (map path/param-path (url-path url))]