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

A sync a day keeps... actually, it doesn't keep anyone away, and tends to make

Browse Source 
one run into other people's bugs sooner, but OH WELL.

svn: r12543
This commit is contained in:
Stevie Strickland 2008-11-20 19:36:17 +00:00
commit 75c57820da
58 changed files with 1255 additions and 672 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/compiler/decompile.ss
View File

@ -28,12 +28,12 @@
(hash-set! table n (car b)))))
table))
(define (list-ref/protect l pos)
(define (list-ref/protect l pos who)
(list-ref l pos)
#;
(if (pos . < . (length l))
(list-ref l pos)
`(OUT-OF-BOUNDS ,pos ,l)))
`(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l)))
;; ----------------------------------------
@ -44,7 +44,7 @@
(let-values ([(globs defns) (decompile-prefix prefix)])
`(begin
,@defns
,(decompile-form form globs '(#%globals))))]
,(decompile-form form globs '(#%globals) (make-hasheq))))]
[else (error 'decompile "unrecognized: ~e" top)]))
(define (decompile-prefix a-prefix)
@ -76,7 +76,7 @@
lift-ids)
(map (lambda (stx id)
`(define ,id ,(if stx
`(#%decode-syntax ,(stx-encoded stx))
`(#%decode-syntax ,stx #;(stx-encoded stx))
#f)))
stxs stx-ids)))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
@ -90,18 +90,19 @@
(match mod-form
[(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
(let-values ([(globs defns) (decompile-prefix prefix)]
[(stack) (append '(#%modvars) stack)])
[(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)])
`(module ,name ....
,@defns
,@(map (lambda (form)
(decompile-form form globs stack))
(decompile-form form globs stack closed))
syntax-body)
,@(map (lambda (form)
(decompile-form form globs stack))
(decompile-form form globs stack closed))
body)))]
[else (error 'decompile-module "huh?: ~e" mod-form)]))
(define (decompile-form form globs stack)
(define (decompile-form form globs stack closed)
(match form
[(? mod?)
(decompile-module form stack)]
@ -109,31 +110,31 @@
`(define-values ,(map (lambda (tl)
(match tl
[(struct toplevel (depth pos const? mutated?))
(list-ref/protect globs pos)]))
(list-ref/protect globs pos 'def-vals)]))
ids)
,(decompile-expr rhs globs stack))]
,(decompile-expr rhs globs stack closed))]
[(struct def-syntaxes (ids rhs prefix max-let-depth))
`(define-syntaxes ,ids
,(let-values ([(globs defns) (decompile-prefix prefix)])
`(let ()
,@defns
,(decompile-form rhs globs '(#%globals)))))]
,(decompile-form rhs globs '(#%globals) closed))))]
[(struct def-for-syntax (ids rhs prefix max-let-depth))
`(define-values-for-syntax ,ids
,(let-values ([(globs defns) (decompile-prefix prefix)])
`(let ()
,@defns
,(decompile-expr rhs globs '(#%globals)))))]
,(decompile-expr rhs globs '(#%globals) closed))))]
[(struct sequence (forms))
`(begin ,@(map (lambda (form)
(decompile-form form globs stack))
(decompile-form form globs stack closed))
forms))]
[(struct splice (forms))
`(begin ,@(map (lambda (form)
(decompile-form form globs stack))
(decompile-form form globs stack closed))
forms))]
[else
(decompile-expr form globs stack)]))
(decompile-expr form globs stack closed)]))
(define (extract-name name)
(if (symbol? name)
@ -168,22 +169,22 @@
(extract-ids! body ids)]
[else #f]))
(define (decompile-expr expr globs stack)
(define (decompile-expr expr globs stack closed)
(match expr
[(struct toplevel (depth pos const? mutated?))
(let ([id (list-ref/protect globs pos)])
(let ([id (list-ref/protect globs pos 'toplevel)])
(if const?
id
`(#%checked ,id)))]
[(struct topsyntax (depth pos midpt))
(list-ref/protect globs (+ midpt pos))]
(list-ref/protect globs (+ midpt pos) 'topsyntax)]
[(struct primitive (id))
(hash-ref primitive-table id)]
[(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack)
,(decompile-expr rhs globs stack))]
`(set! ,(decompile-expr id globs stack closed)
,(decompile-expr rhs globs stack closed))]
[(struct localref (unbox? offset clear?))
(let ([id (list-ref/protect stack offset)])
(let ([id (list-ref/protect stack offset 'localref)])
(let ([e (if unbox?
`(#%unbox ,id)
id)])
@ -191,17 +192,17 @@
`(#%sfs-clear ,e)
e)))]
[(? lam?)
`(lambda . ,(decompile-lam expr globs stack))]
`(lambda . ,(decompile-lam expr globs stack closed))]
[(struct case-lam (name lams))
`(case-lambda
,@(map (lambda (lam)
(decompile-lam lam globs stack))
(decompile-lam lam globs stack closed))
lams))]
[(struct let-one (rhs body))
(let ([id (or (extract-id rhs)
(gensym 'local))])
`(let ([,id ,(decompile-expr rhs globs (cons id stack))])
,(decompile-expr body globs (cons id stack))))]
`(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
,(decompile-expr body globs (cons id stack) closed)))]
[(struct let-void (count boxes? body))
(let ([ids (make-vector count #f)])
(extract-ids! body ids)
@ -210,71 +211,76 @@
(or id (gensym 'localv)))])
`(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
vars)
,(decompile-expr body globs (append vars stack)))))]
,(decompile-expr body globs (append vars stack) closed))))]
[(struct let-rec (procs body))
`(begin
(#%set!-rec-values ,(for/list ([p (in-list procs)]
[i (in-naturals)])
(list-ref/protect stack i))
(list-ref/protect stack i 'let-rec))
,@(map (lambda (proc)
(decompile-expr proc globs stack))
(decompile-expr proc globs stack closed))
procs))
,(decompile-expr body globs stack))]
,(decompile-expr body globs stack closed))]
[(struct install-value (count pos boxes? rhs body))
`(begin
(,(if boxes? '#%set-boxes! 'set!-values)
,(for/list ([i (in-range count)])
(list-ref/protect stack (+ i pos)))
,(decompile-expr rhs globs stack))
,(decompile-expr body globs stack))]
(list-ref/protect stack (+ i pos) 'install-value))
,(decompile-expr rhs globs stack closed))
,(decompile-expr body globs stack closed))]
[(struct boxenv (pos body))
(let ([id (list-ref/protect stack pos)])
(let ([id (list-ref/protect stack pos 'boxenv)])
`(begin
(set! ,id (#%box ,id))
,(decompile-expr body globs stack)))]
,(decompile-expr body globs stack closed)))]
[(struct branch (test then else))
`(if ,(decompile-expr test globs stack)
,(decompile-expr then globs stack)
,(decompile-expr else globs stack))]
`(if ,(decompile-expr test globs stack closed)
,(decompile-expr then globs stack closed)
,(decompile-expr else globs stack closed))]
[(struct application (rator rands))
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
stack)])
(annotate-inline
`(,(decompile-expr rator globs stack)
`(,(decompile-expr rator globs stack closed)
,@(map (lambda (rand)
(decompile-expr rand globs stack))
(decompile-expr rand globs stack closed))
rands))))]
[(struct apply-values (proc args-expr))
`(#%apply-values ,(decompile-expr proc globs stack)
,(decompile-expr args-expr globs stack))]
`(#%apply-values ,(decompile-expr proc globs stack closed)
,(decompile-expr args-expr globs stack closed))]
[(struct sequence (exprs))
`(begin ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack)))]
(decompile-expr expr globs stack closed)))]
[(struct beg0 (exprs))
`(begin0 ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack)))]
(decompile-expr expr globs stack closed)))]
[(struct with-cont-mark (key val body))
`(with-continuation-mark
,(decompile-expr key globs stack)
,(decompile-expr val globs stack)
,(decompile-expr body globs stack))]
,(decompile-expr key globs stack closed)
,(decompile-expr val globs stack closed)
,(decompile-expr body globs stack closed))]
[(struct closure (lam gen-id))
`(#%closed ,gen-id ,(decompile-expr lam globs stack))]
(if (hash-ref closed gen-id #f)
gen-id
(begin
(hash-set! closed gen-id #t)
`(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
[(struct indirect (val))
(if (closure? val)
(closure-gen-id val)
(decompile-expr val globs stack closed)
'???)]
[else `(quote ,expr)]))
(define (decompile-lam expr globs stack)
(define (decompile-lam expr globs stack closed)
(match expr
[(struct closure (lam gen-id)) (decompile-lam lam globs stack)]
[(struct indirect (val)) (decompile-lam val globs stack closed)]
[(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
[(struct lam (name flags num-params rest? closure-map max-let-depth body))
(let ([vars (for/list ([i (in-range num-params)])
(gensym (format "arg~a-" i)))]
[rest-vars (if rest? (list (gensym 'rest)) null)]
[captures (map (lambda (v)
(list-ref/protect stack v))
(list-ref/protect stack v 'lam))
(vector->list closure-map))])
`((,@vars . ,(if rest?
(car rest-vars)
@ -285,8 +291,10 @@
,@(if (null? captures)
null
`('(captures: ,@captures)))
,(decompile-expr body globs (append captures
(append vars rest-vars)))))]))
,(decompile-expr body globs
(append captures
(append vars rest-vars))
closed)))]))
(define (annotate-inline a)
(if (and (symbol? (car a))
@ -301,16 +309,16 @@
car cdr caar cadr cdar cddr
mcar mcdr unbox vector-length syntax-e
add1 sub1 - abs bitwise-not
list vector box))]
list list* vector vector-immutable box))]
[(3) (memq (car a) '(eq? = <= < >= >
bitwise-bit-set? char=?
+ - * / min max bitwise-and bitwise-ior
arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons
list vector))]
list list* vector vector-immutable))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set!
list vector))]
[else (memq (car a) '(list vector))]))
list list* vector vector-immutable))]
[else (memq (car a) '(list list* vector vector-immutable))]))
(cons '#%in a)
a))

17
collects/compiler/zo-parse.ss
View File

@ -661,7 +661,7 @@
;; Main parsing loop
(define (read-compact cp)
(let loop ([need-car 0] [proper #f] [last #f] [first #f])
(let loop ([need-car 0] [proper #f])
(begin-with-definitions
(define ch (cp-getc cp))
(define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)])
@ -707,7 +707,7 @@
(cons (read-compact cp)
(if ppr null (read-compact cp)))
(read-compact-list l ppr cp))
(loop l ppr last first)))]
(loop l ppr)))]
[(let-one)
(make-let-one (read-compact cp) (read-compact cp))]
[(branch)
@ -747,8 +747,10 @@
(read-compact cp))])
(vector->immutable-vector (list->vector lst)))]
[(list) (let* ([n (read-compact-number cp)])
(for/list ([i (in-range n)])
(read-compact cp)))]
(append
(for/list ([i (in-range n)])
(read-compact cp))
(read-compact cp)))]
[(prefab)
(let ([v (read-compact cp)])
(apply make-prefab-struct
@ -845,9 +847,8 @@
[(symbol? s) s]
[(vector? s) (vector-ref s 0)]
[else 'closure]))))])
(vector-set! (cport-symtab cp) l cl)
(set-indirect-v! ind cl)
cl))]
ind))]
[(svector)
(read-compact-svector cp (read-compact-number cp))]
[(small-svector)
@ -858,7 +859,7 @@
[(and proper (= need-car 1))
(cons v null)]
[else
(cons v (loop (sub1 need-car) proper last first))]))))
(cons v (loop (sub1 need-car) proper))]))))
;; path -> bytes
;; implementes read.c:read_compiled
@ -898,11 +899,13 @@
(define symtab (make-vector symtabsize (make-not-ready)))
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
(for/list ([i (in-range 1 symtabsize)])
(when (not-ready? (vector-ref symtab i))
(set-cport-pos! cp (vector-ref so* (sub1 i)))
(let ([v (read-compact cp)])
(vector-set! symtab i v))))
(set-cport-pos! cp shared-size)
(read-marshalled 'compilation-top-type cp)))

6
collects/handin-server/main.ss
View File

@ -10,7 +10,7 @@
"private/run-status.ss"
"private/reloadable.ss"
"private/hooker.ss"
"web-status-server.ss"
(prefix-in web: "web-status-server.ss")
;; this sets some global parameter values, and this needs
;; to be done in the main thread, rather than later in a
;; user session thread (that will make the global changes
@ -622,9 +622,7 @@
(log-line "server started ------------------------------")
(hook 'server-start `([port ,(get-conf 'port-number)]))
(define stop-status
(cond [(get-conf 'https-port-number) => serve-status]
[else void]))
(define stop-status (web:run))
(define session-count 0)

1
collects/handin-server/private/config.ss
View File

@ -74,7 +74,6 @@
[(allow-new-users) (values #f id )]
[(allow-change-info) (values #f id )]
[(master-password) (values #f id )]
[(web-base-dir) (values #f path/false )]
[(log-output) (values #t id )]
[(log-file) (values "log" path/false )]
[(web-log-file) (values #f path/false )]

5
collects/handin-server/scribblings/quick-start.scrbl
View File

@ -50,9 +50,8 @@
The submitted file will be @filepath{.../test/tester/handin.scm}.}
@item{Check the status of your submission by pointing a web browser at
@tt{https://localhost:7980/servlets/status.ss}. Note the ``s'' in
``https''. Use the ``@tt{tester}'' username and ``@tt{pw}''
password, as before.
@tt{https://localhost:7980/}. Note the ``s'' in ``https''. Use the
``@tt{tester}'' username and ``@tt{pw}'' password, as before.
NOTE: The @scheme[https-port-number] line in the
@filepath{config.ss} file enables the embedded secure server. You

24
collects/handin-server/scribblings/server-setup.scrbl
View File

@ -114,16 +114,6 @@ This directory contains the following files and sub-directories:
option), or @scheme[#f] for no log file; defaults to
@filepath{log}.}
@item{@indexed-scheme[web-base-dir] --- if @scheme[#f] (the
default), the built-in web server will use the
@filepath{status-web-root} in the handin collection for its
configuration; to have complete control over the built in server
content, you can copy and edit @filepath{status-web-root}, then
add this configuration entry set to the name of your new copy
(relative to the handin server directory, or absolute). Note that
you must copy the @filepath{servlets} directory if you want the
status servlet.}
@item{@indexed-scheme[web-log-file] --- a path (relative to handin
server directory or absolute) that specifies a filename for
logging the internal HTTPS status web server; or @scheme[#f] (the
@ -218,11 +208,11 @@ This directory contains the following files and sub-directories:
Changes to @filepath{config.ss} are detected, the file will be
re-read, and options are reloaded. A few options are fixed at
startup time: port numbers, log file specs, and the
@scheme[web-base-dir] are fixed as configured at startup. All other
options will change the behavior of the running server (but things
like @scheme[username-case-sensitive?] it would be unwise to do
so). (For safety, options are not reloaded until the file parses
startup time: port numbers and log file specs are fixed as
configured at startup. All other options will change the behavior
of the running server (but things like
@scheme[username-case-sensitive?] it would be unwise to do so).
(For safety, options are not reloaded until the file parses
correctly, but make sure that you don't save a copy that has
inconsistent options: it is best to create a new configuration file
and move it over the old one, or use an editor that does so and not
@ -482,11 +472,11 @@ the correct assignment in the handin dialog.
A student can download his/her own submissions through a web server
that runs concurrently with the handin server. The starting URL is
@commandline{https://SERVER:PORT/servlets/status.ss}
@commandline{https://SERVER:PORT/}
to obtain a list of all assignments, or
@commandline{https://SERVER:PORT/servlets/status.ss?handin=ASSIGNMENT}
@commandline{https://SERVER:PORT/?handin=ASSIGNMENT}
to start with a specific assignment (named ASSIGNMENT). The default
PORT is 7980.

8
collects/handin-server/status-web-root/index.html
View File

@ -1,8 +0,0 @@
<html>
<head><title>Handin Status Web Server</title></head>
<body>
The handin status server is running.
<br>
You can <a href="/status.ss">check your submissions</a> on this server.
</body>
</html>

277
collects/handin-server/status-web-root/servlets/status.ss
View File

@ -1,277 +0,0 @@
(module status mzscheme
(require mzlib/file
mzlib/list
mzlib/string
mzlib/date
web-server/servlet
web-server/servlet/servlet-structs
web-server/managers/timeouts
web-server/private/util
net/uri-codec
net/url
handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker)
(define get-user-data
(let ([users-file (build-path server-dir "users.ss")])
(lambda (user)
(get-preference (string->symbol user) (lambda () #f) #f users-file))))
(define (clean-str s)
(regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") ""))
(define (aget alist key)
(cond [(assq key alist) => cdr] [else #f]))
(define (make-page title . body)
`(html (head (title ,title))
(body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body)))
(define (relativize-path p)
(path->string (find-relative-path (normalize-path server-dir) p)))
(define (make-k k tag)
(format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")
(uri-encode tag)))
;; `look-for' can be a username as a string (will find "bar+foo" for "foo"),
;; or a regexp that should match the whole directory name (used with
;; "^solution" below)
(define (find-handin-entry hi look-for)
(let ([dir (assignment<->dir hi)])
(and (directory-exists? dir)
(ormap
(lambda (d)
(let ([d (path->string d)])
(and (cond [(string? look-for)
(member look-for (regexp-split #rx" *[+] *" d))]
[(regexp? look-for) (regexp-match? look-for d)]
[else (error 'find-handin-entry
"internal error: ~e" look-for)])
(build-path dir d))))
(directory-list dir)))))
(define (handin-link k user hi)
(let* ([dir (find-handin-entry hi user)]
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
(parameterize ([current-directory dir])
(sort (filter (lambda (f)
(and (not (equal? f "grade"))
(file-exists? f)))
(map path->string (directory-list)))
string<?))))])
(if (pair? l)
(cdr (apply append
(map (lambda (f)
(let ([hi (build-path dir f)])
`((br)
(a ([href ,(make-k k (relativize-path hi))]) ,f)
" ("
,(date->string
(seconds->date
(file-or-directory-modify-seconds hi))
#t)
")")))
l)))
(list (format "No handins accepted so far for user ~s, assignment ~s"
user hi)))))
(define (solution-link k hi)
(let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs))
(find-handin-entry hi #rx"^solution"))]
[none `((i "---"))])
(cond [(not soln) none]
[(file-exists? soln)
`((a ((href ,(make-k k (relativize-path soln)))) "Solution"))]
[(directory-exists? soln)
(parameterize ([current-directory soln])
(let ([files (sort (map path->string
(filter file-exists? (directory-list)))
string<?)])
(if (null? files)
none
(apply append
(map (lambda (f)
`((a ([href ,(make-k k (relativize-path
(build-path soln f)))])
(tt ,f))
(br)))
files)))))]
[else none])))
(define (handin-grade user hi)
(let* ([dir (find-handin-entry hi user)]
[grade (and dir
(let ([filename (build-path dir "grade")])
(and (file-exists? filename)
(with-input-from-file filename
(lambda ()
(read-string (file-size filename)))))))])
(or grade "--")))
(define (one-status-page user for-handin)
(let* ([next (send/suspend
(lambda (k)
(make-page (format "User: ~a, Handin: ~a" user for-handin)
`(p ,@(handin-link k user for-handin))
`(p "Grade: " ,(handin-grade user for-handin))
`(p ,@(solution-link k for-handin))
`(p (a ([href ,(make-k k "allofthem")])
,(format "All handins for ~a" user))))))]
[tag (aget (request-bindings next) 'tag)])
(if (string=? tag "allofthem")
(all-status-page user)
(download user tag))))
(define (all-status-page user)
(define (cell . texts) `(td ([bgcolor "white"]) ,@texts))
(define (rcell . texts) `(td ([bgcolor "white"] [align "right"]) ,@texts))
(define (header . texts) `(td ([bgcolor "#f0f0f0"]) (big (strong ,@texts))))
(define ((row k active?) dir)
(let ([hi (assignment<->dir dir)])
`(tr ([valign "top"])
,(apply header hi
(if active? `((br) (small (small "[active]"))) '()))
,(apply cell (handin-link k user hi))
,(rcell (handin-grade user hi))
,(apply cell (solution-link k hi)))))
(let* ([next
(send/suspend
(lambda (k)
(make-page
(format "All Handins for ~a" user)
`(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
(tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
,@(append (map (row k #t) (get-conf 'active-dirs))
(map (row k #f) (get-conf 'inactive-dirs)))))))]
[tag (aget (request-bindings next) 'tag)])
(download user tag)))
(define (download who tag)
(define (check path elts allow-active?)
(let loop ([path path] [elts (reverse elts)])
(let*-values ([(base name dir?) (split-path path)]
[(name) (path->string name)]
[(check) (and (pair? elts) (car elts))])
(if (null? elts)
;; must be rooted in a submission directory (why build-path instead
;; of using `path'? -- because path will have a trailing slash)
(member (build-path base name)
(get-conf (if allow-active? 'all-dirs 'inactive-dirs)))
(and (cond [(eq? '* check) #t]
[(regexp? check) (regexp-match? check name)]
[(string? check)
(or (equal? name check)
(member check (regexp-split #rx" *[+] *" name)))]
[else #f])
(loop base (cdr elts)))))))
(define file (build-path server-dir tag))
(with-handlers ([exn:fail?
(lambda (exn)
(log-line "Status exception: ~a" (exn-message exn))
(make-page "Error" "Illegal file access"))])
;; Make sure the user is allowed to read the requested file:
(or (check file `(,who *) #t)
(check file `(#rx"^solution") #f)
(check file `(#rx"^solution" *) #f)
(error 'download "bad file access for ~s: ~a" who file))
(log-line "Status file-get: ~s ~a" who file)
(hook 'status-file-get `([username ,(string->symbol who)] [file ,file]))
;; Return the downloaded file
(let* ([data (with-input-from-file file
(lambda () (read-bytes (file-size file))))]
[html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))]
[wxme? (regexp-match? #rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)])
(make-response/full 200 "Okay" (current-seconds)
(cond [html? #"text/html"]
[wxme? #"application/data"]
[else #"text/plain"])
(list
(make-header #"Content-Length"
(string->bytes/latin-1
(number->string (bytes-length data))))
(make-header #"Content-Disposition"
(string->bytes/utf-8
(format "~a; filename=~s"
(if wxme? "attachment" "inline")
(let-values ([(base name dir?) (split-path file)])
(path->string name))))))
(list data)))))
(define (status-page user for-handin)
(log-line "Status access: ~s" user)
(hook 'status-login `([username ,(string->symbol user)]))
(if for-handin
(one-status-page user for-handin)
(all-status-page user)))
(define (login-page for-handin errmsg)
(let* ([request
(send/suspend
(lambda (k)
(make-page
"Handin Status Login"
`(form ([action ,k] [method "post"])
(table ([align "center"])
(tr (td ([colspan "2"] [align "center"])
(font ([color "red"]) ,(or errmsg 'nbsp))))
(tr (td "Username")
(td (input ([type "text"] [name "user"] [size "20"]
[value ""]))))
(tr (td nbsp))
(tr (td "Password")
(td (input ([type "password"] [name "passwd"]
[size "20"] [value ""]))))
(tr (td ([colspan "2"] [align "center"])
(input ([type "submit"] [name "post"]
[value "Login"])))))))))]
[bindings (request-bindings request)]
[user (aget bindings 'user)]
[passwd (aget bindings 'passwd)]
[user (and user (clean-str user))]
[user-data (get-user-data user)])
(cond [(and user-data
(string? passwd)
(let ([pw (md5 passwd)])
(or (equal? pw (car user-data))
(equal? pw (get-conf 'master-password)))))
(status-page user for-handin)]
[else (login-page for-handin "Bad username or password")])))
(define web-counter
(let ([sema (make-semaphore 1)]
[count 0])
(lambda ()
(dynamic-wind
(lambda () (semaphore-wait sema))
(lambda () (set! count (add1 count)) (format "w~a" count))
(lambda () (semaphore-post sema))))))
(define (start initial-request)
(parameterize ([current-session (web-counter)])
(login-page (aget (request-bindings initial-request) 'handin) #f)))
(define interface-version 'v2)
(define name "status")
(define (instance-expiration-handler failed-request)
(let* (;; get the current url, and strip off the continuation data
[cont-url (request-uri failed-request)]
[base-url (url-replace-path
(lambda (pl)
(map (lambda (pp)
(make-path/param (path/param-path pp) empty))
pl))
cont-url)]
[base-url-str (url->string base-url)])
`(html (head (meta [(http-equiv "refresh")
(content ,(format "3;URL=~a" base-url-str))]))
(body "Your session has expired, "
(a ([href ,base-url-str]) "restarting") " in 3 seconds."))))
(define manager
(create-timeout-manager instance-expiration-handler 600 600))
(provide interface-version start name manager))

351
collects/handin-server/web-status-server.ss
View File

@ -1,82 +1,283 @@
#lang scheme/base
(require scheme/unit
net/ssl-tcp-unit
net/tcp-sig
net/tcp-unit
(only-in mzlib/etc this-expression-source-directory)
web-server/web-server-unit
web-server/web-server-sig
web-server/web-config-sig
web-server/web-config-unit
web-server/configuration/namespace
"private/config.ss")
#lang scheme
(require scheme/list
scheme/file
scheme/date
net/uri-codec
web-server/servlet
web-server/servlet-env
web-server/managers/lru
handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker)
(provide serve-status)
(define (aget alist key)
(cond [(assq key alist) => cdr] [else #f]))
(define (serve-status port-no)
(define (clean-str s)
(regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") ""))
(define ((in-dir dir) . paths) (path->string (apply build-path dir paths)))
(define in-web-dir
(in-dir (or (get-conf 'web-base-dir)
(build-path (this-expression-source-directory)
"status-web-root"))))
(define in-plt-web-dir
(in-dir (build-path (collection-path "web-server") "default-web-root")))
(define (make-page title . body)
`(html (head (title ,title))
(body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body)))
(define config
`((port ,port-no)
(max-waiting 40)
(initial-connection-timeout 30)
(default-host-table
(host-table
(default-indices "index.html")
(log-format parenthesized-default)
(messages
(servlet-message "servlet-error.html")
(authentication-message "forbidden.html")
(servlets-refreshed "servlet-refresh.html")
(passwords-refreshed "passwords-refresh.html")
(file-not-found-message "not-found.html")
(protocol-message "protocol-error.html")
(collect-garbage "collect-garbage.html"))
(timeouts
(default-servlet-timeout 120)
(password-connection-timeout 300)
(servlet-connection-timeout 86400)
(file-per-byte-connection-timeout 1/20)
(file-base-connection-timeout 30))
(paths
(configuration-root ,(in-plt-web-dir "conf"))
(host-root ".")
(log-file-path ,(cond [(get-conf 'web-log-file) => path->string]
[else #f]))
(file-root ".")
(servlet-root ,(in-web-dir "servlets"))
(mime-types ,(in-plt-web-dir "mime.types"))
(password-authentication ,(in-plt-web-dir "passwords")))))
(virtual-host-table)))
(define get-user-data
(let ([users-file (build-path server-dir "users.ss")])
(unless (file-exists? users-file)
(error 'get-user-data "users file missing at: ~a" users-file))
(lambda (user)
(get-preference (string->symbol user) (lambda () #f) #f users-file))))
(define configuration
(configuration-table-sexpr->web-config@
config
#:web-server-root (in-web-dir)
#:make-servlet-namespace
(make-make-servlet-namespace
#:to-be-copied-module-specs
'(handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker
handin-server/private/reloadable))))
(define (relativize-path p)
(path->string (find-relative-path (normalize-path server-dir) p)))
(define-unit-binding config@ configuration (import) (export web-config^))
(define-unit-binding ssl-tcp@
(make-ssl-tcp@ "server-cert.pem" "private-key.pem" #f #f #f #f #f)
(import) (export tcp^))
(define-compound-unit/infer status-server@
(import)
(link ssl-tcp@ config@ web-server@)
(export web-server^))
(define-values/invoke-unit/infer status-server@)
(define (make-k k tag)
(format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")
(uri-encode tag)))
(serve))
;; `look-for' can be a username as a string (will find "bar+foo" for "foo"), or
;; a regexp that should match the whole directory name (used with "^solution"
;; below)
(define (find-handin-entry hi look-for)
(let ([dir (assignment<->dir hi)])
(and (directory-exists? dir)
(ormap
(lambda (d)
(let ([d (path->string d)])
(and (cond [(string? look-for)
(member look-for (regexp-split #rx" *[+] *" d))]
[(regexp? look-for) (regexp-match? look-for d)]
[else (error 'find-handin-entry
"internal error: ~e" look-for)])
(build-path dir d))))
(directory-list dir)))))
(define (handin-link k user hi)
(let* ([dir (find-handin-entry hi user)]
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
(parameterize ([current-directory dir])
(sort (filter (lambda (f)
(and (not (equal? f "grade"))
(file-exists? f)))
(map path->string (directory-list)))
string<?))))])
(if (pair? l)
(cdr (append-map
(lambda (f)
(let ([hi (build-path dir f)])
`((br)
(a ([href ,(make-k k (relativize-path hi))]) ,f)
" ("
,(date->string
(seconds->date (file-or-directory-modify-seconds hi))
#t)
")")))
l))
(list (format "No handins accepted so far for user ~s, assignment ~s"
user hi)))))
(define (solution-link k hi)
(let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs))
(find-handin-entry hi #rx"^solution"))]
[none `((i "---"))])
(cond [(not soln) none]
[(file-exists? soln)
`((a ((href ,(make-k k (relativize-path soln)))) "Solution"))]
[(directory-exists? soln)
(parameterize ([current-directory soln])
(let ([files (sort (map path->string
(filter file-exists? (directory-list)))
string<?)])
(if (null? files)
none
(apply append
(map (lambda (f)
`((a ([href ,(make-k k (relativize-path
(build-path soln f)))])
(tt ,f))
(br)))
files)))))]
[else none])))
(define (handin-grade user hi)
(let* ([dir (find-handin-entry hi user)]
[grade (and dir
(let ([filename (build-path dir "grade")])
(and (file-exists? filename)
(with-input-from-file filename
(lambda ()
(read-string (file-size filename)))))))])
(or grade "--")))
(define (one-status-page user for-handin)
(let* ([next (send/suspend
(lambda (k)
(make-page (format "User: ~a, Handin: ~a" user for-handin)
`(p ,@(handin-link k user for-handin))
`(p "Grade: " ,(handin-grade user for-handin))
`(p ,@(solution-link k for-handin))
`(p (a ([href ,(make-k k "allofthem")])
,(format "All handins for ~a" user))))))]
[tag (aget (request-bindings next) 'tag)])
(if (string=? tag "allofthem")
(all-status-page user)
(download user tag))))
(define (all-status-page user)
(define (cell . texts) `(td ([bgcolor "white"]) ,@texts))
(define (rcell . texts) `(td ([bgcolor "white"] [align "right"]) ,@texts))
(define (header . texts) `(td ([bgcolor "#f0f0f0"]) (big (strong ,@texts))))
(define ((row k active?) dir)
(let ([hi (assignment<->dir dir)])
`(tr ([valign "top"])
,(apply header hi (if active? `((br) (small (small "[active]"))) '()))
,(apply cell (handin-link k user hi))
,(rcell (handin-grade user hi))
,(apply cell (solution-link k hi)))))
(let* ([next
(send/suspend
(lambda (k)
(make-page
(format "All Handins for ~a" user)
`(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
(tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
,@(append (map (row k #t) (get-conf 'active-dirs))
(map (row k #f) (get-conf 'inactive-dirs)))))))]
[tag (aget (request-bindings next) 'tag)])
(download user tag)))
(define (download who tag)
(define (check path elts allow-active?)
(let loop ([path path] [elts (reverse elts)])
(let*-values ([(base name dir?) (split-path path)]
[(name) (path->string name)]
[(check) (and (pair? elts) (car elts))])
(if (null? elts)
;; must be rooted in a submission directory (why build-path instead
;; of using `path'? -- because path will have a trailing slash)
(member (build-path base name)
(get-conf (if allow-active? 'all-dirs 'inactive-dirs)))
(and (cond [(eq? '* check) #t]
[(regexp? check) (regexp-match? check name)]
[(string? check)
(or (equal? name check)
(member check (regexp-split #rx" *[+] *" name)))]
[else #f])
(loop base (cdr elts)))))))
(define file (build-path server-dir tag))
(with-handlers ([exn:fail?
(lambda (exn)
(log-line "Status exception: ~a" (exn-message exn))
(make-page "Error" "Illegal file access"))])
;; Make sure the user is allowed to read the requested file:
(or (check file `(,who *) #t)
(check file `(#rx"^solution") #f)
(check file `(#rx"^solution" *) #f)
(error 'download "bad file access for ~s: ~a" who file))
(log-line "Status file-get: ~s ~a" who file)
(hook 'status-file-get `([username ,(string->symbol who)] [file ,file]))
;; Return the downloaded file
(let* ([data (file->bytes file)]
[html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))]
[wxme? (regexp-match?
#rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)])
(make-response/full 200 "Okay" (current-seconds)
(cond [html? #"text/html"]
[wxme? #"application/data"]
[else #"text/plain"])
(list
(make-header #"Content-Length"
(string->bytes/latin-1
(number->string (bytes-length data))))
(make-header #"Content-Disposition"
(string->bytes/utf-8
(format "~a; filename=~s"
(if wxme? "attachment" "inline")
(let-values ([(base name dir?) (split-path file)])
(path->string name))))))
(list data)))))
(define (status-page user for-handin)
(log-line "Status access: ~s" user)
(hook 'status-login `([username ,(string->symbol user)]))
(if for-handin
(one-status-page user for-handin)
(all-status-page user)))
(define (login-page for-handin errmsg)
(let* ([request
(send/suspend
(lambda (k)
(make-page
"Handin Status Login"
`(form ([action ,k] [method "post"])
(table ([align "center"])
(tr (td ([colspan "2"] [align "center"])
(font ([color "red"]) ,(or errmsg 'nbsp))))
(tr (td "Username")
(td (input ([type "text"] [name "user"] [size "20"]
[value ""]))))
(tr (td nbsp))
(tr (td "Password")
(td (input ([type "password"] [name "passwd"]
[size "20"] [value ""]))))
(tr (td ([colspan "2"] [align "center"])
(input ([type "submit"] [name "post"]
[value "Login"])))))))))]
[bindings (request-bindings request)]
[user (aget bindings 'user)]
[passwd (aget bindings 'passwd)]
[user (and user (clean-str user))]
[user-data (get-user-data user)])
(cond [(and user-data
(string? passwd)
(let ([pw (md5 passwd)])
(or (equal? pw (car user-data))
(equal? pw (get-conf 'master-password)))))
(status-page user for-handin)]
[else (login-page for-handin "Bad username or password")])))
(define web-counter
(let ([sema (make-semaphore 1)] [count 0])
(lambda ()
(dynamic-wind
(lambda () (semaphore-wait sema))
(lambda () (set! count (add1 count)) (format "w~a" count))
(lambda () (semaphore-post sema))))))
(define ((send-error msg) req)
`(html (head (meta [(http-equiv "refresh") (content "3;URL=/")])
(title ,msg))
(body ,msg "; " (a ([href "/"]) "restarting") " in 3 seconds.")))
(define ((run-servlet port))
(define dir (string->path server-dir))
(serve/servlet
(lambda (request)
(parameterize ([current-session (web-counter)])
(login-page (aget (request-bindings request) 'handin) #f)))
#:port port #:listen-ip #f #:ssl? #t #:command-line? #t
#:servlet-path "/" #:servlet-regexp #rx""
#:server-root-path dir #:servlets-root dir
#:file-not-found-responder (send-error "File not found")
#:servlet-namespace '(handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker
handin-server/private/reloadable)
#:manager (make-threshold-LRU-manager
(send-error "Your session has expired") (* 12 1024 1024))
#:log-file (get-conf 'web-log-file)))
(provide run)
(define (run)
(cond [(get-conf 'https-port-number)
=> (lambda (p)
(define t
(thread (lambda ()
(dynamic-wind
(lambda () (log-line "*** starting web server"))
(run-servlet p)
(lambda () (log-line "*** web server died!"))))))
(lambda () (break-thread t)))]
[else void]))

2
collects/net/scribblings/url.scrbl
View File

@ -44,7 +44,7 @@ re-exported by @schememodname[net/url].}
[query (listof (cons/c symbol? (or/c false/c string?)))]
[fragment (or/c false/c string?)])]{
The basic structure for all URLs, hich is explained in RFC 3986
The basic structure for all URLs, which is explained in RFC 3986
@cite["RFC3986"]. The following diagram illustrates the parts:
@verbatim[#:indent 2]|{

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "19nov2008")
#lang scheme/base (provide stamp) (define stamp "20nov2008")

41
collects/tests/mzscheme/optimize.ss
View File

@ -350,6 +350,9 @@
(un0 '(1) 'list 1)
(bin0 '(1 2) 'list 1 2)
(tri0 '(1 2 3) 'list (lambda () 1) 2 3 void)
(un0 '1 'list* 1)
(bin0 '(1 . 2) 'list* 1 2)
(tri0 '(1 2 . 3) 'list* (lambda () 1) 2 3 void)
(un0 '#&1 'box 1)
(let ([test-setter
@ -443,17 +446,19 @@
(list a b c d e f))])
10))
(test-comp (normalize-depth '(let* ([i (cons 0 1)][j i]) j))
(normalize-depth '(let* ([i (cons 0 1)]) i)))
;; We use nonsense `display' and `write' where we used to use `cons' and
;; `list', because the old ones now get optimized away:
(test-comp (normalize-depth '(let* ([i (display 0 1)][j i]) j))
(normalize-depth '(let* ([i (display 0 1)]) i)))
(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i]) g))
(normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i)))
(test-comp (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)][g i]) g))
(normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)]) i)))
(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i][h g]) h))
(normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i)))
(test-comp (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)][g i][h g]) h))
(normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)]) i)))
(test-comp (normalize-depth '(let* ([i (cons 0 1)][g i][h (car g)][m h]) m))
(normalize-depth '(let* ([i (cons 0 1)][h (car i)]) h)))
(test-comp (normalize-depth '(let* ([i (display 0 1)][g i][h (car g)][m h]) m))
(normalize-depth '(let* ([i (display 0 1)][h (car i)]) h)))
; (require #%kernel) ;
@ -685,6 +690,26 @@
(define (q x)
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10))))))))))))))
(let ([test-dropped
(lambda (cons-name . args)
(test-comp `(let ([x 5])
(let ([y (,cons-name ,@args)])
x))
5))])
(test-dropped 'cons 1 2)
(test-dropped 'mcons 1 2)
(test-dropped 'box 1)
(let ([test-multi
(lambda (cons-name)
(test-dropped cons-name 1 2)
(test-dropped cons-name 1 2 3)
(test-dropped cons-name 1)
(test-dropped cons-name))])
(test-multi 'list)
(test-multi 'list*)
(test-multi 'vector)
(test-multi 'vector-immutable)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check bytecode verification of lifted functions

0
collects/web-server/template/examples/basic.html → collects/tests/web-server/template/examples/basic.html
View File

0
collects/web-server/template/examples/if.html → collects/tests/web-server/template/examples/if.html
View File

0
collects/web-server/template/examples/run.ss → collects/tests/web-server/template/examples/run.ss
View File

0
collects/web-server/template/examples/static.html → collects/tests/web-server/template/examples/static.html
View File

4
collects/texpict/utils.ss
View File

@ -286,9 +286,9 @@
w
h))))
(define (filled-rounded-rectangle w h [corner-radius 0.25] #:angle [angle 0])
(define (filled-rounded-rectangle w h [corner-radius -0.25] #:angle [angle 0])
(let ([dc-path (new dc-path%)])
(send dc-path rounded-rectangle 0 0 w h (- corner-radius))
(send dc-path rounded-rectangle 0 0 w h corner-radius)
(send dc-path rotate angle)
(let-values ([(x y w h) (send dc-path get-bounding-box)])
(dc (λ (dc dx dy)

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

@ -2,6 +2,7 @@
(require
scheme/list
scheme/tcp
(only-in rnrs/lists-6 fold-left)
'#%paramz
(only-in '#%kernel [apply kernel:apply])
@ -480,4 +481,16 @@
[eof (-val eof)]
[read-accept-reader (-Param B B)]
[maybe-print-message (-String . -> . -Void)]
[maybe-print-message (-String . -> . -Void)]
;; scheme/tcp
[tcp-listener? (make-pred-ty -TCP-Listener)]
[tcp-abandon-port (-Port . -> . -Void)]
[tcp-accept (-TCP-Listener . -> . (-values (list -Input-Port -Output-Port)) )]
[tcp-accept/enable-break (-TCP-Listener . -> . (-values (list -Input-Port -Output-Port)) )]
[tcp-accept-ready? (-TCP-Listener . -> . B )]
[tcp-addresses (-Port . -> . (-values (list N N)))]
[tcp-close (-TCP-Listener . -> . -Void )]
[tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
[tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
[tcp-listen (N . -> . -TCP-Listener)]

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

@ -12,7 +12,7 @@
scheme/promise
(for-syntax macro-debugger/stxclass/stxclass)
(for-syntax scheme/base)
(for-template scheme/base scheme/contract))
(for-template scheme/base scheme/contract scheme/tcp))
(provide (all-defined-out)
;; these should all eventually go away
@ -134,6 +134,7 @@
(define -Namespace (make-Base 'Namespace #'namespace?))
(define -Output-Port (make-Base 'Output-Port #'output-port?))
(define -Input-Port (make-Base 'Input-Port #'input-port?))
(define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener?))
(define -Syntax make-Syntax)
(define -HT make-Hashtable)

16
collects/typed/file/gif.ss Normal file
View File

@ -0,0 +1,16 @@
#lang typed-scheme
(require typed/private/utils)
(require/opaque-type GIF-Stream gif-stream? file/gif)
(require/typed/provide file/gif
[gif-start ( Output-Port Number Number Number (U #f (Listof (Vectorof Number))) -> Void )]
[gif-add-image ( GIF-Stream Number Number Number Number Boolean (U #f Number) String -> Void )]
[gif-add-control ( GIF-Stream Symbol Boolean Number (U #f Number) -> Void)]
[gif-add-loop-control ( GIF-Stream Number -> Void )]
[gif-add-comment ( GIF-Stream String -> Void )]
[gif-end ( GIF-Stream -> Void )]
[quantize ( String -> (values String (Listof (Vectorof Number)) (U #f (Vectorof Number))))])
(provide gif-stream? GIF-Stream)

3
collects/typed/framework/framework.ss
View File

@ -1,6 +1,7 @@
#lang typed-scheme
(require (only-in typed/mred/mred dt require/typed/provide Font%))
(require typed/private/utils
(only-in typed/mred/mred Font%))
(dt Style-List% (Class ()
()

10
collects/typed/mred/mred.ss
View File

@ -1,14 +1,6 @@
#lang typed-scheme
(define-syntax-rule (dt nm t)
(begin (define-type-alias nm t) (provide nm)))
(define-syntax-rule (require/typed/provide lib [nm t] ...)
(begin
(require/typed lib [nm t] ...)
(provide nm ...)))
(provide dt require/typed/provide)
(require typed/private/utils)
(dt Bitmap% (Class (Number Number Boolean)
()

13
collects/typed/net/base64.ss Normal file
View File

@ -0,0 +1,13 @@
#lang typed-scheme
(require typed/private/utils)
(require/typed/provide net/base64
[base64-encode-stream (case-lambda (Input-Port Output-Port -> Void)
(Input-Port Output-Port Bytes -> Void))]
[base64-decode-stream (Input-Port Output-Port -> Void)]
[base64-encode (Bytes -> Bytes)]
[base64-decode (Bytes -> Bytes)])
(provide base64-encode-stream base64-decode-stream base64-encode base64-decode)

27
collects/typed/net/cgi.ss Normal file
View File

@ -0,0 +1,27 @@
#lang typed-scheme
(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/provide net/cgi
[get-bindings (-> (Listof (cons (U Symbol String) String)))]
[get-bindings/post (-> (Listof (Pair (U Symbol String) String)))]
[get-bindings/get (-> (Listof (Pair (U Symbol String) String)) )]
[output-http-headers (-> Void)]
[generate-html-output (case-lambda (String (Listof String) -> Void)
(String (Listof String) String String String String String -> Void))]
[generate-error-output ((Listof String) -> (U))]
[bindings-as-html ((Listof (cons (U Symbol String) String)) -> (Listof String))]
[extract-bindings ((U Symbol String) (Listof (cons (U Symbol String) String)) -> ( Listof String))]
[extract-binding/single ((U Symbol String) (Listof (Pair (U Symbol String) String)) -> String)]
[get-cgi-method (-> (U "GET" "POST"))]
[string->html (String -> String)]
[generate-link-text (String String -> String)])
(provide
(struct-out cgi-error)
(struct-out incomplete-%-suffix)
(struct-out invalid-%-suffix))

23
collects/typed/net/cookie.ss Normal file
View File

@ -0,0 +1,23 @@
#lang typed-scheme
(require typed/private/utils)
(require/opaque-type Cookie cookie? net/cookie)
(require/typed/provide net/cookie
[set-cookie (String String -> Cookie)]
[cookie:add-comment (Cookie String -> Cookie)]
[cookie:add-domain (Cookie String -> Cookie)]
[cookie:add-max-age (Cookie Number -> Cookie)]
[cookie:add-path (Cookie String -> Cookie)]
[cookie:secure (Cookie Boolean -> Cookie)]
[cookie:version (Cookie Number -> Cookie)]
[print-cookie (Cookie -> String)]
[get-cookie (String String -> (Listof String))]
[get-cookie/single (String String -> (Option String))])
(require-typed-struct cookie-error () net/cookie)
(provide Cookie cookie? (struct-out cookie-error))

10
collects/typed/net/dns.ss Normal file
View File

@ -0,0 +1,10 @@
#lang typed-scheme
(require typed/private/utils)
(require/typed/provide net/dns
[dns-get-address (String String -> String)]
[dns-get-name (String String -> String)]
[dns-get-mail-exchanger (String String -> String )]
[dns-find-nameserver (-> (Option String))])

16
collects/typed/net/ftp.ss Normal file
View File

@ -0,0 +1,16 @@
#lang typed-scheme
(require typed/private/utils)
(require/opaque-type FTP-Connection ftp-connection? net/ftp)
(require/typed/provide net/ftp
[ftp-cd (FTP-Connection String -> Void)]
[ftp-establish-connection (String Number String String -> FTP-Connection)]
[ftp-close-connection (FTP-Connection -> Void)]
[ftp-directory-list (FTP-Connection -> (Listof (List (U "-" "d" "l") String String)))]
[ftp-download-file (FTP-Connection Path String -> Void)]
[ftp-make-file-seconds (String -> Number)])
(provide ftp-connection? FTP-Connection)

4
collects/typed/net/gifwrite.ss Normal file
View File

@ -0,0 +1,4 @@
#lang typed-scheme
(require typed/file/gif)
(provide (all-from-out typed/file/gif))

31
collects/typed/net/head.ss Normal file
View File

@ -0,0 +1,31 @@
#lang typed-scheme
(require typed/private/utils)
(require/typed/provide net/head
[empty-header String]
[validate-header (String -> Void)]
[extract-field (Bytes (U Bytes String) -> (Option Bytes))]
[remove-field (String String -> String)]
[insert-field (String String String -> String)]
[replace-field (String String String -> String)]
[extract-all-fields ((U String Bytes) -> (Listof (cons (U String Bytes) (U Bytes String))))]
[append-headers (String String -> String)]
[standard-message-header (String (Listof String) (Listof String) (Listof String) String -> String)]
[data-lines->data ((Listof String) -> String)]
[extract-addresses (String Symbol -> (U (Listof String) (Listof (Listof String))))]
[assemble-address-field ((Listof String) -> String)])
(provide
empty-header
validate-header
extract-field
remove-field
insert-field
replace-field
extract-all-fields
append-headers
standard-message-header
data-lines->data
extract-addresses
assemble-address-field)

55
collects/typed/net/imap.ss Normal file
View File

@ -0,0 +1,55 @@
#lang typed-scheme
(require typed/private/utils)
(require/opaque-type IMAP-Connection imap-connection? net/imap)
(define-type-alias bstring (U String Bytes))
(require/typed/provide net/imap
[imap-port-number (Number -> Void)]
[imap-connect (String String String String -> (values IMAP-Connection Number Number))]
[imap-connect* (Number Number String String String -> (values IMAP-Connection Number Number))]
[imap-disconnect (IMAP-Connection -> Void)]
[imap-force-disconnect (IMAP-Connection -> Void)]
[imap-reselect (IMAP-Connection String -> (values Number Number))]
[imap-examine (IMAP-Connection String -> (values Number Number))]
[imap-noop (IMAP-Connection -> (values Number Number))]
[imap-status (IMAP-Connection String (Listof Symbol) -> (Listof (Listof Number)))]
[imap-poll (IMAP-Connection -> Void)]
[imap-new? (IMAP-Connection -> Boolean)]
[imap-messages (IMAP-Connection -> Number)]
[imap-recent (IMAP-Connection -> Number)]
[imap-uidnext (IMAP-Connection -> (Option Number))]
[imap-uidvalidity (IMAP-Connection -> (Option Number))]
[imap-unseen (IMAP-Connection -> (Option Number))]
[imap-reset-new! (IMAP-Connection -> Void)]
[imap-get-expunges (IMAP-Connection -> (Listof Number))]
[imap-pending-expunges? (IMAP-Connection -> Boolean)]
[imap-get-updates (IMAP-Connection -> (Listof (cons Number (Listof (Pair Any Any)))))]
[imap-pending-updates? (IMAP-Connection -> Boolean)]
[imap-get-messages
(IMAP-Connection (Listof Number) Symbol -> (Listof (Listof (U Number String String (Listof Symbol)))))]
[imap-copy (IMAP-Connection (Listof Number) String -> Void)]
[imap-append (IMAP-Connection String String -> Void)]
[imap-store (IMAP-Connection Symbol (Listof Number) Symbol -> Void)]
[imap-flag->symbol (Symbol -> Symbol)]
[symbol->imap-flag (Symbol -> Symbol)]
[imap-expunge (IMAP-Connection -> Void)]
[imap-mailbox-exists? (IMAP-Connection String -> Boolean)]
[imap-create-mailbox (IMAP-Connection String -> Void)]
[imap-list-child-mailboxes
(case-lambda (IMAP-Connection bstring -> (Listof (cons (Listof Symbol) (cons String '()))))
(IMAP-Connection bstring (Option bstring) -> (Listof (List (Listof Symbol) String))))]
[imap-mailbox-flags (IMAP-Connection String -> (Listof Symbol))]
[imap-get-hierarchy-delimiter (IMAP-Connection -> String)])
(provide
imap-connection?
IMAP-Connection)

71
collects/typed/net/mime.ss Normal file
View File

@ -0,0 +1,71 @@
#lang typed-scheme
(require typed/private/utils)
;; -- basic mime structures --
(require-typed-struct disposition
([type : Symbol]
[filename : String]
[creation : String]
[modification : String]
[read : String]
[size : Number]
[params : Any])
net/mime)
(require-typed-struct entity ([type : (U Symbol String)]
[subtype : (U Symbol String)]
[charset : (U Symbol String)]
[encoding : Symbol]
[disposition : disposition ]
[params : (Listof (cons Symbol String))]
[id : String]
[description : String]
[other : String]
[fields : Any]
[parts : (Listof String) ]
[body : (Output-Port -> Void)])
net/mime)
(require-typed-struct message
([version : String] [entity : entity] [fields : (Listof Symbol)])
net/mime)
;; -- 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)
;; -- 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
)

31
collects/typed/net/nntp.ss Normal file
View File

@ -0,0 +1,31 @@
#lang typed-scheme
(require typed/private/utils)
(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number])
net/nntp)
(require/typed/provide net/nntp
[connect-to-server (case-lambda (String -> communicator) (String Number -> communicator))]
[disconnect-from-server (communicator -> Void)]
[authenticate-user (communicator String String -> Void)]
[open-news-group (communicator String -> (values Number Number Number))]
[head-of-message (communicator Number -> (Listof String))]
[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 ()]
|#

38
collects/typed/net/pop3.ss Normal file
View File

@ -0,0 +1,38 @@
#lang typed-scheme
(require typed/private/utils)
(require-typed-struct 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?)) )]
[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)) )]
[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)
|#

10
collects/typed/net/qp.ss Normal file
View File

@ -0,0 +1,10 @@
#lang typed-scheme
(require typed/private/utils)
(require/typed/provide net/qp
[qp-encode ( String -> String )]
[qp-decode ( String -> String )]
[qp-encode-stream (case-lambda (Input-Port Output-Port -> Void) (Input-Port Output-Port String -> Void) )]
[qp-decode-stream ( Input-Port Output-Port -> Void )])

12
collects/typed/net/sendmail.ss Normal file
View File

@ -0,0 +1,12 @@
#lang typed-scheme
(require typed/private/utils)
(require/typed/provide net/sendmail
[send-mail-message/port
(String String (Listof String) (Listof String) (Listof String) String * -> Output-Port)]
[send-mail-message
(String String (Listof String) (Listof String) (Listof String) (Listof String) String * -> Output-Port)])
(provide send-mail-message/port send-mail-message #;no-mail-recipients)

9
collects/typed/net/sendurl.ss Normal file
View File

@ -0,0 +1,9 @@
#lang typed-scheme
(require/typed net/sendurl
[send-url (String -> Void)]
[unix-browser-list (Listof Symbol)]
[browser-preference? (String -> Boolean)]
[external-browser (-> (U Symbol #f (Pair String String)))])
(provide send-url unix-browser-list browser-preference? external-browser)

11
collects/typed/net/smtp.ss Normal file
View File

@ -0,0 +1,11 @@
#lang typed-scheme
(require typed/private/utils)
(require/typed/provide net/smtp
[smtp-send-message (String String (Listof String) String (Listof String) -> Void)]
[smtp-sending-end-of-message (Parameter (-> Any))])
(provide smtp-send-message smtp-sending-end-of-message)

15
collects/typed/net/uri-codec.ss Normal file
View File

@ -0,0 +1,15 @@
#lang typed-scheme
(require typed/private/utils)
(require/typed/provide net/uri-codec
[uri-encode ( String -> String )]
[uri-decode ( String -> String )]
[form-urlencoded-encode ( String -> String )]
[form-urlencoded-decode ( String -> String )]
[alist->form-urlencoded ( (Listof (cons Symbol String)) -> String )]
[form-urlencoded->alist ( String -> (Listof (cons Symbol String)) )]
[current-alist-separator-mode (Parameter Symbol)])

59
collects/typed/net/url.ss Normal file
View File

@ -0,0 +1,59 @@
#lang typed-scheme
(require typed/private/utils)
(require-typed-struct path/param ([path : (U String 'up 'same)] [param : (Listof String)]) net/url)
(require-typed-struct url ([scheme : (Option String)]
[user : (Option String)]
[host : (Option String)]
[port : (Option Integer)]
[path-absolute? : Boolean]
[path : (Listof path/param)]
[query : (Listof (Pair Symbol (Option String)))]
[fragment : (Option String)])
net/url)
(require/opaque-type URL-Exception url-exception? net/url)
(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)))
(require/typed/provide net/url
[path->url (Path -> url)]
[url->path (case-lambda (url -> Path) (url (U 'unix 'windows) -> Path))]
[file-url-path-convention-type (Parameter (U 'unix 'windows))]
[get-pure-port PortT]
[head-pure-port PortT]
[delete-pure-port PortT]
[get-impure-port PortT]
[head-impure-port PortT]
[delete-impure-port PortT]
[post-pure-port PortT/String]
[put-pure-port PortT/String]
[post-impure-port PortT/String]
[put-impure-port PortT/String]
[display-pure-port (Input-Port -> Void)]
[purify-port (Input-Port -> String)]
[call/input-url (case-lambda [url url (Input-Port -> Any) -> Any])] ;;FIXME - need polymorphism
[current-proxy-servers (Parameter (Listof (List String String Integer)))]
[netscape/string->url (String -> url)]
[string->url (String -> url)]
[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 Normal file
View File

@ -0,0 +1,11 @@
#lang typed-scheme
(define-syntax-rule (dt nm t)
(begin (define-type-alias nm t) (provide nm)))
(define-syntax-rule (require/typed/provide lib [nm t] ...)
(begin
(require/typed lib [nm t] ...)
(provide nm ...)))
(provide dt require/typed/provide)

18
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -51,10 +51,6 @@
#:responders-servlet (url? any/c . -> . response?))
dispatcher/c)])
;; default-server-instance-expiration-handler : (request -> response)
(define (default-servlet-instance-expiration-handler req)
(next-dispatcher))
(define (make url->servlet
#:responders-servlet-loading [responders-servlet-loading servlet-loading-responder]
#:responders-servlet [responders-servlet servlet-error-responder])
@ -70,15 +66,6 @@
(define response
(with-handlers ([exn:fail:filesystem:exists?
(lambda (the-exn) (next-dispatcher))]
[exn:fail:servlet-manager:no-instance?
(lambda (the-exn)
((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))]
[exn:fail:servlet-manager:no-continuation?
(lambda (the-exn)
((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))]
[exn:fail:servlet:instance?
(lambda (the-exn)
(default-servlet-instance-expiration-handler req))]
[(lambda (x) #t)
(lambda (the-exn) (responders-servlet-loading uri the-exn))])
(define the-servlet (url->servlet uri))
@ -87,10 +74,7 @@
[current-directory (servlet-directory the-servlet)]
[current-namespace (servlet-namespace the-servlet)])
(with-handlers ([(lambda (x) #t)
(lambda (exn)
(responders-servlet
(request-uri req)
exn))])
(lambda (exn) (responders-servlet uri exn))])
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-prompt

11
collects/web-server/private/launch.ss
View File

@ -18,7 +18,7 @@
default)))
(define ssl (make-parameter #f))
(define port (make-parameter 80))
(define port (make-parameter #f))
(define configuration@
(parse-command-line
@ -27,7 +27,7 @@
`((once-each
[("--ssl")
,(lambda (flag)
(port 443)
(unless (port) (port 443))
(ssl #t))
("Run with SSL using server-cert.pem and private-key.pem in the current directory, with 443 as the default port.")]
[("-f" "--configuration-table")
@ -41,7 +41,10 @@
("Use an alternate configuration table" "file-name")]
[("-p" "--port")
,(lambda (flag the-port)
(port (string->number the-port)))
(let ([p (string->number the-port)])
(if (and (integer? p) (<= 1 p 65535))
(port p)
(error 'web-server "expecting a valid port number, got \"~a\"" the-port))))
("Use an alternate network port." "port")]
[("-a" "--ip-address")
,(lambda (flag ip-address)
@ -58,7 +61,7 @@
(lambda (flags)
(configuration-table->web-config@
(extract-flag 'config flags default-configuration-table-path)
#:port (port)
#:port (or (port) 80)
#:listen-ip (extract-flag 'ip-address flags #f)))
'()))

27
collects/web-server/private/mime-types.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require mzlib/contract
mzlib/plt-match
mzlib/string)
(require scheme/contract
scheme/match
scheme/promise)
(require "util.ss"
web-server/http)
(provide/contract
@ -17,13 +17,9 @@
(match (read-line (current-input-port) 'any)
[(? eof-object?)
(void)]
[(regexp #"^([^\t ]+)[\t ]+(.+)$"
(list s type exts))
(for-each (lambda (ext)
(hash-set! MIME-TYPE-TABLE
(lowercase-symbol! ext)
type))
(regexp-split #" " exts))
[(regexp #rx#"^([^\t ]+)[\t ]+(.+)$" (list _ type exts))
(for ([ext (in-list (regexp-split #" " exts))])
(hash-set! MIME-TYPE-TABLE (lowercase-symbol! ext) type))
(loop)]
[_
(loop)]))))
@ -36,12 +32,11 @@
;; 1. Can we determine the mime type based on file contents?
;; 2. Assuming that 7-bit ASCII is correct for mime-type
(define (make-path->mime-type a-path)
(define MIME-TYPE-TABLE (read-mime-types a-path))
(define file-suffix-regexp (byte-regexp #".*\\.([^\\.]*$)"))
(define MIME-TYPE-TABLE (delay (read-mime-types a-path)))
(lambda (path)
(match (regexp-match file-suffix-regexp (path->bytes path))
[(list path-bytes sffx)
(hash-ref MIME-TYPE-TABLE
(match (path->bytes path)
[(regexp #rx#".*\\.([^\\.]*$)" (list _ sffx))
(hash-ref (force MIME-TYPE-TABLE)
(lowercase-symbol! sffx)
(lambda () TEXT/HTML-MIME-TYPE))]
TEXT/HTML-MIME-TYPE)]
[_ TEXT/HTML-MIME-TYPE])))

4
collects/web-server/private/servlet.ss
View File

@ -4,7 +4,6 @@
web-server/http)
(define servlet-prompt (make-continuation-prompt-tag 'servlet))
(define-struct (exn:fail:servlet:instance exn:fail) ())
(define-struct servlet (custodian namespace manager directory handler)
#:mutable)
(define-struct execution-context (request))
@ -18,9 +17,6 @@
(provide/contract
[servlet-prompt continuation-prompt-tag?]
[struct (exn:fail:servlet:instance exn:fail)
([message string?]
[continuation-marks continuation-mark-set?])]
[struct servlet
([custodian custodian?]
[namespace namespace?]

36
collects/web-server/scribblings/servlet-env.scrbl
View File

@ -6,7 +6,10 @@
@(require (for-label web-server/servlet-env
web-server/http
web-server/managers/lru
web-server/private/util
web-server/configuration/configuration-table
web-server/configuration/responders
web-server/dispatchers/dispatch-log
scheme/list))
@defmodule[web-server/servlet-env]{
@ -82,12 +85,16 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
[#:launch-browser? launch-browser? boolean? (not command-line?)]
[#:quit? quit? boolean? (not command-line?)]
[#:banner? banner? boolean? (not command-line?)]
[#:listen-ip listen-ip string? "127.0.0.1"]
[#:listen-ip listen-ip (or/c false/c string?) "127.0.0.1"]
[#:port port number? 8000]
[#:ssl? ssl? boolean? #f]
[#:servlet-path servlet-path string?
"/servlets/standalone.ss"]
[#:servlet-regexp servlet-regexp regexp?
(regexp (format "^~a$" (regexp-quote servlet-path)))]
(regexp
(format
"^~a$"
(regexp-quote servlet-path)))]
[#:stateless? stateless? boolean? #f]
[#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))]
[#:servlet-namespace servlet-namespace (listof module-path?) empty]
@ -96,9 +103,24 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
[#:servlets-root servlets-root path? (build-path server-root-path "htdocs")]
[#:servlet-current-directory servlet-current-directory path? servlets-root]
[#:file-not-found-responder file-not-found-responder
(gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))]
(request? . -> . response?)
(gen-file-not-found-responder
(build-path
server-root-path
"conf"
"not-found.html"))]
[#:mime-types-path mime-types-path path?
(build-path server-root-path "mime.types")])
(let ([p (build-path
server-root-path
"mime.types")])
(if (file-exists? p)
p
(build-path
(directory-part
default-configuration-table-path)
"mime.types")))]
[#:log-file log-file path? #f]
[#:log-format log-format symbol? 'apache-default])
void]{
This sets up and starts a fairly default server instance.
@ -115,6 +137,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
The server listens on @scheme[listen-ip] and port @scheme[port].
If @scheme[ssl?] is true, then the server runs in HTTPS mode with @filepath{<server-root-path>/server-cert.pem}
and @filepath{<server-root-path>/private-key.pem} as the certificates and private keys
The servlet is loaded with @scheme[manager]
as its continuation manager. (The default manager limits the amount of memory to 64 MB and
deals with memory pressure as discussed in the @scheme[make-threshold-LRU-manager] documentation.)
@ -133,6 +158,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
running from the command line, in which case the @scheme[command-line?] option controls similar options.
MIME types are looked up at @scheme[mime-types-path].
If @scheme[log-file] is given, then it used to log requests using @scheme[log-format] as the format. Allowable formats
are those allowed by @scheme[log-format->format].
}
}

248
collects/web-server/servlet-env.ss
View File

@ -3,13 +3,17 @@
#lang scheme/base
(require (prefix-in net: net/sendurl)
scheme/contract
scheme/list)
scheme/list
scheme/unit
net/tcp-unit
net/tcp-sig
net/ssl-tcp-unit)
(require web-server/web-server
web-server/managers/lru
web-server/managers/manager
web-server/private/servlet
web-server/configuration/namespace
web-server/private/cache-table
web-server/private/cache-table
web-server/http
web-server/private/util
web-server/configuration/responders
@ -18,11 +22,12 @@
web-server/configuration/configuration-table
web-server/servlet/setup
(prefix-in lift: web-server/dispatchers/dispatch-lift)
(prefix-in fsmap: web-server/dispatchers/filesystem-map)
(prefix-in fsmap: web-server/dispatchers/filesystem-map)
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
(prefix-in files: web-server/dispatchers/dispatch-files)
(prefix-in filter: web-server/dispatchers/dispatch-filter)
(prefix-in servlets: web-server/dispatchers/dispatch-servlets))
(prefix-in filter: web-server/dispatchers/dispatch-filter)
(prefix-in servlets: web-server/dispatchers/dispatch-servlets)
(prefix-in log: web-server/dispatchers/dispatch-log))
(define send-url (make-parameter net:send-url))
@ -30,93 +35,117 @@
(lift:make
(lambda (request)
(thread (lambda () (sleep 2) (semaphore-post sema)))
`(html
(head
(title "Server Stopped")
(link ([rel "stylesheet"] [href "/error.css"])))
(body
(div ([class "section"])
(div ([class "title"]) "Server Stopped")
(p "Return to DrScheme.")))))))
`(html (head (title "Server Stopped")
(link ([rel "stylesheet"] [href "/error.css"])))
(body (div ([class "section"])
(div ([class "title"]) "Server Stopped")
(p "Return to DrScheme.")))))))
(provide/contract
[serve/servlet (((request? . -> . response?))
(#:command-line? boolean?
#:launch-browser? boolean?
#:quit? boolean?
#:banner? boolean?
#:listen-ip string?
#:port number?
#:manager manager?
#:servlet-namespace (listof module-path?)
#:server-root-path path?
#:stateless? boolean?
#:extra-files-paths (listof path?)
#:servlets-root path?
#:file-not-found-responder (request? . -> . response?)
#:mime-types-path path?
#:servlet-path string?
#:servlet-regexp regexp?)
#:launch-browser? boolean?
#:quit? boolean?
#:banner? boolean?
#:listen-ip (or/c false/c string?)
#:port number?
#:ssl? boolean?
#:manager manager?
#:servlet-namespace (listof module-path?)
#:server-root-path path?
#:stateless? boolean?
#:extra-files-paths (listof path?)
#:servlets-root path?
#:file-not-found-responder (request? . -> . response?)
#:mime-types-path path?
#:servlet-path string?
#:servlet-regexp regexp?
#:log-file (or/c false/c path?))
. ->* .
void)])
(define (serve/servlet start
#:command-line?
[command-line? #f]
#:launch-browser?
[launch-browser? (not command-line?)]
#:quit?
[quit? (not command-line?)]
#:banner?
[banner? (not command-line?)]
#:listen-ip
[listen-ip "127.0.0.1"]
#:port
[the-port 8000]
#:manager
[manager
(make-threshold-LRU-manager
(lambda (request)
`(html (head (title "Page Has Expired."))
(body (p "Sorry, this page has expired. Please go back."))))
(* 64 1024 1024))]
#:servlet-path
[servlet-path "/servlets/standalone.ss"]
#:servlet-regexp
[servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))]
#:stateless?
[stateless? #f]
#:servlet-namespace
[servlet-namespace empty]
#:server-root-path
[server-root-path (directory-part default-configuration-table-path)]
#:extra-files-paths
[extra-files-paths (list (build-path server-root-path "htdocs"))]
#:servlets-root
[servlets-root (build-path server-root-path "htdocs")]
#:servlet-current-directory
[servlet-current-directory servlets-root]
#:file-not-found-responder
[file-not-found-responder (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))]
#:mime-types-path
[mime-types-path (build-path server-root-path "mime.types")])
;; utility for conveniently chaining dispatchers
(define (dispatcher-sequence . dispatchers)
(let loop ([ds dispatchers] [r '()])
(cond [(null? ds) (apply sequencer:make (reverse r))]
[(not (car ds)) (loop (cdr ds) r)]
[(list? (car ds)) (loop (append (car ds) (cdr ds)) r)]
[else (loop (cdr ds) (cons (car ds) r))])))
(define (serve/servlet
start
#:command-line?
[command-line? #f]
#:launch-browser?
[launch-browser? (not command-line?)]
#:quit?
[quit? (not command-line?)]
#:banner?
[banner? (not command-line?)]
#:listen-ip
[listen-ip "127.0.0.1"]
#:port
[the-port 8000]
#:ssl?
[ssl? #f]
#:manager
[manager
(make-threshold-LRU-manager
(lambda (request)
`(html (head (title "Page Has Expired."))
(body (p "Sorry, this page has expired. Please go back."))))
(* 64 1024 1024))]
#:servlet-path
[servlet-path "/servlets/standalone.ss"]
#:servlet-regexp
[servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))]
#:stateless?
[stateless? #f]
#:servlet-namespace
[servlet-namespace empty]
#:server-root-path
[server-root-path (directory-part default-configuration-table-path)]
#:extra-files-paths
[extra-files-paths (list (build-path server-root-path "htdocs"))]
#:servlets-root
[servlets-root (build-path server-root-path "htdocs")]
#:servlet-current-directory
[servlet-current-directory servlets-root]
#:file-not-found-responder
[file-not-found-responder
(gen-file-not-found-responder
(build-path server-root-path "conf" "not-found.html"))]
#:mime-types-path
[mime-types-path (let ([p (build-path server-root-path "mime.types")])
(if (file-exists? p)
p
(build-path
(directory-part default-configuration-table-path)
"mime.types")))]
#:log-file
[log-file #f]
#:log-format
[log-format 'apache-default])
(define standalone-url
(format "http://localhost:~a~a" the-port servlet-path))
(string-append (if ssl? "https" "http")
"://localhost"
(if (and (not ssl?) (= the-port 80))
"" (format ":~a" the-port))
servlet-path))
(define make-servlet-namespace
(make-make-servlet-namespace
#:to-be-copied-module-specs servlet-namespace))
(make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace))
(define sema (make-semaphore 0))
(define servlet-box (box #f))
(define dispatcher
(sequencer:make
(if quit?
(filter:make
#rx"^/quit$"
(quit-server sema))
(lambda _ (next-dispatcher)))
(dispatcher-sequence
(and log-file (log:make #:format (log:log-format->format log-format)
#:log-path log-file))
(and quit? (filter:make #rx"^/quit$" (quit-server sema)))
(filter:make
servlet-regexp
(servlets:make
@ -129,8 +158,8 @@
#:additional-specs
default-module-specs)])
(if stateless?
(make-stateless.servlet servlet-current-directory start)
(make-v2.servlet servlet-current-directory manager start)))])
(make-stateless.servlet servlet-current-directory start)
(make-v2.servlet servlet-current-directory manager start)))])
(set-box! servlet-box servlet)
servlet)))))
(let-values ([(clear-cache! url->servlet)
@ -142,35 +171,40 @@
(make-default-path->servlet
#:make-servlet-namespace make-servlet-namespace))])
(servlets:make url->servlet))
(apply sequencer:make
(map (lambda (extra-files-path)
(files:make
#:url->path (fsmap:make-url->path
extra-files-path)
#:path->mime-type (make-path->mime-type mime-types-path)
#:indices (list "index.html" "index.htm")))
extra-files-paths))
(files:make
#:url->path (fsmap:make-url->path
(build-path server-root-path "htdocs"))
#:path->mime-type (make-path->mime-type (build-path server-root-path "mime.types"))
(map (lambda (extra-files-path)
(files:make
#:url->path (fsmap:make-url->path extra-files-path)
#:path->mime-type (make-path->mime-type mime-types-path)
#:indices (list "index.html" "index.htm")))
extra-files-paths)
(files:make
#:url->path (fsmap:make-url->path (build-path server-root-path "htdocs"))
#:path->mime-type (make-path->mime-type mime-types-path)
#:indices (list "index.html" "index.htm"))
(lift:make file-not-found-responder)))
(define shutdown-server
(serve #:dispatch dispatcher
#:listen-ip listen-ip
#:port the-port))
#:port the-port
#:tcp@ (if ssl?
(let ()
(define-unit-binding ssl-tcp@
(make-ssl-tcp@
(build-path server-root-path "server-cert.pem")
(build-path server-root-path "private-key.pem")
#f #f #f #f #f)
(import) (export tcp^))
ssl-tcp@)
tcp@)))
(when launch-browser?
((send-url) standalone-url #t))
(when banner?
(printf "Your Web application is running at ~a.~n" standalone-url)
(printf "Click 'Stop' at any time to terminate the Web Server.~n"))
(with-handlers
([exn:break?
(lambda (exn)
(when banner?
(printf "~nWeb Server stopped.~n"))
(shutdown-server))])
(semaphore-wait/enable-break sema))
; We shouldn't get here, because nothing posts to the semaphore. But just in case...
(shutdown-server))
(printf "Your Web application is running at ~a.\n" standalone-url)
(printf "Click 'Stop' at any time to terminate the Web Server.\n"))
(let ([bye (lambda ()
(when banner? (printf "\nWeb Server stopped.\n"))
(shutdown-server))])
(with-handlers ([exn:break? (lambda (exn) (bye))])
(semaphore-wait/enable-break sema)
;; We can get here if a /quit url is visited
(bye))))

33
collects/web-server/servlet/setup.ss
View File

@ -49,19 +49,26 @@
(lambda (req)
(define uri (request-uri req))
(define-values (instance-id handler)
(cond
[(continuation-url? uri)
=> (match-lambda
[(list instance-id k-id salt)
(values instance-id
(custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])]
[else
(values ((manager-create-instance manager) (exit-handler))
start)]))
(parameterize ([current-servlet-instance-id instance-id])
(handler req)))))
(with-handlers ([exn:fail:servlet-manager:no-instance?
(lambda (the-exn)
((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))]
[exn:fail:servlet-manager:no-continuation?
(lambda (the-exn)
((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))])
(define-values (instance-id handler)
(cond
[(continuation-url? uri)
=> (match-lambda
[(list instance-id k-id salt)
(values instance-id
(custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])]
[else
(values ((manager-create-instance manager) (exit-handler))
start)]))
(parameterize ([current-servlet-instance-id instance-id])
(handler req))))))
(define (make-stateless.servlet directory start)
(define ses

24
collects/web-server/web-server.ss
View File

@ -15,25 +15,25 @@
[serve
(->* (#:dispatch dispatcher/c)
(#:tcp@ unit?
#:port number?
#:listen-ip (or/c false/c string?)
#:max-waiting number?
#:initial-connection-timeout number?)
#:port number?
#:listen-ip (or/c false/c string?)
#:max-waiting number?
#:initial-connection-timeout number?)
(-> void))]
[serve/ports
(->* (#:dispatch dispatcher/c)
(#:tcp@ unit?
#:ports (listof number?)
#:listen-ip (or/c false/c string?)
#:max-waiting number?
#:initial-connection-timeout number?)
#:ports (listof number?)
#:listen-ip (or/c false/c string?)
#:max-waiting number?
#:initial-connection-timeout number?)
(-> void))]
[serve/ips+ports
(->* (#:dispatch dispatcher/c)
(#:tcp@ unit?
#:ips+ports (listof (cons/c (or/c false/c string?) (listof number?)))
#:max-waiting number?
#:initial-connection-timeout number?)
#:ips+ports (listof (cons/c (or/c false/c string?) (listof number?)))
#:max-waiting number?
#:initial-connection-timeout number?)
(-> void))]
[do-not-return (-> void)]
[serve/web-config@ ((unit?) (#:tcp@ unit?) . ->* . (-> void?))])
@ -59,7 +59,7 @@
dispatch-server@/tcp@
(import dispatch-server-config^)
(export dispatch-server^))
(serve))
(define (serve/ports

13
doc/release-notes/drscheme/HISTORY.txt
View File

@ -1,3 +1,16 @@
------------------------------
Version 4.3
------------------------------
. minor bug fixes
------------------------------
Version 4.2
------------------------------
. contract library's function contract
combinatiors now preserve tail recursion.
------------------------------
Version 4.1
------------------------------

4
doc/release-notes/stepper/HISTORY.txt
View File

@ -1,6 +1,10 @@
Stepper
-------
Changes for v4.1.3:
Minor bug fixes.
Changes for v4.1.2:
None.

1
src/mred/wxme/wx_mpbrd.cxx
View File

@ -317,7 +317,6 @@ void wxMediaPasteboard::OnDefaultEvent(wxMouseEvent *event)
if (!admin)
return;
/* First, find clicked-on snip: */
x = event->x;
y = event->y;

30
src/mzscheme/src/eval.c
View File

@ -889,8 +889,12 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
return 1;
}
}
/* (void <omittable> ...) */
if (SAME_OBJ(scheme_void_proc, app->args[0])) {
/* ({void,list,list*,vector,vector-immutable} <omittable> ...) */
if (SAME_OBJ(scheme_void_proc, app->args[0])
|| SAME_OBJ(scheme_list_proc, app->args[0])
|| SAME_OBJ(scheme_list_star_proc, app->args[0])
|| SAME_OBJ(scheme_vector_proc, app->args[0])
|| SAME_OBJ(scheme_vector_immutable_proc, app->args[0])) {
note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) {
int i;
@ -905,10 +909,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
}
if ((vtype == scheme_application2_type)) {
/* (values <omittable>) or (void <omittable>) */
/* ({values,void,list,list*,vector,vector-immutable,box} <omittable>) */
Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
if (SAME_OBJ(scheme_values_func, app->rator)
|| SAME_OBJ(scheme_void_proc, app->rator)) {
|| SAME_OBJ(scheme_void_proc, app->rator)
|| SAME_OBJ(scheme_list_proc, app->rator)
|| SAME_OBJ(scheme_list_star_proc, app->rator)
|| SAME_OBJ(scheme_vector_proc, app->rator)
|| SAME_OBJ(scheme_vector_immutable_proc, app->rator)
|| SAME_OBJ(scheme_box_proc, app->rator)) {
note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) {
if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info))
@ -928,8 +937,14 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
return 1;
}
}
/* (void <omittable> <omittable>) */
if (SAME_OBJ(scheme_void_proc, app->rator)) {
/* ({void,cons,list,list*,vector,vector-immutable) <omittable> <omittable>) */
if (SAME_OBJ(scheme_void_proc, app->rator)
|| SAME_OBJ(scheme_cons_proc, app->rator)
|| SAME_OBJ(scheme_mcons_proc, app->rator)
|| SAME_OBJ(scheme_list_proc, app->rator)
|| SAME_OBJ(scheme_list_star_proc, app->rator)
|| SAME_OBJ(scheme_vector_proc, app->rator)
|| SAME_OBJ(scheme_vector_immutable_proc, app->rator)) {
note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) {
if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info)
@ -2507,7 +2522,8 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
}
}
if (SAME_OBJ(scheme_values_func, app->rator)
if ((SAME_OBJ(scheme_values_func, app->rator)
|| SAME_OBJ(scheme_list_star_proc, app->rator))
&& scheme_omittable_expr(app->rand, 1, -1, 0, info)) {
info->preserves_marks = 1;
info->single_result = 1;

54
src/mzscheme/src/jit.c
View File

@ -1256,8 +1256,7 @@ static void *malloc_double(void)
#endif
#ifdef CAN_INLINE_ALLOC
static void *make_list_code;
# define make_list make_list_code
static void *make_list_code, *make_list_star_code;
#else
static Scheme_Object *make_list(long n)
{
@ -1270,6 +1269,17 @@ static Scheme_Object *make_list(long n)
return l;
}
static Scheme_Object *make_list_star(long n)
{
GC_CAN_IGNORE Scheme_Object **rs = MZ_RUNSTACK;
GC_CAN_IGNORE Scheme_Object *l = rs[--n];
while (n--) {
l = cons(rs[n], l);
}
return l;
}
#endif
#if !defined(CAN_INLINE_ALLOC)
@ -4077,6 +4087,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "vector-immutable")
|| IS_NAMED_PRIM(rator, "vector")) {
return generate_vector_alloc(jitter, rator, NULL, app, NULL);
} else if (IS_NAMED_PRIM(rator, "list*")) {
/* on a single argument, `list*' is identity */
mz_runstack_skipped(jitter, 1);
generate_non_tail(app->rand, jitter, 0, 1);
CHECK_LIMIT();
mz_runstack_unskipped(jitter, 1);
return 1;
} else if (IS_NAMED_PRIM(rator, "list")) {
mz_runstack_skipped(jitter, 1);
generate_non_tail(app->rand, jitter, 0, 1);
@ -4553,7 +4570,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
(void)jit_movi_p(JIT_R0, scheme_void);
return 1;
} else if (IS_NAMED_PRIM(rator, "cons")) {
} else if (IS_NAMED_PRIM(rator, "cons")
|| IS_NAMED_PRIM(rator, "list*")) {
LOG_IT(("inlined cons\n"));
generate_two_args(app->rand1, app->rand2, jitter, 1);
@ -4748,8 +4766,12 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
} else if (IS_NAMED_PRIM(rator, "vector-immutable")
|| IS_NAMED_PRIM(rator, "vector")) {
return generate_vector_alloc(jitter, rator, app, NULL, NULL);
} else if (IS_NAMED_PRIM(rator, "list")) {
} else if (IS_NAMED_PRIM(rator, "list")
|| IS_NAMED_PRIM(rator, "list*")) {
int c = app->num_args;
int star;
star = IS_NAMED_PRIM(rator, "list*");
if (c)
generate_app(app, NULL, c, jitter, 0, 0, 1);
@ -4757,13 +4779,19 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
#ifdef CAN_INLINE_ALLOC
jit_movi_l(JIT_R2, c);
(void)jit_calli(make_list_code);
if (star)
(void)jit_calli(make_list_star_code);
else
(void)jit_calli(make_list_code);
#else
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
jit_movi_l(JIT_R0, c);
mz_prepare(1);
jit_pusharg_l(JIT_R0);
(void)mz_finish(make_list);
if (star)
(void)mz_finish(make_list_star);
else
(void)mz_finish(make_list);
jit_retval(JIT_R0);
#endif
@ -7252,13 +7280,21 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
#ifdef CAN_INLINE_ALLOC
/* *** make_list_code *** */
/* R2 has length, args are on runstack */
{
for (i = 0; i < 2; i++) {
jit_insn *ref, *refnext;
make_list_code = jit_get_ip().ptr;
if (i == 0)
make_list_code = jit_get_ip().ptr;
else
make_list_star_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE);
(void)jit_movi_p(JIT_R0, &scheme_null);
if (i == 0)
(void)jit_movi_p(JIT_R0, &scheme_null);
else {
jit_subi_l(JIT_R2, JIT_R2, JIT_WORD_SIZE);
jit_ldxr_p(JIT_R0, JIT_RUNSTACK, JIT_R2);
}
__START_SHORT_JUMPS__(1);
ref = jit_beqi_l(jit_forward(), JIT_R2, 0);

23
src/mzscheme/src/list.c
View File

@ -27,7 +27,11 @@
/* globals */
Scheme_Object scheme_null[1];
Scheme_Object *scheme_cons_proc;
Scheme_Object *scheme_mcons_proc;
Scheme_Object *scheme_list_proc;
Scheme_Object *scheme_list_star_proc;
Scheme_Object *scheme_box_proc;
/* locals */
static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]);
@ -155,7 +159,9 @@ scheme_init_list (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("mpair?", p, env);
REGISTER_SO(scheme_cons_proc);
p = scheme_make_noncm_prim(cons_prim, "cons", 2, 2);
scheme_cons_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant ("cons", p, env);
@ -167,7 +173,9 @@ scheme_init_list (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("cdr", p, env);
REGISTER_SO(scheme_mcons_proc);
p = scheme_make_noncm_prim(mcons_prim, "mcons", 2, 2);
scheme_mcons_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant ("mcons", p, env);
@ -205,11 +213,14 @@ scheme_init_list (Scheme_Env *env)
| SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant ("list", p, env);
scheme_add_global_constant ("list*",
scheme_make_immed_prim(list_star_prim,
"list*",
1, -1),
env);
REGISTER_SO(scheme_list_star_proc);
p = scheme_make_immed_prim(list_star_prim, "list*", 1, -1);
scheme_list_star_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant ("list*", p, env);
scheme_add_global_constant("immutable?",
scheme_make_folding_prim(immutablep,
"immutable?",
@ -409,7 +420,9 @@ scheme_init_list (Scheme_Env *env)
1, 1, 1),
env);
REGISTER_SO(scheme_box_proc);
p = scheme_make_immed_prim(box, BOX, 1, 1);
scheme_box_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant(BOX, p, env);

8
src/mzscheme/src/read.c
View File

@ -4371,6 +4371,8 @@ static Scheme_Object *read_compact_k(void)
return read_compact(port, p->ku.k.i1);
}
int dump_info = 0;
static Scheme_Object *read_compact(CPort *port, int use_stack)
{
#define BLK_BUF_SIZE 32
@ -4396,6 +4398,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
ZO_CHECK(port->pos < port->size);
ch = CP_GETC(port);
if (dump_info)
printf("%d %d %d\n", ch, port->pos, need_car);
switch(cpt_branch[ch]) {
case CPT_ESCAPE:
{
@ -4451,6 +4456,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
case CPT_SYMREF:
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
if (dump_info)
printf("%d\n", l);
v = port->symtab[l];
if (!v) {
long save_pos = port->pos;
@ -5261,6 +5268,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
len = symtabsize;
for (j = 1; j < len; j++) {
if (!symtab[j]) {
if (dump_info) printf("at %ld %ld\n", j, rp->pos);
v = read_compact(rp, 0);
symtab[j] = v;
} else {

6
src/mzscheme/src/schpriv.h
View File

@ -260,7 +260,13 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_procedure_p_proc;
extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_cons_proc;
extern Scheme_Object *scheme_mcons_proc;
extern Scheme_Object *scheme_list_proc;
extern Scheme_Object *scheme_list_star_proc;
extern Scheme_Object *scheme_vector_proc;
extern Scheme_Object *scheme_vector_immutable_proc;
extern Scheme_Object *scheme_box_proc;
extern Scheme_Object *scheme_call_with_values_proc;
extern Scheme_Object *scheme_make_struct_type_proc;
extern Scheme_Object *scheme_current_inspector_proc;

8
src/mzscheme/src/vector.c
View File

@ -25,6 +25,10 @@
#include "schpriv.h"
/* globals */
Scheme_Object *scheme_vector_proc;
Scheme_Object *scheme_vector_immutable_proc;
/* locals */
static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_vector (int argc, Scheme_Object *argv[]);
@ -53,13 +57,17 @@ scheme_init_vector (Scheme_Env *env)
1, 2),
env);
REGISTER_SO(scheme_vector_proc);
p = scheme_make_immed_prim(vector, "vector", 0, -1);
scheme_vector_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("vector", p, env);
REGISTER_SO(scheme_vector_immutable_proc);
p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1);
scheme_vector_immutable_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED);

26
src/wxmac/src/mac/wx_dccan2.cc
View File

@ -533,6 +533,32 @@ void wxCanvasDC::DrawPoint(double x, double y)
if (!current_pen || current_pen->GetStyle() == wxTRANSPARENT)
return;
if (anti_alias) {
double xx, yy;
CGContextRef cg;
SetCurrentDC(TRUE);
cg = GetCG();
CGContextSaveGState(cg);
xx = SmoothingXFormX(x);
yy = SmoothingXFormY(y);
CGContextMoveToPoint(cg, xx, yy);
CGContextAddLineToPoint(cg, xx, yy);
wxMacSetCurrentTool(kPenTool);
CGContextStrokePath(cg);
wxMacSetCurrentTool(kNoTool);
CGContextRestoreGState(cg);
ReleaseCurrentDC();
return;
}
SetCurrentDC();
wxMacSetCurrentTool(kPenTool);
wxMacDrawPoint(XLOG2DEV(x), YLOG2DEV(y));