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%
(define (cancel-on-right?) (eq? (system-type) 'windows))
(define (cancel-on-right?) (system-position-ok-before-cancel?))
(define ok/cancel-buttons
(lambda (parent
@ -334,6 +334,8 @@
@{Returns @scheme[#t] if cancel should be on the right-hand side (or below)
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].})
(proc-doc/names
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
(define (http://getpost-impure-port get? url post-data strings)
(let*-values
([(proxy) (assoc (url-scheme url) (current-proxy-servers))]
[(server->client client->server) (make-ports url proxy)]
[(access-string) (url->string
(define proxy (assoc (url-scheme url) (current-proxy-servers)))
(define-values (server->client client->server) (make-ports url proxy))
(define access-string
(url->string
(if proxy
url
(make-url #f #f #f #f
(url-path-absolute? url)
(url-path url)
(url-query url)
(url-fragment url))))])
;; RFCs 1945 and 2616 say:
;; Note that the absolute path cannot be empty; if none is present in
;; the original URI, it must be given as "/" (the server root).
(let-values ([(abs? path)
(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)
(for-each (lambda (x) (display x client->server)) xs)
(display "\r\n" client->server))
@ -126,7 +129,7 @@
(when post-data (display post-data client->server))
(flush-output client->server)
(tcp-abandon-port client->server)
server->client))
server->client)
(define (file://->path url [kind (system-path-convention-type)])
(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)))
#f))])
(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))))))
(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"
new-cl ...))))]))
(infer-param infer)
(define (subtype-tests)
(subtyping-tests
;; trivial examples
@ -121,6 +123,8 @@
(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

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

@ -385,6 +385,9 @@
;; parameters are just like one-arg functions
[((Param: in1 out1) (Param: in2 out2))
(cset-meet (cg in2 in1) (cg out1 out2))]
[((Function: _)
(Function: (list (top-arr:))))
empty]
[((Function: (list t-arr ...))
(Function: (list s-arr ...)))
(=> unmatch)
@ -488,4 +491,4 @@
(define (i s 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)]
[list? (make-pred-ty (-lst Univ))]
[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))
((-lst b) b) . ->... .(-lst c)))]
[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))]
[Syntax Any-Syntax]
[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)
;; 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)
(apply Un (map -val args)))
(define top-func (make-Function (list (make-top-arr))))
(define (-vet id) (make-Var-True-Effect id))
(define (-vef id) (make-Var-False-Effect id))

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

@ -3,8 +3,9 @@
(require typed/private/utils)
(require-typed-struct cgi-error () net/cgi)
(require-typed-struct incomplete-%-suffix ([chars : (Listof Char)]) net/cgi)
(require-typed-struct invalid-%-suffix ([char : Char]) net/cgi)
(require-typed-struct (incomplete-%-suffix cgi-error) ([chars : (Listof Char)]) net/cgi)
(require-typed-struct (invalid-%-suffix cgi-error) ([char : Char]) net/cgi)
(require/typed/provide net/cgi
[get-bindings (-> (Listof (cons (U Symbol String) String)))]
@ -21,6 +22,7 @@
[string->html (String -> String)]
[generate-link-text (String String -> String)])
(provide
(struct-out cgi-error)
(struct-out incomplete-%-suffix)

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

@ -18,6 +18,6 @@
[get-cookie (String String -> (Listof 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))

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

@ -30,42 +30,35 @@
;; -- 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 unexpected-termination-msg ((Opaque unexpected-termination?) -> message) net/mime)
(require/typed missing-multipart-boundary-parameter? (Any -> Boolean : (Opaque missing-multipart-boundary-parameter?)) net/mime)
(require/typed malformed-multipart-entity? (Any -> Boolean : (Opaque malformed-multipart-entity?)) net/mime)
(require/typed malformed-multipart-entity-msg ((Opaque malformed-multipart-entity?)-> message) net/mime)
(require/typed empty-mechanism? (Any -> Boolean : (Opaque empty-mechanism?)) net/mime)
(require/typed empty-type? (Any -> Boolean : (Opaque empty-type?)) net/mime)
(require/typed empty-subtype? (Any -> Boolean : (Opaque empty-subtype?)) net/mime)
(require/typed empty-disposition-type? (Any -> Boolean : (Opaque empty-disposition-type?)) net/mime)
#|
(require-typed-struct mime-error () net/mime)
(require-typed-struct (unexpected-termination mime-error) ([msg : String]) net/mime)
(require-typed-struct (missing-multipart-boundary-parameter mime-error) () net/mime)
(require-typed-struct (malformed-multipart-entity mime-error) ([msg : String]) net/mime)
(require-typed-struct (empty-mechanism mime-error) () net/mime)
(require-typed-struct (empty-type mime-error) () net/mime)
(require-typed-struct (empty-subtype mime-error) () net/mime)
(require-typed-struct (empty-disposition-type mime-error) () net/mime)
|#
;; -- mime methods --
(require/typed/provide net/mime
[mime-analyze ((U Bytes Input-Port) Any -> message)])
(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 --
message
entity
disposition
;; -- mime methods --
mime-analyze
(struct-out message)
(struct-out entity)
(struct-out disposition)
#|
(struct-out mime-error)
(struct-out unexpected-termination)
(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-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)
(require/typed/provide net/nntp
@ -14,18 +15,17 @@
[body-of-message (communicator Number -> (Listof String))]
[newnews-since (communicator Number -> (Listof String))]
[generic-message-command (communicator Number -> (Listof String))]
[make-desired-header (String -> String)] ;;-> Regexp
[extract-desired-headers ((Listof String) (Listof String) -> (Listof String))]) ;;2nd: Of Regexp
#|
;; requires structure inheritance
(require-typed-struct nntp ()]
(require-typed-struct unexpected-response ([code : Number] [text : String])]
(require-typed-struct bad-status-line ([line : String])]
(require-typed-struct premature-close ([communicator : communicator])]
(require-typed-struct bad-newsgroup-line ([line : String])]
(require-typed-struct non-existent-group ([group : String])]
(require-typed-struct article-not-in-group ([article : Number])]
(require-typed-struct no-group-selected ()]
(require-typed-struct article-not-found ([article : Number])]
(require-typed-struct authentication-rejected ()]
|#
[make-desired-header (String -> String)]
[extract-desired-headers ((Listof String) (Listof String) -> (Listof String))])
(require-typed-struct/provide (nntp exn:fail) () net/nntp)
(require-typed-struct/provide (unexpected-response nntp) ([code : Number] [text : String]) net/nntp)
(require-typed-struct/provide (bad-status-line nntp) ([line : String]) net/nntp)
(require-typed-struct/provide (premature-close nntp) ([communicator : communicator]) net/nntp)
(require-typed-struct/provide (bad-newsgroup-line nntp) ([line : String]) net/nntp)
(require-typed-struct/provide (non-existent-group nntp) ([group : String]) net/nntp)
(require-typed-struct/provide (article-not-in-group nntp) ([article : Number]) net/nntp)
(require-typed-struct/provide (no-group-selected nntp) () net/nntp)
(require-typed-struct/provide (article-not-found nntp) ([article : Number]) net/nntp)
(require-typed-struct/provide (authentication-rejected nntp) () net/nntp)

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

@ -2,37 +2,43 @@
(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
[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 )]
[authenticate/plain-text ( String String (Opaque communicator?) -> Void )]
[get-mailbox-status ( (Opaque communicator?) -> (values Number Number) )]
[get-message/complete ( (Opaque communicator?) Number -> (values (Listof String)(Listof String)) )]
[get-message/headers ( (Opaque communicator?) Number -> (Listof String) )]
[get-message/body ( (Opaque communicator?) Number -> (Listof String) )]
[delete-message ( (Opaque communicator?) Number -> Void )]
[get-unique-id/single ( (Opaque communicator?) Number -> String )]
[get-unique-id/all ( (Opaque communicator?) -> (Listof (cons Number String)) )]
[disconnect-from-server (communicator -> Void)]
[authenticate/plain-text (String String communicator -> Void)]
[get-mailbox-status (communicator -> (values Number Number))]
[get-message/complete (communicator Number -> (values (Listof String)(Listof String)))]
[get-message/headers (communicator Number -> (Listof String))]
[get-message/body (communicator Number -> (Listof String))]
[delete-message (communicator Number -> Void)]
[get-unique-id/single (communicator 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-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)]
[host : (Option String)]
[port : (Option Integer)]
@ -15,6 +16,7 @@
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/String (case-lambda (url String -> Input-Port) (url String (Listof String)-> Input-Port)))
@ -52,8 +54,3 @@
[url->string (url -> String)]
[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] ...)
(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_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_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_blti_ul(label, rs, is) jit_blti_ui((label), (rs), (is))
#define jit_bler_ul(label, s1, s2) jit_bler_ui((label), (s1), (s2))