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

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

@ -103,17 +103,20 @@
;; 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))
(values #t (list (make-path/param "" '())))
(values (url-path-absolute? url) (url-path url)))])
(make-url #f #f #f #f abs? path (url-query url) (url-fragment url))))))
(define (println . xs) (define (println . xs)
(for-each (lambda (x) (display x client->server)) xs) (for-each (lambda (x) (display x client->server)) xs)
(display "\r\n" client->server)) (display "\r\n" client->server))
@ -126,7 +129,7 @@
(when post-data (display post-data client->server)) (when post-data (display post-data client->server))
(flush-output client->server) (flush-output client->server)
(tcp-abandon-port client->server) (tcp-abandon-port client->server)
server->client)) 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

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

@ -385,6 +385,9 @@
;; 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: _)
(Function: (list (top-arr:))))
empty]
[((Function: (list t-arr ...)) [((Function: (list t-arr ...))
(Function: (list s-arr ...))) (Function: (list s-arr ...)))
(=> unmatch) (=> unmatch)
@ -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)

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

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

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

@ -2,7 +2,8 @@
(require typed/private/utils) (require typed/private/utils)
(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number]) (require-typed-struct/provide
communicator ([sender : Number] [receiver : Number] [server : String] [port : Number])
net/nntp) net/nntp)
(require/typed/provide net/nntp (require/typed/provide net/nntp
@ -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 ()]
|#

62
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)]
[extract-desired-headers ((Listof String)(Listof String)-> (Listof String))])
(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)
[make-desired-header ( String -> String )];-> Regexp
[extract-desired-headers ( (Listof String)(Listof String)-> (Listof String) )];2nd:of Regexp
)
(provide (struct-out communicator))
#|
(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)
|#

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

@ -2,9 +2,10 @@
(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
url ([scheme : (Option String)]
[user : (Option String)] [user : (Option String)]
[host : (Option String)] [host : (Option String)]
[port : (Option Integer)] [port : (Option Integer)]
@ -15,6 +16,7 @@
net/url) 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))