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

Syncing.

Browse Source 
svn: r12756
This commit is contained in:
Stevie Strickland 2008-12-09 20:07:43 +00:00
commit 61b66c0d9c
17 changed files with 299 additions and 275 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/framework/gui-utils.ss
View File

@ -110,7 +110,7 @@
;; end choices-canvas% ;; end choices-canvas%
(define (cancel-on-right?) (eq? (system-type) 'windows)) (define (cancel-on-right?) (system-position-ok-before-cancel?))
(define ok/cancel-buttons (define ok/cancel-buttons
(lambda (parent (lambda (parent
@ -334,6 +334,8 @@
@{Returns @scheme[#t] if cancel should be on the right-hand side (or below) @{Returns @scheme[#t] if cancel should be on the right-hand side (or below)
in a dialog and @scheme[#f] otherwise. in a dialog and @scheme[#f] otherwise.
Just returns what @scheme[system-position-ok-before-cancel?] does.
See also @scheme[gui-utils:ok/cancel-buttons].}) See also @scheme[gui-utils:ok/cancel-buttons].})
(proc-doc/names (proc-doc/names
gui-utils:ok/cancel-buttons gui-utils:ok/cancel-buttons

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

4
collects/planet/lang/reader.ss
View File

@ -29,7 +29,9 @@
`(planet ,(string->symbol (string-append str lang-mod))) `(planet ,(string->symbol (string-append str lang-mod)))
#f))]) #f))])
(if parsed-spec (if parsed-spec
(dynamic-require parsed-spec export-sym (mk-fail-thunk spec)) (begin
((current-reader-guard) parsed-spec)
(dynamic-require parsed-spec export-sym (mk-fail-thunk spec)))
(bad (cadr spec) #f)))))) (bad (cadr spec) #f))))))
(define (get-info in mod line col pos) (define (get-info in mod line col pos)

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "8dec2008") #lang scheme/base (provide stamp) (define stamp "9dec2008")

4
collects/tests/typed-scheme/unit-tests/subtype-tests.ss
View File

@ -23,6 +23,8 @@
(begin (test-suite "Tests for subtyping" (begin (test-suite "Tests for subtyping"
new-cl ...))))])) new-cl ...))))]))
(infer-param infer)
(define (subtype-tests) (define (subtype-tests)
(subtyping-tests (subtyping-tests
;; trivial examples ;; trivial examples
@ -121,6 +123,8 @@
(FAIL (-poly (a b) (-> a a)) (-poly (a b) (-> a b))) (FAIL (-poly (a b) (-> a a)) (-poly (a b) (-> a b)))
;; polymorphic function types should be subtypes of the function top
[(-poly (a) (a . -> . a)) top-func]
)) ))
(define-go (define-go

301
collects/typed-scheme/infer/infer-unit.ss
View File

@ -251,154 +251,157 @@
(parameterize ([match-equality-test type-equal?] (parameterize ([match-equality-test type-equal?]
[current-seen (remember S T (current-seen))]) [current-seen (remember S T (current-seen))])
(match* (match*
(S T) (S T)
[(a a) empty] [(a a) empty]
[(_ (Univ:)) empty] [(_ (Univ:)) empty]
[((F: (? (lambda (e) (memq e X)) v)) S) [((F: (? (lambda (e) (memq e X)) v)) S)
(when (match S (when (match S
[(F: v*) [(F: v*)
(just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))] (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))]
[_ #f]) [_ #f])
(fail! S T)) (fail! S T))
(singleton (Un) v (var-demote S V))] (singleton (Un) v (var-demote S V))]
[(S (F: (? (lambda (e) (memq e X)) v))) [(S (F: (? (lambda (e) (memq e X)) v)))
(when (match S (when (match S
[(F: v*) [(F: v*)
(just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))] (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))]
[_ #f]) [_ #f])
(fail! S T)) (fail! S T))
(singleton (var-promote S V) v Univ)] (singleton (var-promote S V) v Univ)]
;; two unions with the same number of elements, so we just try to unify them pairwise ;; two unions with the same number of elements, so we just try to unify them pairwise
#;[((Union: l1) (Union: l2)) #;[((Union: l1) (Union: l2))
(=> unmatch) (=> unmatch)
(unless (= (length l1) (length l2)) (unless (= (length l1) (length l2))
(unmatch)) (unmatch))
(cgen-union V X l1 l2)] (cgen-union V X l1 l2)]
#;[((Poly: v1 b1) (Poly: v2 b2)) #;[((Poly: v1 b1) (Poly: v2 b2))
(unless (= (length v1) (length v2)) (unless (= (length v1) (length v2))
(fail! S T)) (fail! S T))
(let ([b2* (subst-all (map list v2 v1) b2)]) (let ([b2* (subst-all (map list v2 v1) b2)])
(cg b1 b2*))] (cg b1 b2*))]
#;[((PolyDots: (list v1 ... r1) b1) (PolyDots: (list v2 ... r2) b2)) #;[((PolyDots: (list v1 ... r1) b1) (PolyDots: (list v2 ... r2) b2))
(unless (= (length v1) (length v2)) (unless (= (length v1) (length v2))
(fail! S T)) (fail! S T))
(let ([b2* (substitute-dotted v1 v1 v2 (subst-all (map list v2 v1) b2))]) (let ([b2* (substitute-dotted v1 v1 v2 (subst-all (map list v2 v1) b2))])
(cg b1 b2*))] (cg b1 b2*))]
[((Poly: v1 b1) T) [((Poly: v1 b1) T)
(cgen (append v1 V) X b1 T)] (cgen (append v1 V) X b1 T)]
#;[((PolyDots: (list v1 ... r1) b1) T) #;[((PolyDots: (list v1 ... r1) b1) T)
(let ([b1* (var-demote b1 (cons r1 v1))]) (let ([b1* (var-demote b1 (cons r1 v1))])
(cg b1* T))] (cg b1* T))]
#; #;
[((Poly-unsafe: n b) (Poly-unsafe: n* b*)) [((Poly-unsafe: n b) (Poly-unsafe: n* b*))
(unless (= n n*) (unless (= n n*)
(fail! S T)) (fail! S T))
(cg b b*)] (cg b b*)]
[((Union: es) S) (cset-meet* (cons empty (for/list ([e es]) (cg e S))))] [((Union: es) S) (cset-meet* (cons empty (for/list ([e es]) (cg e S))))]
;; we might want to use multiple csets here, but I don't think it makes a difference ;; we might want to use multiple csets here, but I don't think it makes a difference
[(S (Union: es)) (or [(S (Union: es)) (or
(for/or (for/or
([e es]) ([e es])
(with-handlers (with-handlers
([exn:infer? (lambda _ #f)]) ([exn:infer? (lambda _ #f)])
(cg S e))) (cg S e)))
(fail! S T))] (fail! S T))]
[((Struct: nm p flds proc _ _ _) (Struct: nm p flds* proc* _ _ _)) [((Struct: nm p flds proc _ _ _) (Struct: nm p flds* proc* _ _ _))
(let-values ([(flds flds*) (let-values ([(flds flds*)
(cond [(and proc proc*) (cond [(and proc proc*)
(values (cons proc flds) (cons proc* flds*))] (values (cons proc flds) (cons proc* flds*))]
[(or proc proc*) [(or proc proc*)
(fail! S T)] (fail! S T)]
[else (values flds flds*)])]) [else (values flds flds*)])])
(cgen/list V X flds flds*))] (cgen/list V X flds flds*))]
[((Name: n) (Name: n*)) [((Name: n) (Name: n*))
(if (free-identifier=? n n*) (if (free-identifier=? n n*)
null null
(fail! S T))] (fail! S T))]
[((Pair: a b) (Pair: a* b*)) [((Pair: a b) (Pair: a* b*))
(cset-meet (cg a a*) (cg b b*))] (cset-meet (cg a a*) (cg b b*))]
;; if we have two mu's, we rename them to have the same variable ;; if we have two mu's, we rename them to have the same variable
;; and then compare the bodies ;; and then compare the bodies
[((Mu-unsafe: s) (Mu-unsafe: t)) [((Mu-unsafe: s) (Mu-unsafe: t))
(cg s t)] (cg s t)]
;; other mu's just get unfolded ;; other mu's just get unfolded
[(s (? Mu? t)) (cg s (unfold t))] [(s (? Mu? t)) (cg s (unfold t))]
[((? Mu? s) t) (cg (unfold s) t)] [((? Mu? s) t) (cg (unfold s) t)]
;; type application ;; type application
[((App: (Name: n) args _) [((App: (Name: n) args _)
(App: (Name: n*) args* _)) (App: (Name: n*) args* _))
(unless (free-identifier=? n n*) (unless (free-identifier=? n n*)
(fail! S T)) (fail! S T))
(let ([x (instantiate-poly (lookup-type-name n) args)] (let ([x (instantiate-poly (lookup-type-name n) args)]
[y (instantiate-poly (lookup-type-name n) args*)]) [y (instantiate-poly (lookup-type-name n) args*)])
(cg x y))] (cg x y))]
[((Values: ss) (Values: ts)) [((Values: ss) (Values: ts))
(unless (= (length ss) (length ts)) (unless (= (length ss) (length ts))
(fail! ss ts)) (fail! ss ts))
(cgen/list V X ss ts)] (cgen/list V X ss ts)]
[((Values: ss) (ValuesDots: ts t-dty dbound)) [((Values: ss) (ValuesDots: ts t-dty dbound))
(unless (>= (length ss) (length ts)) (unless (>= (length ss) (length ts))
(fail! ss ts)) (fail! ss ts))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(let* ([num-vars (- (length ss) (length ts))] (let* ([num-vars (- (length ss) (length ts))]
[vars (for/list ([n (in-range num-vars)]) [vars (for/list ([n (in-range num-vars)])
(gensym dbound))] (gensym dbound))]
[new-tys (for/list ([var vars]) [new-tys (for/list ([var vars])
(substitute (make-F var) dbound t-dty))] (substitute (make-F var) dbound t-dty))]
[new-cset (cgen/list V (append vars X) ss (append ts new-tys))]) [new-cset (cgen/list V (append vars X) ss (append ts new-tys))])
(move-vars-to-dmap new-cset dbound vars))] (move-vars-to-dmap new-cset dbound vars))]
[((ValuesDots: ss s-dty dbound) (Values: ts)) [((ValuesDots: ss s-dty dbound) (Values: ts))
(unless (>= (length ts) (length ss)) (unless (>= (length ts) (length ss))
(fail! ss ts)) (fail! ss ts))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(let* ([num-vars (- (length ts) (length ss))] (let* ([num-vars (- (length ts) (length ss))]
[vars (for/list ([n (in-range num-vars)]) [vars (for/list ([n (in-range num-vars)])
(gensym dbound))] (gensym dbound))]
[new-tys (for/list ([var vars]) [new-tys (for/list ([var vars])
(substitute (make-F var) dbound s-dty))] (substitute (make-F var) dbound s-dty))]
[new-cset (cgen/list V (append vars X) (append ss new-tys) ts)]) [new-cset (cgen/list V (append vars X) (append ss new-tys) ts)])
(move-vars-to-dmap new-cset dbound vars))] (move-vars-to-dmap new-cset dbound vars))]
[((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound)) [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound))
(when (memq dbound X) (fail! ss ts)) (when (memq dbound X) (fail! ss ts))
(cgen/list V X (cons s-dty ss) (cons t-dty ts))] (cgen/list V X (cons s-dty ss) (cons t-dty ts))]
[((Vector: e) (Vector: e*)) [((Vector: e) (Vector: e*))
(cset-meet (cg e e*) (cg e* e))] (cset-meet (cg e e*) (cg e* e))]
[((Box: e) (Box: e*)) [((Box: e) (Box: e*))
(cset-meet (cg e e*) (cg e* e))] (cset-meet (cg e e*) (cg e* e))]
[((Hashtable: s1 s2) (Hashtable: t1 t2)) [((Hashtable: s1 s2) (Hashtable: t1 t2))
;; the key is covariant, the value is invariant ;; the key is covariant, the value is invariant
(cset-meet* (list (cg s1 t1) (cg t2 s2) (cg s2 t2)))] (cset-meet* (list (cg s1 t1) (cg t2 s2) (cg s2 t2)))]
[((Syntax: s1) (Syntax: s2)) [((Syntax: s1) (Syntax: s2))
(cg s1 s2)] (cg s1 s2)]
;; parameters are just like one-arg functions ;; parameters are just like one-arg functions
[((Param: in1 out1) (Param: in2 out2)) [((Param: in1 out1) (Param: in2 out2))
(cset-meet (cg in2 in1) (cg out1 out2))] (cset-meet (cg in2 in1) (cg out1 out2))]
[((Function: (list t-arr ...)) [((Function: _)
(Function: (list s-arr ...))) (Function: (list (top-arr:))))
(=> unmatch) empty]
(cset-combine [((Function: (list t-arr ...))
(filter (Function: (list s-arr ...)))
values ;; only generate the successful csets (=> unmatch)
(for*/list (cset-combine
([t-arr t-arr] [s-arr s-arr]) (filter
(with-handlers ([exn:infer? (lambda (_) #f)]) values ;; only generate the successful csets
(cgen/arr V X t-arr s-arr)))))] (for*/list
[(_ _) ([t-arr t-arr] [s-arr s-arr])
(cond [(subtype S T) empty] (with-handlers ([exn:infer? (lambda (_) #f)])
;; or, nothing worked, and we fail (cgen/arr V X t-arr s-arr)))))]
[else (fail! S T)])])))) [(_ _)
(cond [(subtype S T) empty]
;; or, nothing worked, and we fail
[else (fail! S T)])]))))
(define (check-vars must-vars subst) (define (check-vars must-vars subst)
(and (for/and ([v must-vars]) (and (for/and ([v must-vars])
@ -488,4 +491,4 @@
(define (i s t r) (define (i s t r)
(infer/simple (list s) (list t) r)) (infer/simple (list s) (list t) r))
;(trace cgen/arr #;cgen #;cgen/list) ;(trace cgen)

4
collects/typed-scheme/private/base-env.ss
View File

@ -90,7 +90,7 @@
[symbol? (make-pred-ty Sym)] [symbol? (make-pred-ty Sym)]
[list? (make-pred-ty (-lst Univ))] [list? (make-pred-ty (-lst Univ))]
[list (-poly (a) (->* '() a (-lst a)))] [list (-poly (a) (->* '() a (-lst a)))]
[procedure? (make-pred-ty (make-Function (list (make-top-arr))))] [procedure? (make-pred-ty top-func)]
[map (-polydots (c a b) ((list ((list a) (b b) . ->... . c) (-lst a)) [map (-polydots (c a b) ((list ((list a) (b b) . ->... . c) (-lst a))
((-lst b) b) . ->... .(-lst c)))] ((-lst b) b) . ->... .(-lst c)))]
[for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . Univ) (-lst a)) [for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . Univ) (-lst a))
@ -561,4 +561,4 @@
;; string.ss ;; string.ss
[real->decimal-string (N [-Nat] . ->opt . -String)] [real->decimal-string (N [-Nat] . ->opt . -String)]
[current-continuation-marks (-> -Cont-Mark-Set)] [current-continuation-marks (-> -Cont-Mark-Set)]

2
collects/typed-scheme/private/base-types.ss
View File

@ -27,5 +27,5 @@
[Boxof (-poly (a) (make-Box a))] [Boxof (-poly (a) (make-Box a))]
[Syntax Any-Syntax] [Syntax Any-Syntax]
[Identifier Ident] [Identifier Ident]
[Procedure (make-Function (list (make-top-arr)))] [Procedure top-func]

4
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -17,11 +17,13 @@
(provide (all-defined-out) (provide (all-defined-out)
;; these should all eventually go away ;; these should all eventually go away
make-Name make-ValuesDots make-Function make-top-arr make-Latent-Restrict-Effect make-Latent-Remove-Effect) make-Name make-ValuesDots make-Function make-Latent-Restrict-Effect make-Latent-Remove-Effect)
(define (one-of/c . args) (define (one-of/c . args)
(apply Un (map -val args))) (apply Un (map -val args)))
(define top-func (make-Function (list (make-top-arr))))
(define (-vet id) (make-Var-True-Effect id)) (define (-vet id) (make-Var-True-Effect id))
(define (-vef id) (make-Var-False-Effect id)) (define (-vef id) (make-Var-False-Effect id))

8
collects/typed/net/cgi.ss
View File

@ -3,13 +3,14 @@
(require typed/private/utils) (require typed/private/utils)
(require-typed-struct cgi-error () net/cgi) (require-typed-struct cgi-error () net/cgi)
(require-typed-struct incomplete-%-suffix ([chars : (Listof Char)]) net/cgi) (require-typed-struct (incomplete-%-suffix cgi-error) ([chars : (Listof Char)]) net/cgi)
(require-typed-struct invalid-%-suffix ([char : Char]) net/cgi) (require-typed-struct (invalid-%-suffix cgi-error) ([char : Char]) net/cgi)
(require/typed/provide net/cgi (require/typed/provide net/cgi
[get-bindings (-> (Listof (cons (U Symbol String) String)))] [get-bindings (-> (Listof (cons (U Symbol String) String)))]
[get-bindings/post (-> (Listof (Pair (U Symbol String) String)))] [get-bindings/post (-> (Listof (Pair (U Symbol String) String)))]
[get-bindings/get (-> (Listof (Pair (U Symbol String) String)) )] [get-bindings/get (-> (Listof (Pair (U Symbol String) String)))]
[output-http-headers (-> Void)] [output-http-headers (-> Void)]
[generate-html-output (case-lambda (String (Listof String) -> Void) [generate-html-output (case-lambda (String (Listof String) -> Void)
(String (Listof String) String String String String String -> Void))] (String (Listof String) String String String String String -> Void))]
@ -21,6 +22,7 @@
[string->html (String -> String)] [string->html (String -> String)]
[generate-link-text (String String -> String)]) [generate-link-text (String String -> String)])
(provide (provide
(struct-out cgi-error) (struct-out cgi-error)
(struct-out incomplete-%-suffix) (struct-out incomplete-%-suffix)

2
collects/typed/net/cookie.ss
View File

@ -18,6 +18,6 @@
[get-cookie (String String -> (Listof String))] [get-cookie (String String -> (Listof String))]
[get-cookie/single (String String -> (Option String))]) [get-cookie/single (String String -> (Option String))])
(require-typed-struct cookie-error () net/cookie) (require-typed-struct (cookie-error exn:fail) () net/cookie)
(provide Cookie cookie? (struct-out cookie-error)) (provide Cookie cookie? (struct-out cookie-error))

55
collects/typed/net/mime.ss
View File

@ -30,42 +30,35 @@
;; -- exceptions raised -- ;; -- exceptions raised --
(require/typed mime-error? (Any -> Boolean : (Opaque mime-error?)) net/mime) #|
(require/typed unexpected-termination? (Any -> Boolean :(Opaque unexpected-termination?)) net/mime) (require-typed-struct mime-error () net/mime)
(require/typed unexpected-termination-msg ((Opaque unexpected-termination?) -> message) net/mime) (require-typed-struct (unexpected-termination mime-error) ([msg : String]) net/mime)
(require/typed missing-multipart-boundary-parameter? (Any -> Boolean : (Opaque missing-multipart-boundary-parameter?)) net/mime) (require-typed-struct (missing-multipart-boundary-parameter mime-error) () net/mime)
(require/typed malformed-multipart-entity? (Any -> Boolean : (Opaque malformed-multipart-entity?)) net/mime) (require-typed-struct (malformed-multipart-entity mime-error) ([msg : String]) net/mime)
(require/typed malformed-multipart-entity-msg ((Opaque malformed-multipart-entity?)-> message) net/mime) (require-typed-struct (empty-mechanism mime-error) () net/mime)
(require/typed empty-mechanism? (Any -> Boolean : (Opaque empty-mechanism?)) net/mime) (require-typed-struct (empty-type mime-error) () net/mime)
(require/typed empty-type? (Any -> Boolean : (Opaque empty-type?)) net/mime) (require-typed-struct (empty-subtype mime-error) () net/mime)
(require/typed empty-subtype? (Any -> Boolean : (Opaque empty-subtype?)) net/mime) (require-typed-struct (empty-disposition-type mime-error) () net/mime)
(require/typed empty-disposition-type? (Any -> Boolean : (Opaque empty-disposition-type?)) net/mime) |#
;; -- mime methods -- ;; -- mime methods --
(require/typed/provide net/mime (require/typed/provide net/mime
[mime-analyze ((U Bytes Input-Port) Any -> message)]) [mime-analyze ((U Bytes Input-Port) Any -> message)])
(provide (provide
;; -- exceptions raised --
mime-error?
unexpected-termination?
unexpected-termination-msg
missing-multipart-boundary-parameter?
malformed-multipart-entity?
malformed-multipart-entity-msg
empty-mechanism?
empty-type?
empty-subtype?
empty-disposition-type?
;; -- basic mime structures -- ;; -- basic mime structures --
message (struct-out message)
entity (struct-out entity)
(struct-out disposition)
disposition #|
(struct-out mime-error)
;; -- mime methods -- (struct-out unexpected-termination)
mime-analyze (struct-out missing-multipart-boundary)
) (struct-out malformed-multipart-entity)
(struct-out empty-mechanism)
(struct-out empty-type)
(struct-out empty-subtype)
(struct-out empty-disposition-type)
|#
)

34
collects/typed/net/nntp.ss
View File

@ -2,8 +2,9 @@
(require typed/private/utils) (require typed/private/utils)
(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number]) (require-typed-struct/provide
net/nntp) communicator ([sender : Number] [receiver : Number] [server : String] [port : Number])
net/nntp)
(require/typed/provide net/nntp (require/typed/provide net/nntp
[connect-to-server (case-lambda (String -> communicator) (String Number -> communicator))] [connect-to-server (case-lambda (String -> communicator) (String Number -> communicator))]
@ -14,18 +15,17 @@
[body-of-message (communicator Number -> (Listof String))] [body-of-message (communicator Number -> (Listof String))]
[newnews-since (communicator Number -> (Listof String))] [newnews-since (communicator Number -> (Listof String))]
[generic-message-command (communicator Number -> (Listof String))] [generic-message-command (communicator Number -> (Listof String))]
[make-desired-header (String -> String)] ;;-> Regexp [make-desired-header (String -> String)]
[extract-desired-headers ((Listof String) (Listof String) -> (Listof String))]) ;;2nd: Of Regexp [extract-desired-headers ((Listof String) (Listof String) -> (Listof String))])
#|
;; requires structure inheritance (require-typed-struct/provide (nntp exn:fail) () net/nntp)
(require-typed-struct nntp ()] (require-typed-struct/provide (unexpected-response nntp) ([code : Number] [text : String]) net/nntp)
(require-typed-struct unexpected-response ([code : Number] [text : String])] (require-typed-struct/provide (bad-status-line nntp) ([line : String]) net/nntp)
(require-typed-struct bad-status-line ([line : String])] (require-typed-struct/provide (premature-close nntp) ([communicator : communicator]) net/nntp)
(require-typed-struct premature-close ([communicator : communicator])] (require-typed-struct/provide (bad-newsgroup-line nntp) ([line : String]) net/nntp)
(require-typed-struct bad-newsgroup-line ([line : String])] (require-typed-struct/provide (non-existent-group nntp) ([group : String]) net/nntp)
(require-typed-struct non-existent-group ([group : String])] (require-typed-struct/provide (article-not-in-group nntp) ([article : Number]) net/nntp)
(require-typed-struct article-not-in-group ([article : Number])] (require-typed-struct/provide (no-group-selected nntp) () net/nntp)
(require-typed-struct no-group-selected ()] (require-typed-struct/provide (article-not-found nntp) ([article : Number]) net/nntp)
(require-typed-struct article-not-found ([article : Number])] (require-typed-struct/provide (authentication-rejected nntp) () net/nntp)
(require-typed-struct authentication-rejected ()]
|#

60
collects/typed/net/pop3.ss
View File

@ -2,37 +2,43 @@
(require typed/private/utils) (require typed/private/utils)
(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number] [state : Symbol])net/pop3) (require-typed-struct/provide communicator
([sender : Number] [receiver : Number] [server : String] [port : Number] [state : Symbol])
net/pop3)
(require/typed/provide net/pop3 (require/typed/provide net/pop3
[connect-to-server ( case-lambda (String -> (Opaque communicator?)) (String Number -> (Opaque communicator?)) )] [connect-to-server (case-lambda (String -> communicator) (String Number -> communicator))]
[disconnect-from-server ( (Opaque communicator?) -> Void )] [disconnect-from-server (communicator -> Void)]
[authenticate/plain-text ( String String (Opaque communicator?) -> Void )] [authenticate/plain-text (String String communicator -> Void)]
[get-mailbox-status ( (Opaque communicator?) -> (values Number Number) )] [get-mailbox-status (communicator -> (values Number Number))]
[get-message/complete ( (Opaque communicator?) Number -> (values (Listof String)(Listof String)) )] [get-message/complete (communicator Number -> (values (Listof String)(Listof String)))]
[get-message/headers ( (Opaque communicator?) Number -> (Listof String) )] [get-message/headers (communicator Number -> (Listof String))]
[get-message/body ( (Opaque communicator?) Number -> (Listof String) )] [get-message/body (communicator Number -> (Listof String))]
[delete-message ( (Opaque communicator?) Number -> Void )] [delete-message (communicator Number -> Void)]
[get-unique-id/single ( (Opaque communicator?) Number -> String )] [get-unique-id/single (communicator Number -> String)]
[get-unique-id/all ( (Opaque communicator?) -> (Listof (cons Number String)) )] [get-unique-id/all (communicator -> (Listof (cons Number String)))]
[make-desired-header ( String -> String )];-> Regexp [make-desired-header (String -> String)]
[extract-desired-headers ( (Listof String)(Listof String)-> (Listof String) )];2nd:of Regexp [extract-desired-headers ((Listof String)(Listof String)-> (Listof String))])
)
(provide (struct-out communicator))
(require-typed-struct/provide (pop3 exn) () net/pop3)
(require-typed-struct/provide (cannot-connect pop3) () net/pop3)
(require-typed-struct/provide (username-rejected pop3) () net/pop3)
(require-typed-struct/provide (password-rejected pop3) () net/pop3)
(require-typed-struct/provide (not-ready-for-transaction pop3)
([communicator : communicator]) net/pop3)
(require-typed-struct/provide (not-given-headers pop3)
([communicator : communicator] [message : Integer]) net/pop3)
(require-typed-struct/provide (illegal-message-number pop3)
([communicator : communicator] [message : Integer]) net/pop3)
(require-typed-struct/provide (cannot-delete-message pop3)
([communicator : communicator] [message : Integer]) net/pop3)
(require-typed-struct/provide (disconnect-not-quiet pop3)
([communicator : communicator]) net/pop3)
(require-typed-struct/provide (malformed-server-response pop3)
([communicator : communicator]) net/pop3)
#|
(require-typed-struct pop3 ()]
(require-typed-struct cannot-connect ()]
(require-typed-struct username-rejected ()]
(require-typed-struct password-rejected ()]
(require-typed-struct not-ready-for-transaction ([ communicator : (Opaque communicator?) ])net/pop3)
(require-typed-struct not-given-headers ([ communicator : (Opaque communicator?) ] [message : String])]
(require-typed-struct illegal-message-number ([communicator : (Opaque communicator?)] [message : String])]
(require-typed-struct cannot-delete-message ([communicator : (Opaque communicator?)] [message : String])]
(require-typed-struct disconnect-not-quiet ([communicator : (Opaque communicator?)])]
(require-typed-struct malformed-server-response ([communicator : (Opaque communicator?)])net/pop3)
|#

27
collects/typed/net/url.ss
View File

@ -2,19 +2,21 @@
(require typed/private/utils) (require typed/private/utils)
(require-typed-struct path/param ([path : (U String 'up 'same)] [param : (Listof String)]) net/url) (require-typed-struct/provide path/param ([path : (U String 'up 'same)] [param : (Listof String)]) net/url)
(require-typed-struct url ([scheme : (Option String)] (require-typed-struct/provide
[user : (Option String)] url ([scheme : (Option String)]
[host : (Option String)] [user : (Option String)]
[port : (Option Integer)] [host : (Option String)]
[path-absolute? : Boolean] [port : (Option Integer)]
[path : (Listof path/param)] [path-absolute? : Boolean]
[query : (Listof (Pair Symbol (Option String)))] [path : (Listof path/param)]
[fragment : (Option String)]) [query : (Listof (Pair Symbol (Option String)))]
net/url) [fragment : (Option String)])
net/url)
(require/opaque-type URL-Exception url-exception? net/url) (require/opaque-type URL-Exception url-exception? net/url)
(provide URL-Exception url-exception?)
(define-type-alias PortT (case-lambda (url -> Input-Port) (url (Listof String)-> Input-Port))) (define-type-alias PortT (case-lambda (url -> Input-Port) (url (Listof String)-> Input-Port)))
(define-type-alias PortT/String (case-lambda (url String -> Input-Port) (url String (Listof String)-> Input-Port))) (define-type-alias PortT/String (case-lambda (url String -> Input-Port) (url String (Listof String)-> Input-Port)))
@ -52,8 +54,3 @@
[url->string (url -> String)] [url->string (url -> String)]
[combine-url/relative (url String -> url)]) [combine-url/relative (url String -> url)])
(provide
URL-Exception
url-exception?
(struct-out url)
(struct-out path/param))

11
collects/typed/private/utils.ss
View File

@ -8,4 +8,13 @@
(require/typed lib [nm t] ...) (require/typed lib [nm t] ...)
(provide nm ...))) (provide nm ...)))
(provide dt require/typed/provide) (define-syntax require-typed-struct/provide
(syntax-rules ()
[(_ (nm par) . rest)
(begin (require-typed-struct (nm par) . rest)
(provide (struct-out nm)))]
[(_ nm . rest)
(begin (require-typed-struct nm . rest)
(provide (struct-out nm)))]))
(provide dt require/typed/provide require-typed-struct/provide)

1
src/mzscheme/src/lightning/ppc/core-common.h
View File

@ -609,6 +609,7 @@ static jit_state _jit;
#define jit_boaddi_l(label, rs, is) jit_boaddi_i((label), (rs), (is)) #define jit_boaddi_l(label, rs, is) jit_boaddi_i((label), (rs), (is))
#define jit_bosubr_l(label, s1, s2) jit_bosubr_i((label), (s1), (s2)) #define jit_bosubr_l(label, s1, s2) jit_bosubr_i((label), (s1), (s2))
#define jit_bosubi_l(label, rs, is) jit_bosubi_i((label), (rs), (is)) #define jit_bosubi_l(label, rs, is) jit_bosubi_i((label), (rs), (is))
#define jit_bomulr_l(label, s1, s2) jit_bomulr_i((label), (s1), (s2))
#define jit_bltr_ul(label, s1, s2) jit_bltr_ui((label), (s1), (s2)) #define jit_bltr_ul(label, s1, s2) jit_bltr_ui((label), (s1), (s2))
#define jit_blti_ul(label, rs, is) jit_blti_ui((label), (rs), (is)) #define jit_blti_ul(label, rs, is) jit_blti_ui((label), (rs), (is))
#define jit_bler_ul(label, s1, s2) jit_bler_ui((label), (s1), (s2)) #define jit_bler_ul(label, s1, s2) jit_bler_ui((label), (s1), (s2))