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

sync to trunk

Browse Source 
svn: r14750
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-08 20:11:09 +00:00
parent f6f9b20f17
commit 0ddf7338cb
33 changed files with 2407 additions and 2133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

200
collects/framework/preferences.ss
View File

@ -38,12 +38,8 @@ the state transitions / contracts are:
(define exn:make-unknown-preference make-exn:unknown-preference) (define exn:make-unknown-preference make-exn:unknown-preference)
(define exn:struct:unknown-preference struct:exn:unknown-preference) (define exn:struct:unknown-preference struct:exn:unknown-preference)
(define old-preferences-symbol 'plt:framework-prefs) (define preferences:low-level-put-preferences (make-parameter put-preferences))
(define old-preferences (make-hasheq)) (define preferences:low-level-get-preference (make-parameter get-preference))
(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
(for-each
(λ (line) (hash-set! old-preferences (car line) (cadr line)))
old-prefs))
(define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p))) (define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p)))
@ -51,12 +47,6 @@ the state transitions / contracts are:
;; the current values of the preferences ;; the current values of the preferences
(define preferences (make-hasheq)) (define preferences (make-hasheq))
;; marshalled : hash-table[sym -o> any]
;; the values of the preferences, as read in from the disk
;; each symbol will only be mapped in one of the preferences
;; hash-table and this hash-table, but not both.
(define marshalled (make-hasheq))
;; marshall-unmarshall : sym -o> un/marshall ;; marshall-unmarshall : sym -o> un/marshall
(define marshall-unmarshall (make-hasheq)) (define marshall-unmarshall (make-hasheq))
@ -67,11 +57,11 @@ the state transitions / contracts are:
(define defaults (make-hasheq)) (define defaults (make-hasheq))
;; these four functions determine the state of a preference ;; these four functions determine the state of a preference
(define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref)) (define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref))
(define (pref-default-set? pref) (hash-table-bound? defaults pref)) (define (pref-default-set? pref) (hash-has-key? defaults pref))
(define (pref-can-init? pref) (define (pref-can-init? pref)
(and (not snapshot-grabbed?) (and (not snapshot-grabbed?)
(not (hash-table-bound? preferences pref)))) (not (hash-has-key? preferences pref))))
;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any)) ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
(define-struct un/marshall (marshall unmarshall)) (define-struct un/marshall (marshall unmarshall))
@ -86,35 +76,32 @@ the state transitions / contracts are:
;; this is used as a wrapped to deal with the problem that different procedures might be eq?. ;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
(define-struct pref-callback (cb)) (define-struct pref-callback (cb))
;; used to detect missing hash entries
(define none (gensym 'none))
;; get : symbol -> any ;; get : symbol -> any
;; return the current value of the preference `p' ;; return the current value of the preference `p'
;; exported ;; exported
(define (preferences:get p) (define (preferences:get p)
(define v (hash-ref preferences p none))
(cond (cond
;; if this is found, we can just return it immediately
[(not (eq? v none))
v]
;; first time reading this, check the file & unmarshall value, if
;; it's not there, use the default
[(pref-default-set? p) [(pref-default-set? p)
(let* (;; try to read the preferece from the preferences file
;; unmarshall, if required [v ((preferences:low-level-get-preference)
(when (hash-table-bound? marshalled p) (add-pref-prefix p) (λ () none))]
;; if `preferences' is already bound, that means the unmarshalled value isn't useful. [v (if (eq? v none)
(unless (hash-table-bound? preferences p) ;; no value read, take the default value
(hash-set! preferences p (unmarshall-pref p (hash-ref marshalled p)))) (default-value (hash-ref defaults p))
(hash-remove! marshalled p)) ;; found a saved value, unmarshall it
(unmarshall-pref p v))])
;; if there is no value in the preferences table, but there is one ;; set the value for future reference and return it
;; in the old version preferences file, take that: (hash-set! preferences p v)
(unless (hash-table-bound? preferences p) v)]
(when (hash-table-bound? old-preferences p)
(hash-set! preferences p (unmarshall-pref p (hash-ref old-preferences p)))))
;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore)
(when (hash-table-bound? old-preferences p)
(hash-remove! old-preferences p))
;; if it still isn't set, take the default value
(unless (hash-table-bound? preferences p)
(hash-set! preferences p (default-value (hash-ref defaults p))))
(hash-ref preferences p)]
[(not (pref-default-set? p)) [(not (pref-default-set? p))
(raise-unknown-preference-error (raise-unknown-preference-error
'preferences:get 'preferences:get
@ -155,8 +142,6 @@ the state transitions / contracts are:
values)) values))
(void)) (void))
(define preferences:low-level-put-preferences (make-parameter put-preferences))
(define (raise-unknown-preference-error sym fmt . args) (define (raise-unknown-preference-error sym fmt . args)
(raise (exn:make-unknown-preference (raise (exn:make-unknown-preference
(string-append (format "~a: " sym) (apply format fmt args)) (string-append (format "~a: " sym) (apply format fmt args))
@ -229,11 +214,6 @@ the state transitions / contracts are:
[(not (pref-can-init? p)) [(not (pref-can-init? p))
(error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)])) (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
(define (hash-table-bound? ht s)
(let/ec k
(hash-ref ht s (λ () (k #f)))
#t))
(define (preferences:restore-defaults) (define (preferences:restore-defaults)
(hash-for-each (hash-for-each
defaults defaults
@ -248,12 +228,7 @@ the state transitions / contracts are:
(unless default-okay? (unless default-okay?
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
p checker default-okay? default-value)) p checker default-okay? default-value))
(hash-set! defaults p (make-default default-value checker)) (hash-set! defaults p (make-default default-value checker)))]
(let/ec k
(let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))])
;; if there is no preference saved, we just don't do anything.
;; `get' notices this case.
(hash-set! marshalled p m))))]
[(not (pref-can-init? p)) [(not (pref-can-init? p))
(error 'preferences:set-default (error 'preferences:set-default
"tried to call set-default for preference ~e but it cannot be configured any more" "tried to call set-default for preference ~e but it cannot be configured any more"
@ -355,83 +330,77 @@ the state transitions / contracts are:
((p f) ((p f)
((weak? #f))) ((weak? #f)))
@{This function adds a callback which is called with a symbol naming a @{This function adds a callback which is called with a symbol naming a
preference and its value, when the preference changes. preference and its value, when the preference changes.
@scheme[preferences:add-callback] returns a thunk, which when @scheme[preferences:add-callback] returns a thunk, which when
invoked, removes the callback from this preference. invoked, removes the callback from this preference.
If @scheme[weak?] is true, the preferences system will only hold on to If @scheme[weak?] is true, the preferences system will only hold on to
the callback weakly. the callback weakly.
The callbacks will be called in the order in which they were added. The callbacks will be called in the order in which they were added.
If you are adding a callback for a preference that requires If you are adding a callback for a preference that requires
marshalling and unmarshalling, you must set the marshalling and marshalling and unmarshalling, you must set the marshalling and
unmarshalling functions by calling unmarshalling functions by calling
@scheme[preferences:set-un/marshall] before adding a callback. @scheme[preferences:set-un/marshall] before adding a callback.
This function raises This function raises
@index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]} @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
@scheme[exn:unknown-preference] @scheme[exn:unknown-preference]
if the preference has not been set.}) if the preference has not been set.})
(proc-doc/names (proc-doc/names
preferences:set-default preferences:set-default
(symbol? any/c (any/c . -> . any) . -> . void?) (symbol? any/c (any/c . -> . any) . -> . void?)
(symbol value test) (symbol value test)
@{This function must be called every time your application starts up, before any call to @{This function must be called every time your application starts up, before
@scheme[preferences:get] or any call to @scheme[preferences:get] or @scheme[preferences:set]
@scheme[preferences:set] (for any given preference).
(for any given preference).
If you use If you use @scheme[preferences:set-un/marshall],
@scheme[preferences:set-un/marshall], you must call this function before calling it.
you must call this function before calling it.
This sets the default value of the preference @scheme[symbol] to This sets the default value of the preference @scheme[symbol] to
@scheme[value]. If the user has chosen a different setting, @scheme[value]. If the user has chosen a different setting,
the user's setting the user's setting will take precedence over the default value.
will take precedence over the default value.
The last argument, @scheme[test] is used as a safeguard. That function is The last argument, @scheme[test] is used as a safeguard. That function is
called to determine if a preference read in from a file is a valid called to determine if a preference read in from a file is a valid
preference. If @scheme[test] returns @scheme[#t], then the preference is preference. If @scheme[test] returns @scheme[#t], then the preference is
treated as valid. If @scheme[test] returns @scheme[#f] then the default is treated as valid. If @scheme[test] returns @scheme[#f] then the default is
used.}) used.})
(proc-doc/names (proc-doc/names
preferences:set-un/marshall preferences:set-un/marshall
(symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?) (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
(symbol marshall unmarshall) (symbol marshall unmarshall)
@{@scheme[preference:set-un/marshall] is used to specify marshalling and @{@scheme[preference:set-un/marshall] is used to specify marshalling and
unmarshalling functions for the preference unmarshalling functions for the preference
@scheme[symbol]. @scheme[marshall] will be called when the users saves their @scheme[symbol]. @scheme[marshall] will be called when the users saves their
preferences to turn the preference value for @scheme[symbol] into a preferences to turn the preference value for @scheme[symbol] into a
printable value. @scheme[unmarshall] will be called when the user's printable value. @scheme[unmarshall] will be called when the user's
preferences are read from the file to transform the printable value preferences are read from the file to transform the printable value
into its internal representation. If @scheme[preference:set-un/marshall] into its internal representation. If @scheme[preference:set-un/marshall]
is never called for a particular preference, the values of that is never called for a particular preference, the values of that
preference are assumed to be printable. preference are assumed to be printable.
If the unmarshalling function returns a value that does not meet the If the unmarshalling function returns a value that does not meet the
guard passed to guard passed to @scheme[preferences:set-default]
@scheme[preferences:set-default] for this preference, the default value is used.
for this preference, the default value is used.
The @scheme[marshall] function might be called with any value returned The @scheme[marshall] function might be called with any value returned
from @scheme[read] and it must not raise an error from @scheme[read] and it must not raise an error
(although it can return arbitrary results if it gets bad input). This might (although it can return arbitrary results if it gets bad input). This might
happen when the preferences file becomes corrupted, or is edited happen when the preferences file becomes corrupted, or is edited
by hand. by hand.
@scheme[preference:set-un/marshall] must be called before calling @scheme[preference:set-un/marshall] must be called before calling
@scheme[preferences:get], @scheme[preferences:get],@scheme[preferences:set].})
@scheme[preferences:set].})
(proc-doc/names (proc-doc/names
preferences:restore-defaults preferences:restore-defaults
(-> void?) (-> void?)
() ()
@{@scheme[(preferences:restore-defaults)] @{@scheme[(preferences:restore-defaults)] restores the users' configuration
restores the users's configuration to the to the default preferences.})
default preferences.})
(proc-doc/names (proc-doc/names
exn:make-unknown-preference exn:make-unknown-preference
@ -447,11 +416,17 @@ the state transitions / contracts are:
(parameter-doc (parameter-doc
preferences:low-level-put-preferences preferences:low-level-put-preferences
(parameter/c (-> (listof symbol?) (listof any/c) any)) (parameter/c ((listof symbol?) (listof any/c) . -> . any))
put-preference put-preferences
@{This parameter's value @{This parameter's value is called to save preference the preferences file.
is called to save preference the preferences. Its interface should Its interface should be just like mzlib's @scheme[put-preferences].})
be just like mzlib's @scheme[put-preference].})
(parameter-doc
preferences:low-level-get-preference
(parameter/c (->* [symbol?] [(-> any)] any))
get-preference
@{This parameter's value is called to get a preference from the preferences
file. Its interface should be just like mzlib's @scheme[get-preference].})
(proc-doc/names (proc-doc/names
preferences:snapshot? preferences:snapshot?
@ -459,16 +434,15 @@ the state transitions / contracts are:
(arg) (arg)
@{Determines if its argument is a preferences snapshot. @{Determines if its argument is a preferences snapshot.
See also See also @scheme[preferences:get-prefs-snapshot] and
@scheme[preferences:get-prefs-snapshot] and @scheme[preferences:restore-prefs-snapshot].})
@scheme[preferences:restore-prefs-snapshot].})
(proc-doc/names (proc-doc/names
preferences:restore-prefs-snapshot preferences:restore-prefs-snapshot
(-> preferences:snapshot? void?) (-> preferences:snapshot? void?)
(snapshot) (snapshot)
@{Restores the preferences saved in @scheme[snapshot]. @{Restores the preferences saved in @scheme[snapshot].
See also @scheme[preferences:get-prefs-snapshot].}) See also @scheme[preferences:get-prefs-snapshot].})
(proc-doc/names (proc-doc/names
preferences:get-prefs-snapshot preferences:get-prefs-snapshot

280
collects/lang/private/todo.ss Normal file
View File

@ -0,0 +1,280 @@
#lang scheme
;; If we eliminate char from HtDP/I, we need to add re-think
;; the following functions. Concrete proposals attached.
;; If you're in a hurry, look for QQQ.
#| QQQ: okay?
char-upcase: use string-upcase instead
char-downcase: use string-downcase instead
string: use string-append instead
|#
#| QQQ: I noticed an oddity:
substring consumes 2 or 3 arguments
|#
;; -----------------------------------------------------------------------------
;; auxiliary stuff, ignore
(require test-engine/scheme-tests)
(define 1-letter "1-letter string")
(define 1-letter* (format "~as" 1-letter))
;; Symbol Any -> Boolean
;; is this a 1-letter string?
(define (1-letter? tag s)
(unless (string? s)
(error tag "~a expected, not a string: ~e" 1-letter s))
(= (string-length s) 1))
;; Symbol Any -> Boolean
;; is s a list of 1-letter strings
;; effect: not a list, not a list of strings
(define (1-letter*? tag s)
(unless (list? s)
(error tag "list of ~a expected, not a list: ~e" 1-letter* s))
(for-each
(lambda (c)
(unless (string? c)
(error tag "list of ~a expected, not a string: ~e" 1-letter* c)))
s)
#; (lambda (s) (= 1 (string-length s)))
(andmap (compose (curry = 1) string-length) s))
(define-syntax (define-teach stx)
(syntax-case stx ()
[(_ level id expr)
(with-syntax ([level-id (datum->syntax
(syntax id)
(string->symbol
(format "~a-~a"
(syntax->datum (syntax level))
(syntax->datum (syntax id))))
(syntax id))])
(syntax (define level-id
(let ([id expr])
id))))]))
;; -----------------------------------------------------------------------------
(check-expect (beginner-string-ith "hell" 0) "h")
(check-error
(beginner-string-ith "hell" 4)
(string-append
"string-ith:"
" second argument must be between 0 and the length of the given string (4), given "
"4"))
(define-teach beginner string-ith
(lambda (s n)
(unless (string? s)
(error 'string-ith "first argument must be of type <string>, given ~e" s))
(unless (and (number? n) (integer? n) (>= n 0))
(error 'string-ith
"second argument must be of type <natural number>, given ~e"
n))
(unless (< n (string-length s))
(error 'string-ith
"second argument must be between 0 and the length of the given string (~s), given ~a"
(string-length s) n))
(string (string-ref s n))))
;; -----------------------------------------------------------------------------
;; QQQ: this would be a re-definition of a Scheme function. Should we rename?
(check-expect (beginner-make-string 3 "a") "aaa")
(check-error
(beginner-make-string 3 "ab")
(string-append "make-string: " 1-letter " expected, given "
(format "~s" "ab")))
(define-teach beginner make-string
(lambda (n s1)
(unless (and (number? n) (exact-integer? n) (>= n 0))
(error 'make-string "(exact) natural number expected, given ~e" n))
(unless (1-letter? 'make-string s1)
(error 'make-string "~a expected, given ~e" 1-letter s1))
(apply string-append (build-list n (lambda (i) s1)))))
;; -----------------------------------------------------------------------------
(check-expect (beginner-int->string 10) "\n")
(check-error
(beginner-int->string 56555)
(string-append
"int->string: exact integer in [0,55295] or [57344 1114111] expected, given "
"56555"))
(check-error
(beginner-int->string "A")
(string-append
"int->string: exact integer in [0,55295] or [57344 1114111] expected, given "
"A"))
(define-teach beginner int->string
(lambda (i)
(unless (and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111)))
(error 'int->string
"exact integer in [0,55295] or [57344 1114111] expected, given ~a"
i))
(string (integer->char i))))
;; -----------------------------------------------------------------------------
(check-expect (beginner-string->int "A") 65)
(check-error
(beginner-string->int 10)
(string-append
"string->int: " 1-letter " expected, not a string: "
"10"))
(check-error
(beginner-string->int "AB")
(string-append
"string->int: " 1-letter " expected, given "
(format "~s" "AB")))
(define-teach beginner string->int
(lambda (s)
(unless (1-letter? 'string->int s)
(error 'string->int "~a expected, given ~e" 1-letter s))
(char->integer (string-ref s 0))))
;; -----------------------------------------------------------------------------
(check-expect (beginner-explode "hello") (list "h" "e" "l" "l" "o"))
(check-error
(beginner-explode 10)
(string-append
"explode: string expected, given "
"10"))
(define-teach beginner explode
(lambda (s)
(unless (string? s)
(error 'explode "string expected, given ~e" s))
(map string (string->list s))))
;; -----------------------------------------------------------------------------
(check-expect (beginner-implode (list "h" "e" "l" "l" "o")) "hello")
(check-error
(beginner-implode 10)
(string-append
"implode: list of " 1-letter* " expected, not a list: "
"10"))
(check-error
(beginner-implode '("he" "l"))
(string-append
"implode: list of " 1-letter* " expected, given "
(format "~s" '("he" "l"))))
(define-teach beginner implode
(lambda (los)
(unless (1-letter*? 'implode los)
(error 'implode "list of ~a expected, given ~e" 1-letter* los))
(list->string (map (lambda (s) (string-ref s 0)) los))))
;; -----------------------------------------------------------------------------
(check-expect (beginner-string1-numeric? "0") true)
(check-expect (beginner-string1-numeric? "a") false)
(check-error
(beginner-string1-numeric? "ab")
(string-append "string1-numeric?: " 1-letter " expected, given "
(format "~s" "ab")))
(define-teach beginner string1-numeric?
;; is this: (number? (string->number s)) enough?
(lambda (s1)
(unless (1-letter? 'string1-numeric? s1)
(error 'string1-numeric? "~a expected, given ~e" 1-letter s1))
(char-numeric? (string-ref s1 0))))
;; -----------------------------------------------------------------------------
;; I used copying here and I feel awful.
(check-expect (beginner-string1-alphabetic? "0") false)
(check-expect (beginner-string1-alphabetic? "a") true)
(check-error
(beginner-string1-alphabetic? "ab")
(string-append "string1-alphabetic?: " 1-letter " expected, given "
(format "~s" "ab")))
(define-teach beginner string1-alphabetic?
;; is this
#;
(andmap (lambda (c)
(or (string<=? "A" x "Z") (string<=? "a" x "z")))
(string->list s))
;; enough?
(lambda (s1)
(unless (1-letter? 'string1-alphabetic? s1)
(error 'string1-alphabetic? "~a expected, given ~e" 1-letter s1))
(char-alphabetic? (string-ref s1 0))))
;; -----------------------------------------------------------------------------
(check-expect (beginner-string-whitespace? " ") true)
(check-expect (beginner-string-whitespace? " \t") true)
(check-expect (beginner-string-whitespace? "ABC") false)
(define-teach beginner string-whitespace?
(lambda (s)
(unless (string? s)
(error 'string-upper-case? "string expected, given ~e" s))
(andmap char-whitespace? (string->list s))))
;; -----------------------------------------------------------------------------
;; I copied the next two, and I feel awful, too.
(check-expect (beginner-string-upper-case? " ") false)
(check-expect (beginner-string-upper-case? "AB\t") false)
(check-expect (beginner-string-upper-case? "ABC") true)
(define-teach beginner string-upper-case?
(lambda (s)
(unless (string? s)
(error 'string-upper-case? "string expected, given ~e" s))
(andmap char-upper-case? (string->list s))))
;; -----------------------------------------------------------------------------
(check-expect (beginner-string-lower-case? " ") false)
(check-expect (beginner-string-lower-case? "ab\t") false)
(check-expect (beginner-string-lower-case? "abc") true)
(define-teach beginner string-lower-case?
(lambda (s)
(unless (string? s)
(error 'string-lower-case? "string expected, given ~e" s))
(andmap char-lower-case? (string->list s))))
;; -----------------------------------------------------------------------------
;; !!! redefinition !!! (and copy from teachprims.ss)
;; QQQ: do we need a new name????
(check-expect (intermediate-build-string 3 (lambda (x) "x")) "xxx")
(define-teach intermediate build-string
(lambda (n f)
(unless (and (number? n) (integer? n) (>= n 0))
(error 'build-string
"first argument must be of type <natural number>, given ~e"
n))
(unless (and (procedure? f) (procedure-arity-includes? f 1))
(error 'build-string
"second argument must be a <procedure> that accepts one argument, given ~e"
f))
(apply string-append
(build-list
n
(lambda (i)
(define r (f i))
(unless (1-letter? 'build-string r)
(error 'build-string
"second argument must be a <procedure> that produces a ~a, given ~e, which produced ~e for ~e"
1-letter f r i))
r)))))
(test)

3474
collects/mzlib/port.ss
View File

File diff suppressed because it is too large Load Diff

312
collects/redex/private/reduction-semantics.ss
View File

@ -199,6 +199,42 @@
[(_ orig-reduction-relation lang args ...) [(_ orig-reduction-relation lang args ...)
#'(do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...)])) #'(do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...)]))
;; the withs, freshs, and side-conditions come in backwards order
(define-for-syntax (bind-withs orig-name main stx body)
(let loop ([stx stx]
[body body])
(syntax-case stx (side-condition where fresh)
[() body]
[((where x e) y ...)
(loop #'(y ...) #`(term-let ([x (term e)]) #,body))]
[((side-condition s ...) y ...)
(loop #'(y ...) #`(and s ... #,body))]
[((fresh x) y ...)
(identifier? #'x)
(loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))]
[((fresh x name) y ...)
(identifier? #'x)
(loop #'(y ...)
#`(term-let ([x (let ([the-name (term name)])
(verify-name-ok '#,orig-name the-name)
(variable-not-in #,main the-name))])
#,body))]
[((fresh (y) (x ...)) z ...)
(loop #'(z ...)
#`(term-let ([(y #,'...)
(variables-not-in #,main
(map (λ (_ignore_) 'y)
(term (x ...))))])
#,body))]
[((fresh (y) (x ...) names) z ...)
(loop #'(z ...)
#`(term-let ([(y #,'...)
(let ([the-names (term names)]
[len-counter (term (x ...))])
(verify-names-ok '#,orig-name the-names len-counter)
(variables-not-in #,main the-names))])
#,body))])))
(define-struct successful (result)) (define-struct successful (result))
(define-syntax-set (do-reduction-relation) (define-syntax-set (do-reduction-relation)
@ -608,42 +644,6 @@
#,(bind-withs orig-name #'main sides/withs/freshs #,(bind-withs orig-name #'main sides/withs/freshs
#'(make-successful (term to))))))))))) #'(make-successful (term to)))))))))))
;; the withs, freshs, and side-conditions come in backwards order
(define (bind-withs orig-name main stx body)
(let loop ([stx stx]
[body body])
(syntax-case stx (side-condition where fresh)
[() body]
[((where x e) y ...)
(loop #'(y ...) #`(term-let ([x (term e)]) #,body))]
[((side-condition s ...) y ...)
(loop #'(y ...) #`(and s ... #,body))]
[((fresh x) y ...)
(identifier? #'x)
(loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))]
[((fresh x name) y ...)
(identifier? #'x)
(loop #'(y ...)
#`(term-let ([x (let ([the-name (term name)])
(verify-name-ok '#,orig-name the-name)
(variable-not-in #,main the-name))])
#,body))]
[((fresh (y) (x ...)) z ...)
(loop #'(z ...)
#`(term-let ([(y #,'...)
(variables-not-in #,main
(map (λ (_ignore_) 'y)
(term (x ...))))])
#,body))]
[((fresh (y) (x ...) names) z ...)
(loop #'(z ...)
#`(term-let ([(y #,'...)
(let ([the-names (term names)]
[len-counter (term (x ...))])
(verify-names-ok '#,orig-name the-names len-counter)
(variables-not-in #,main the-names))])
#,body))])))
(define (process-extras stx orig-name name-table extras) (define (process-extras stx orig-name name-table extras)
(let ([the-name #f] (let ([the-name #f]
[the-name-stx #f] [the-name-stx #f]
@ -1012,114 +1012,117 @@
(loop name (cdr names))]))]) (loop name (cdr names))]))])
(with-syntax ([(((tl-side-conds ...) ...) (with-syntax ([(((tl-side-conds ...) ...)
(tl-bindings ...)) (tl-bindings ...)
(extract-side-conditions (syntax-e #'name) stx #'((stuff ...) ...))]) (tl-side-cond/binds ...))
(parse-extras #'((stuff ...) ...))])
(let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) (let ([lang-nts (language-id-nts #'lang 'define-metafunction)])
(with-syntax ([(side-conditions-rewritten ...) (with-syntax ([(tl-withs ...) (map (λ (sc/b) (bind-withs syn-error-name '() sc/b #t))
(map (λ (x) (rewrite-side-conditions/check-errs (syntax->list #'(tl-side-cond/binds ...)))])
lang-nts (with-syntax ([(side-conditions-rewritten ...)
'define-metafunction (map (λ (x) (rewrite-side-conditions/check-errs
#t lang-nts
x)) 'define-metafunction
(syntax->list (syntax ((side-condition lhs (and tl-side-conds ...)) ...))))] #t
[dom-side-conditions-rewritten x))
(and dom-ctcs (syntax->list (syntax ((side-condition lhs tl-withs) ...))))]
(rewrite-side-conditions/check-errs [dom-side-conditions-rewritten
lang-nts (and dom-ctcs
'define-metafunction (rewrite-side-conditions/check-errs
#f lang-nts
dom-ctcs))] 'define-metafunction
[codom-side-conditions-rewritten #f
(rewrite-side-conditions/check-errs dom-ctcs))]
lang-nts [codom-side-conditions-rewritten
'define-metafunction (rewrite-side-conditions/check-errs
#f lang-nts
codom-contract)] 'define-metafunction
[(rhs-fns ...) #f
(map (λ (lhs rhs bindings) codom-contract)]
(let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)]) [(rhs-fns ...)
(with-syntax ([(names ...) names] (map (λ (lhs rhs bindings)
[(names/ellipses ...) names/ellipses] (let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)])
[rhs rhs] (with-syntax ([(names ...) names]
[((tl-var tl-exp) ...) bindings]) [(names/ellipses ...) names/ellipses]
(syntax [rhs rhs]
(λ (name bindings) [((tl-var tl-exp) ...) bindings])
(term-let-fn ((name name)) (syntax
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...) (λ (name bindings)
(term-let ([tl-var (term tl-exp)] ...) (term-let-fn ((name name))
(term rhs))))))))) (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
(syntax->list (syntax (lhs ...))) (term-let ([tl-var (term tl-exp)] ...)
(syntax->list (syntax (rhs ...))) (term rhs)))))))))
(syntax->list (syntax (tl-bindings ...))))] (syntax->list (syntax (lhs ...)))
[(name2 name-predicate) (generate-temporaries (syntax (name name)))] (syntax->list (syntax (rhs ...)))
[((side-cond ...) ...) (syntax->list (syntax (tl-bindings ...))))]
;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level [(name2 name-predicate) (generate-temporaries (syntax (name name)))]
(map (lambda (lhs scs) [((side-cond ...) ...)
(append ;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level
(let loop ([lhs lhs]) (map (lambda (lhs scs)
(syntax-case lhs (side-condition term) (append
[(side-condition pat (term sc)) (let loop ([lhs lhs])
(cons #'sc (loop #'pat))] (syntax-case lhs (side-condition term)
[_else null])) [(side-condition pat (term sc))
scs)) (cons #'sc (loop #'pat))]
(syntax->list #'(lhs ...)) [_else null]))
(syntax->list #'((tl-side-conds ...) ...)))] scs))
[(((bind-id . bind-pat) ...) ...) (syntax->list #'(lhs ...))
;; Also for pict, extract pattern bindings (syntax->list #'((tl-side-conds ...) ...)))]
(map extract-pattern-binds (syntax->list #'(lhs ...)))] [(((bind-id . bind-pat) ...) ...)
[(((rhs-bind-id . rhs-bind-pat) ...) ...) ;; Also for pict, extract pattern bindings
;; Also for pict, extract pattern bindings (map extract-pattern-binds (syntax->list #'(lhs ...)))]
(map extract-term-let-binds (syntax->list #'(rhs ...)))] [(((rhs-bind-id . rhs-bind-pat) ...) ...)
[(((where-id where-pat) ...) ...) ;; Also for pict, extract pattern bindings
;; Also for pict, extract where bindings (map extract-term-let-binds (syntax->list #'(rhs ...)))]
#'(tl-bindings ...)]) [(((where-id where-pat) ...) ...)
(syntax-property ;; Also for pict, extract where bindings
#`(begin #'(tl-bindings ...)])
(define-values (name2 name-predicate) (syntax-property
(let ([sc `(side-conditions-rewritten ...)] #`(begin
[dsc `dom-side-conditions-rewritten]) (define-values (name2 name-predicate)
(build-metafunction (let ([sc `(side-conditions-rewritten ...)]
lang [dsc `dom-side-conditions-rewritten])
sc (build-metafunction
(list rhs-fns ...) lang
#,(if prev-metafunction sc
(let ([term-fn (syntax-local-value prev-metafunction)]) (list rhs-fns ...)
#`(metafunc-proc-cps #,(term-fn-get-id term-fn))) #,(if prev-metafunction
#''()) (let ([term-fn (syntax-local-value prev-metafunction)])
#,(if prev-metafunction #`(metafunc-proc-cps #,(term-fn-get-id term-fn)))
(let ([term-fn (syntax-local-value prev-metafunction)]) #''())
#`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) #,(if prev-metafunction
#''()) (let ([term-fn (syntax-local-value prev-metafunction)])
(λ (f/dom cps rhss) #`(metafunc-proc-rhss #,(term-fn-get-id term-fn)))
(make-metafunc-proc #''())
(let ([name (lambda (x) (f/dom x))]) name) (λ (f/dom cps rhss)
(list (list (to-lw lhs-for-lw) (make-metafunc-proc
(list (to-lw/uq side-cond) ...) (let ([name (lambda (x) (f/dom x))]) name)
(list (cons (to-lw bind-id) (list (list (to-lw lhs-for-lw)
(to-lw bind-pat)) (list (to-lw/uq side-cond) ...)
... (list (cons (to-lw bind-id)
(cons (to-lw rhs-bind-id) (to-lw bind-pat))
(to-lw/uq rhs-bind-pat)) ...
... (cons (to-lw rhs-bind-id)
(cons (to-lw where-id) (to-lw/uq rhs-bind-pat))
(to-lw where-pat)) ...
...) (cons (to-lw where-id)
(to-lw rhs)) (to-lw where-pat))
...) ...)
lang (to-lw rhs))
#t ;; multi-args? ...)
'name lang
cps #t ;; multi-args?
rhss 'name
(let ([name (lambda (x) (name-predicate x))]) name) cps
dsc rhss
sc)) (let ([name (lambda (x) (name-predicate x))]) name)
dsc dsc
'codom-side-conditions-rewritten sc))
'name))) dsc
(term-define-fn name name2)) 'codom-side-conditions-rewritten
'disappeared-use 'name)))
(map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))] (term-define-fn name name2))
'disappeared-use
(map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))]
[(_ prev-metafunction name lang clauses ...) [(_ prev-metafunction name lang clauses ...)
(begin (begin
(unless (identifier? #'name) (unless (identifier? #'name)
@ -1199,31 +1202,38 @@
(syntax->list #'(x ...))) (syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.2" stx))])) (raise-syntax-error syn-error-name "error checking failed.2" stx))]))
(define (extract-side-conditions name stx stuffs) (define (parse-extras extras)
(let loop ([stuffs (syntax->list stuffs)] (let loop ([stuffs (syntax->list extras)]
[side-conditionss '()] [side-conditionss '()]
[bindingss '()]) [bindingss '()]
[bothss '()])
(cond (cond
[(null? stuffs) (list (reverse side-conditionss) [(null? stuffs) (list (reverse side-conditionss)
(reverse bindingss))] (reverse bindingss)
(reverse bothss))]
[else [else
(let s-loop ([stuff (syntax->list (car stuffs))] (let s-loop ([stuff (syntax->list (car stuffs))]
[side-conditions '()] [side-conditions '()]
[bindings '()]) [bindings '()]
[boths '()])
(cond (cond
[(null? stuff) (loop (cdr stuffs) [(null? stuff) (loop (cdr stuffs)
(cons (reverse side-conditions) side-conditionss) (cons (reverse side-conditions) side-conditionss)
(cons (reverse bindings) bindingss))] (cons (reverse bindings) bindingss)
; Want these in reverse order.
(cons boths bothss))]
[else [else
(syntax-case (car stuff) (where side-condition) (syntax-case (car stuff) (where side-condition)
[(side-condition tl-side-conds ...) [(side-condition tl-side-conds ...)
(s-loop (cdr stuff) (s-loop (cdr stuff)
(append (syntax->list #'(tl-side-conds ...)) side-conditions) (append (syntax->list #'(tl-side-conds ...)) side-conditions)
bindings)] bindings
(cons (car stuff) boths))]
[(where x e) [(where x e)
(s-loop (cdr stuff) (s-loop (cdr stuff)
side-conditions side-conditions
(cons #'(x e) bindings))] (cons #'(x e) bindings)
(cons (car stuff) boths))]
[_ [_
(raise-syntax-error 'define-metafunction (raise-syntax-error 'define-metafunction
"expected a side-condition or where clause" "expected a side-condition or where clause"

16
collects/redex/private/rg-test.ss
View File

@ -820,11 +820,13 @@
; check-metafunction ; check-metafunction
(let () (let ()
(define-language empty) (define-language empty)
(define-metafunction empty (define-metafunction empty
[(m 1) whatever] [(m 1) whatever]
[(m 2) whatever]) [(m 2) whatever])
(define-metafunction empty (define-metafunction empty
[(n (side-condition any #f)) any]) [(n (side-condition any #f)) any])
(let ([generated null]) (let ([generated null])
(test (begin (test (begin
(output (output
@ -832,6 +834,20 @@
(check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1))) (check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1)))
generated) generated)
(reverse '((1) (2))))) (reverse '((1) (2)))))
(test
(let/ec k
(define-language L (n 2))
(define-metafunction L
[(f n)
n
(where number_2 ,(add1 (term n)))
(where number_3 ,(add1 (term number_2)))
(side-condition (k (term number_3)))]
[(f any) 0])
(check-metafunction f (λ (_) #t)))
4)
(test (output (λ () (check-metafunction m (λ (_) #t)))) #rx"no counterexamples") (test (output (λ () (check-metafunction m (λ (_) #t)))) #rx"no counterexamples")
(test (output (λ () (check-metafunction m (curry eq? 1)))) (test (output (λ () (check-metafunction m (curry eq? 1))))
#rx"check-metafunction:.*counterexample found after 1 attempt with clause #1") #rx"check-metafunction:.*counterexample found after 1 attempt with clause #1")

11
collects/redex/private/tl-test.ss
View File

@ -482,6 +482,17 @@
(test (term (f z)) (test (term (f z))
(term ((z z) (z z))))) (term ((z z) (z z)))))
(let ()
(define-metafunction empty-language
[(f number_1)
number_1
(where number_2 ,(add1 (term number_1)))
(where number_3 ,(add1 (term number_2)))
(side-condition (and (number? (term number_3))
(= (term number_3) 4)))]
[(f any) 0])
(test (term (f 2)) 2))
(let () (let ()
(define-language x-lang (define-language x-lang
(x variable)) (x variable))

29
collects/schemeunit/test-suite-test.ss
View File

@ -35,6 +35,35 @@
(check-exn exn:fail:contract? (check-exn exn:fail:contract?
(lambda () (lambda ()
(test-suite (check = 1 1))))) (test-suite (check = 1 1)))))
(test-case
"make-test-suite"
(let* ([before? #f]
[after? #f]
[ran? #f]
[results
(run-test
(make-test-suite
"dummy1"
(list
(make-test-case
"dummy-test-1"
(lambda () (check-true #t)))
(make-test-suite
"dummy2"
#:before (lambda () (set! before? #t))
#:after (lambda () (set! after? #t))
(list
(make-test-case
"dummy-test-2"
(lambda ()
(set! ran? #t)
(check-true #t))))))))])
(check-equal? (length results) 2)
(map (lambda (r) (check-pred test-success? r)) results)
(check-true before?)
(check-true after?)
(check-true ran?)))
)) ))

33
collects/schemeunit/test-suite.ss
View File

@ -10,6 +10,7 @@
test-suite-test-case-around test-suite-test-case-around
test-suite-check-around test-suite-check-around
delay-test delay-test
make-test-suite
apply-test-suite apply-test-suite
@ -124,6 +125,38 @@
#:after void-thunk #:after void-thunk
test ...))])) test ...))]))
(define (tests->test-suite-action tests)
(lambda (fdown fup fhere seed)
(parameterize
([current-seed seed])
(for-each
(lambda (t)
(cond
[(schemeunit-test-suite? t)
(current-seed (apply-test-suite t fdown fup fhere (current-seed)))]
[(schemeunit-test-case? t)
(current-seed
(fhere t
(schemeunit-test-case-name t)
(schemeunit-test-case-action t)
(current-seed)))]
[else
(raise
(make-exn:test
(format "tests->test-suite-action received ~a in list of tests ~a, which is not a test." t tests)
(current-continuation-marks)))]))
tests)
(current-seed))))
;; make-test-suite : string [#:before thunk] [#:after thunk] (listof test?) -> test-suite?
;;
;; Construct a test suite from a list of tests
(define (make-test-suite name #:before [before void-thunk] #:after [after void-thunk] tests)
(make-schemeunit-test-suite name
(tests->test-suite-action tests)
before
after))
;; ;;
;; Shortcut helpers ;; Shortcut helpers
;; ;;

8
collects/schemeunit/test-test.ss
View File

@ -281,5 +281,13 @@
check-info? check-info?
check-info-name check-info-name
check-info-value) check-info-value)
(test-case
"make-test-case constructs a test case"
(check-pred
test-success?
(car
(run-test
(make-test-case "dummy" (lambda () (check-true #t)))))))
)) ))

4
collects/schemeunit/test.ss
View File

@ -41,8 +41,10 @@
test-begin test-begin
test-case test-case
test-suite test-suite
make-test-suite
delay-test delay-test
(rename-out [schemeunit-test-case? test-case?] (rename-out [make-schemeunit-test-case make-test-case]
[schemeunit-test-case? test-case?]
[schemeunit-test-suite? test-suite?]) [schemeunit-test-suite? test-suite?])
define-test-suite define-test-suite

21
collects/scribblings/foreign/libs.scrbl
View File

@ -20,7 +20,7 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib],
@section{Unsafe Library Functions} @section{Unsafe Library Functions}
@defproc[(ffi-lib [path (or/c path-string? #f)] @defproc[(ffi-lib [path (or/c path-string? #f)]
[version (or/c string? (listof string?) #f) #f]) any]{ [version (or/c string? (listof (or/c string? #f)) #f) #f]) any]{
Returns an foreign-library value. If @scheme[path] is a path, the Returns an foreign-library value. If @scheme[path] is a path, the
result represents the foreign library, which is opened in an result represents the foreign library, which is opened in an
@ -29,14 +29,15 @@ OS-specific way (using @cpp{LoadLibrary} under Windows, and
The path is not expected to contain the library suffix, which is added The path is not expected to contain the library suffix, which is added
according to the current platform. If adding the suffix fails, according to the current platform. If adding the suffix fails,
several other filename variations are tried --- retrying without an several other filename variations are tried: retrying without an
automatically added suffix, and using a full path of a file if it automatically added suffix, and using a full path of a file if it
exists relative to the current directory (since the OS-level library exists relative to the current directory (since the OS-level library
function usually searches, unless the library name is an absolute function usually searches, unless the library name is an absolute
path). An optional @scheme[version] string can be supplied, which is path). An optional @scheme[version] string can be supplied, which is
appended to the name after any added suffix. If you need any of a few appended to the name before or after the suffix, depending on platform
possible versions, use a list of version strings, and @scheme[ffi-lib] conventions, unless it is @scheme[#f] or @scheme[""]. If
will try all of them. @scheme[version] is a list, @scheme[ffi-lib] will try each of them in
order.
If @scheme[path] is @scheme[#f], then the resulting foreign-library If @scheme[path] is @scheme[#f], then the resulting foreign-library
value represents all libraries loaded in the current process, value represents all libraries loaded in the current process,
@ -45,10 +46,12 @@ particular, use @scheme[#f] to access C-level functionality exported
by the run-time system (as described in @|InsideMzScheme|). by the run-time system (as described in @|InsideMzScheme|).
Note: @scheme[ffi-lib] tries to look for the library file in a few Note: @scheme[ffi-lib] tries to look for the library file in a few
places like the PLT libraries (see @scheme[get-lib-search-dirs]), a places, inluding the PLT libraries (see @scheme[get-lib-search-dirs]),
relative path, or a system search. However, if @cpp{dlopen} cannot a relative path, or a system search. When @scheme[version] is a list,
open a library, there is no reliable way to know why it failed, so if different versions are tried through each route before continuing the
all path combinations fail, it will raise an error with the result of search with other routes. However, if @cpp{dlopen} cannot open a
library, there is no reliable way to know why it failed, so if all
path combinations fail, it will raise an error with the result of
@cpp{dlopen} on the unmodified argument name. For example, if you @cpp{dlopen} on the unmodified argument name. For example, if you
have a local @filepath{foo.so} library that cannot be loaded because have a local @filepath{foo.so} library that cannot be loaded because
of a missing symbol, using @scheme[(ffi-lib "foo.so")] will fail with of a missing symbol, using @scheme[(ffi-lib "foo.so")] will fail with

3
collects/scribblings/reference/class.scrbl
View File

@ -1663,7 +1663,7 @@ Returns @scheme[#t] if @scheme[v] is an interface, @scheme[#f] otherwise.}
Returns @scheme[#t] if @scheme[v] is a @tech{generic}, @scheme[#f] otherwise.} Returns @scheme[#t] if @scheme[v] is a @tech{generic}, @scheme[#f] otherwise.}
@defproc[(object=? [a object?][b object?]) eq?]{ @defproc[(object=? [a object?] [b object?]) boolean?]{
Determines if two objects are the same object, or not; this procedure uses Determines if two objects are the same object, or not; this procedure uses
@scheme[eq?], but also works properly with contracts.} @scheme[eq?], but also works properly with contracts.}
@ -1745,7 +1745,6 @@ not including fields whose names are local (i.e., declared with
Returns two values, analogous to the return Returns two values, analogous to the return
values of @scheme[struct-info]: values of @scheme[struct-info]:
K%
@itemize[ @itemize[
@item{@scheme[class]: a class or @scheme[#f]; the result is @item{@scheme[class]: a class or @scheme[#f]; the result is

4
collects/sgl/gl.ss
View File

@ -10,11 +10,11 @@
(define gl-lib (case stype (define gl-lib (case stype
[(windows) (ffi-lib "opengl32")] [(windows) (ffi-lib "opengl32")]
[(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL")] [(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL")]
[else (ffi-lib "libGL")])) [else (ffi-lib "libGL" '("1" ""))]))
(define glu-lib (case stype (define glu-lib (case stype
[(windows) (ffi-lib "glu32")] [(windows) (ffi-lib "glu32")]
[(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGLU")] [(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGLU")]
[else (ffi-lib "libGLU")])) [else (ffi-lib "libGLU" '("1" ""))]))
(define (unavailable name) (define (unavailable name)
(lambda () (lambda x (error name "unavailable on this system")))) (lambda () (lambda x (error name "unavailable on this system"))))

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

@ -694,6 +694,36 @@
(define (q x) (define (q x)
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10)))))))))))))) (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10))))))))))))))
(let ([check (lambda (proc arities non-arities)
(test-comp `(module m scheme/base
(define f ,proc)
(print (procedure? f)))
`(module m scheme/base
(define f ,proc)
(print #t)))
(for-each
(lambda (a)
(test-comp `(module m scheme/base
(define f ,proc)
(print (procedure-arity-includes? f ,a)))
`(module m scheme/base
(define f ,proc)
(print #t))))
arities)
(for-each
(lambda (a)
(test-comp `(module m scheme/base
(define f ,proc)
(print (procedure-arity-includes? f ,a)))
`(module m scheme/base
(define f ,proc)
(print #f))))
non-arities))])
(check '(lambda (x) x) '(1) '(0 2))
(check '(lambda (x . y) x) '(1 2 3) '(0))
(check '(case-lambda [() 1] [(x y) x]) '(0 2) '(1 3))
(check '(lambda (x [y #f]) y) '(1 2) '(0 3)))
(let ([test-dropped (let ([test-dropped
(lambda (cons-name . args) (lambda (cons-name . args)
(test-comp `(let ([x 5]) (test-comp `(let ([x 5])

2
collects/web-server/lang/lang-api.ss
View File

@ -1,6 +1,7 @@
#lang scheme #lang scheme
(require net/url (require net/url
web-server/http web-server/http
web-server/http/bindings
web-server/dispatch web-server/dispatch
web-server/stuffers web-server/stuffers
web-server/lang/abort-resume web-server/lang/abort-resume
@ -11,6 +12,7 @@
(provide (except-out (all-from-out scheme) #%module-begin) (provide (except-out (all-from-out scheme) #%module-begin)
(all-from-out net/url (all-from-out net/url
web-server/http web-server/http
web-server/http/bindings
web-server/dispatch web-server/dispatch
web-server/stuffers web-server/stuffers
web-server/lang/abort-resume web-server/lang/abort-resume

2
collects/web-server/scribblings/cache-table.scrbl
View File

@ -6,7 +6,7 @@
@defmodule[web-server/private/cache-table]{ @defmodule[web-server/private/cache-table]{
@filepath{private/cache-table.ss} provides a set of caching hash table This module provides a set of caching hash table
functions. functions.
@defproc[(make-cache-table) @defproc[(make-cache-table)

2
collects/web-server/scribblings/connection-manager.scrbl
View File

@ -7,7 +7,7 @@
@defmodule[web-server/private/connection-manager]{ @defmodule[web-server/private/connection-manager]{
@filepath{private/connection-manager.ss} provides functionality for managing pairs of This module provides functionality for managing pairs of
input and output ports. We have plans to allow a number of different strategies input and output ports. We have plans to allow a number of different strategies
for doing this. for doing this.

2
collects/web-server/scribblings/contracts.scrbl
View File

@ -7,7 +7,7 @@
@defmodule[web-server/servlet/servlet-structs]{ @defmodule[web-server/servlet/servlet-structs]{
@filepath{servlet/servlet-structs.ss} provides a number of contracts This module provides a number of contracts
for use in servlets. for use in servlets.
@defthing[k-url? contract?]{ @defthing[k-url? contract?]{

2
collects/web-server/scribblings/ctable-structs.scrbl
View File

@ -9,7 +9,7 @@
@defmodule[web-server/configuration/configuration-table-structs]{ @defmodule[web-server/configuration/configuration-table-structs]{
@filepath{configuration/configuration-table-structs.ss} provides the following structures that This module provides the following structures that
represent a standard configuration (see @secref["web-server-unit.ss"]) of the @web-server . represent a standard configuration (see @secref["web-server-unit.ss"]) of the @web-server .
The contracts on this structure influence the valid types of values in The contracts on this structure influence the valid types of values in
the configuration table S-expression file format described in the configuration table S-expression file format described in

2
collects/web-server/scribblings/ctable.scrbl
View File

@ -8,7 +8,7 @@
@defmodule[web-server/configuration/configuration-table]{ @defmodule[web-server/configuration/configuration-table]{
@filepath{configuration/configuration-table.ss} provides functions for This module provides functions for
reading, writing, parsing, and printing @scheme[configuration-table] reading, writing, parsing, and printing @scheme[configuration-table]
structures. structures.

4
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -27,7 +27,7 @@ documentation.
@defmodule[web-server/dispatchers/dispatch]{ @defmodule[web-server/dispatchers/dispatch]{
@filepath{dispatchers/dispatch.ss} provides a few functions for dispatchers in general. This module provides a few functions for dispatchers in general.
@defthing[dispatcher/c contract?]{ @defthing[dispatcher/c contract?]{
Equivalent to @scheme[(connection? request? . -> . void)]. Equivalent to @scheme[(connection? request? . -> . void)].
@ -74,7 +74,7 @@ Consider the following example dispatcher, that captures the essence of URL rewr
@defmodule[web-server/dispatchers/filesystem-map]{ @defmodule[web-server/dispatchers/filesystem-map]{
@filepath{dispatchers/filesystem-map.ss} provides a means of mapping This module provides a means of mapping
URLs to paths on the filesystem. URLs to paths on the filesystem.
@defthing[url->path/c contract?]{ @defthing[url->path/c contract?]{

2
collects/web-server/scribblings/file-box.scrbl
View File

@ -9,7 +9,7 @@
As mentioned earlier, it is dangerous to rely on the store in As mentioned earlier, it is dangerous to rely on the store in
Web Language servlets, due to the deployment scenarios available Web Language servlets, due to the deployment scenarios available
to them. @filepath{lang/file-box.ss} provides a simple API to replace to them. This module provides a simple API to replace
boxes in a safe way. boxes in a safe way.
@defproc[(file-box? [v any/c]) @defproc[(file-box? [v any/c])

1
collects/web-server/scribblings/lang-api.scrbl
View File

@ -45,6 +45,7 @@ An example @scheme['stateless] servlet module:
These servlets have an extensive API available to them: @schememodname[net/url], @schememodname[web-server/http], These servlets have an extensive API available to them: @schememodname[net/url], @schememodname[web-server/http],
@schememodname[web-server/http/bindings],
@schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/web-param], @schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/web-param],
@schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/dispatch], and @schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/dispatch], and
@schememodname[web-server/stuffers]. @schememodname[web-server/stuffers].

8
collects/web-server/scribblings/managers.scrbl
View File

@ -17,7 +17,7 @@ pluggable through the manager interface.
@defmodule[web-server/managers/manager]{ @defmodule[web-server/managers/manager]{
@filepath{managers/manager.ss} defines the manager interface. It is required by This module defines the manager interface. It is required by
the users and implementers of managers. the users and implementers of managers.
@defstruct[manager ([create-instance ((-> void) . -> . number?)] @defstruct[manager ([create-instance ((-> void) . -> . number?)]
@ -65,7 +65,7 @@ the users and implementers of managers.
@defmodule[web-server/managers/none]{ @defmodule[web-server/managers/none]{
@filepath{managers/none.ss} defines a manager constructor: This module defines a manager constructor:
@defproc[(create-none-manager (instance-expiration-handler expiration-handler/c)) @defproc[(create-none-manager (instance-expiration-handler expiration-handler/c))
manager?]{ manager?]{
@ -90,7 +90,7 @@ Web Language. (See @secref["stateless"].)
@defmodule[web-server/managers/timeouts]{ @defmodule[web-server/managers/timeouts]{
@filepath{managers/timeouts.ss} defines a manager constructor: This module defines a manager constructor:
@defproc[(create-timeout-manager [instance-exp-handler expiration-handler/c] @defproc[(create-timeout-manager [instance-exp-handler expiration-handler/c]
[instance-timeout number?] [instance-timeout number?]
@ -122,7 +122,7 @@ deployments of the @web-server .
@defmodule[web-server/managers/lru]{ @defmodule[web-server/managers/lru]{
@filepath{managers/lru.ss} defines a manager constructor: This module defines a manager constructor:
@defproc[(create-LRU-manager @defproc[(create-LRU-manager
[instance-expiration-handler expiration-handler/c] [instance-expiration-handler expiration-handler/c]

2
collects/web-server/scribblings/mime-types.scrbl
View File

@ -6,7 +6,7 @@
@defmodule[web-server/private/mime-types]{ @defmodule[web-server/private/mime-types]{
@filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types} This module provides function for dealing with @filepath{mime.types}
files. files.
@defproc[(read-mime-types [p path-string?]) @defproc[(read-mime-types [p path-string?])

2
collects/web-server/scribblings/mod-map.scrbl
View File

@ -7,7 +7,7 @@
@defmodule[web-server/private/mod-map]{ @defmodule[web-server/private/mod-map]{
The @schememodname[scheme/serialize] library provides the The @schememodname[scheme/serialize] library provides the
functionality of serializing values. @filepath{private/mod-map.ss} functionality of serializing values. This module
compresses the serialized representation. compresses the serialized representation.
@defproc[(compress-serial [sv list?]) @defproc[(compress-serial [sv list?])

6
collects/web-server/scribblings/namespace.scrbl
View File

@ -6,9 +6,9 @@
@defmodule[web-server/configuration/namespace]{ @defmodule[web-server/configuration/namespace]{
@filepath{configuration/namespace.ss} provides a function to help create the This module provides a function to help create the
@scheme[make-servlet-namespace] procedure needed by the @scheme[make] functions @scheme[make-servlet-namespace] procedure needed by the @scheme[make] function
of @filepath{dispatchers/dispatch-servlets.ss} and @filepath{dispatchers/dispatch-lang.ss}. of @schememodname[web-server/dispatchers/dispatch-servlets].
@defthing[make-servlet-namespace/c contract?]{ @defthing[make-servlet-namespace/c contract?]{
Equivalent to Equivalent to

2
collects/web-server/scribblings/responders.scrbl
View File

@ -8,7 +8,7 @@
@defmodule[web-server/configuration/responders]{ @defmodule[web-server/configuration/responders]{
@filepath{configuration/responders.ss} provides some functions that help constructing HTTP responders. This module provides some functions that help constructing HTTP responders.
These functions are used by the default dispatcher constructor (see @secref["web-server-unit.ss"]) to These functions are used by the default dispatcher constructor (see @secref["web-server-unit.ss"]) to
turn the paths given in the @scheme[configuration-table] into responders for the associated circumstance. turn the paths given in the @scheme[configuration-table] into responders for the associated circumstance.

14
collects/web-server/scribblings/stateless-usage.scrbl
View File

@ -6,19 +6,17 @@
A servlet has the following process performed on it automatically: A servlet has the following process performed on it automatically:
@itemize[ @itemize[
@item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of @item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of
@scheme[let] and imperative features. (@filepath{lang/elim-letrec.ss})} @scheme[let] and imperative features.}
@item{The program is converted into ANF (Administrative Normal Form), @item{The program is converted into ANF (Administrative Normal Form),
making all continuations explicit. (@filepath{lang/anormal.ss})} making all continuations explicit.}
@item{All continuations (and other continuations marks) are recorded in the @item{All continuations (and other continuations marks) are recorded in the
continuation marks of the expression continuation marks of the expression
they are the continuation of. (@filepath{lang/elim-callcc.ss})} they are the continuation of.}
@item{All calls to external modules are identified and marked. @item{All calls to external modules are identified and marked.}
(@filepath{lang/elim-callcc.ss})}
@item{All uses of @scheme[call/cc] are removed and replaced with @item{All uses of @scheme[call/cc] are removed and replaced with
equivalent gathering of the continuations through the continuation-marks. equivalent gathering of the continuations through the continuation-marks.}
(@filepath{lang/elim-callcc.ss})}
@item{The program is defunctionalized with a serializable data-structure for each @item{The program is defunctionalized with a serializable data-structure for each
anonymous lambda. (@filepath{lang/defun.ss})} anonymous lambda.}
] ]
This process allows the continuations captured by your servlet to be serialized. This process allows the continuations captured by your servlet to be serialized.

2
collects/web-server/scribblings/timer.scrbl
View File

@ -6,7 +6,7 @@
@defmodule[web-server/private/timer]{ @defmodule[web-server/private/timer]{
@filepath{private/timer.ss} provides a functionality for running This module provides a functionality for running
procedures after a given amount of time, that may be extended. procedures after a given amount of time, that may be extended.
@defstruct[timer ([evt evt?] @defstruct[timer ([evt evt?]

2
collects/web-server/scribblings/url-param.scrbl
View File

@ -10,7 +10,7 @@
The @web-server needs to encode information in URLs. If this data The @web-server needs to encode information in URLs. If this data
is stored in the query string, than it will be overridden by browsers that is stored in the query string, than it will be overridden by browsers that
make GET requests to those URLs with more query data. So, it must be encoded make GET requests to those URLs with more query data. So, it must be encoded
in URL params. @filepath{private/url-param.ss} provides functions for helping in URL params. This module provides functions for helping
with this process. with this process.
@defproc[(insert-param [u url?] @defproc[(insert-param [u url?]

2
collects/web-server/scribblings/util.scrbl
View File

@ -10,7 +10,7 @@
@defmodule[web-server/private/util] @defmodule[web-server/private/util]
There are a number of other miscellaneous utilities the @web-server There are a number of other miscellaneous utilities the @web-server
needs. They are provided by @filepath{private/util.ss}. needs. They are provided by this module.
@section{Contracts} @section{Contracts}
@defthing[non-empty-string/c contract?]{Contract for non-empty strings.} @defthing[non-empty-string/c contract?]{Contract for non-empty strings.}

2
collects/web-server/scribblings/web-param.scrbl
View File

@ -7,7 +7,7 @@
@defmodule[web-server/lang/web-param]{ @defmodule[web-server/lang/web-param]{
It is not easy to use @scheme[parameterize] in the It is not easy to use @scheme[parameterize] in the
Web Language. @filepath{lang/web-param.ss} provides (roughly) the same Web Language. This module provides (roughly) the same
functionality in a way that is serializable. Like other serializable functionality in a way that is serializable. Like other serializable
things in the Web Language, they are sensitive to source code modification. things in the Web Language, they are sensitive to source code modification.