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

226
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:struct:unknown-preference struct:exn:unknown-preference)
(define old-preferences-symbol 'plt:framework-prefs)
(define old-preferences (make-hasheq))
(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
(for-each
(λ (line) (hash-set! old-preferences (car line) (cadr line)))
old-prefs))
(define preferences:low-level-put-preferences (make-parameter put-preferences))
(define preferences:low-level-get-preference (make-parameter get-preference))
(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
(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
(define marshall-unmarshall (make-hasheq))
@ -67,11 +57,11 @@ the state transitions / contracts are:
(define defaults (make-hasheq))
;; these four functions determine the state of a preference
(define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
(define (pref-default-set? pref) (hash-table-bound? defaults pref))
(define (pref-can-init? pref)
(define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref))
(define (pref-default-set? pref) (hash-has-key? defaults pref))
(define (pref-can-init? pref)
(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))
(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?.
(define-struct pref-callback (cb))
;; used to detect missing hash entries
(define none (gensym 'none))
;; get : symbol -> any
;; return the current value of the preference `p'
;; exported
(define (preferences:get p)
(define v (hash-ref preferences p none))
(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)
;; unmarshall, if required
(when (hash-table-bound? marshalled p)
;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
(unless (hash-table-bound? preferences p)
(hash-set! preferences p (unmarshall-pref p (hash-ref marshalled p))))
(hash-remove! marshalled p))
;; if there is no value in the preferences table, but there is one
;; in the old version preferences file, take that:
(unless (hash-table-bound? preferences p)
(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)]
(let* (;; try to read the preferece from the preferences file
[v ((preferences:low-level-get-preference)
(add-pref-prefix p) (λ () none))]
[v (if (eq? v none)
;; no value read, take the default value
(default-value (hash-ref defaults p))
;; found a saved value, unmarshall it
(unmarshall-pref p v))])
;; set the value for future reference and return it
(hash-set! preferences p v)
v)]
[(not (pref-default-set? p))
(raise-unknown-preference-error
'preferences:get
@ -155,8 +142,6 @@ the state transitions / contracts are:
values))
(void))
(define preferences:low-level-put-preferences (make-parameter put-preferences))
(define (raise-unknown-preference-error sym fmt . args)
(raise (exn:make-unknown-preference
(string-append (format "~a: " sym) (apply format fmt args))
@ -229,11 +214,6 @@ the state transitions / contracts are:
[(not (pref-can-init? 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)
(hash-for-each
defaults
@ -248,12 +228,7 @@ the state transitions / contracts are:
(unless default-okay?
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
p checker default-okay? default-value))
(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))))]
(hash-set! defaults p (make-default default-value checker)))]
[(not (pref-can-init? p))
(error 'preferences:set-default
"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)
((weak? #f)))
@{This function adds a callback which is called with a symbol naming a
preference and its value, when the preference changes.
@scheme[preferences:add-callback] returns a thunk, which when
invoked, removes the callback from this preference.
If @scheme[weak?] is true, the preferences system will only hold on to
the callback weakly.
The callbacks will be called in the order in which they were added.
If you are adding a callback for a preference that requires
marshalling and unmarshalling, you must set the marshalling and
unmarshalling functions by calling
@scheme[preferences:set-un/marshall] before adding a callback.
This function raises
@index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
@scheme[exn:unknown-preference]
if the preference has not been set.})
preference and its value, when the preference changes.
@scheme[preferences:add-callback] returns a thunk, which when
invoked, removes the callback from this preference.
If @scheme[weak?] is true, the preferences system will only hold on to
the callback weakly.
The callbacks will be called in the order in which they were added.
If you are adding a callback for a preference that requires
marshalling and unmarshalling, you must set the marshalling and
unmarshalling functions by calling
@scheme[preferences:set-un/marshall] before adding a callback.
This function raises
@index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
@scheme[exn:unknown-preference]
if the preference has not been set.})
(proc-doc/names
preferences:set-default
(symbol? any/c (any/c . -> . any) . -> . void?)
(symbol value test)
@{This function must be called every time your application starts up, before any call to
@scheme[preferences:get] or
@scheme[preferences:set]
(for any given preference).
If you use
@scheme[preferences:set-un/marshall],
you must call this function before calling it.
This sets the default value of the preference @scheme[symbol] to
@scheme[value]. If the user has chosen a different setting,
the user's setting
will take precedence over the default value.
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
preference. If @scheme[test] returns @scheme[#t], then the preference is
treated as valid. If @scheme[test] returns @scheme[#f] then the default is
used.})
@{This function must be called every time your application starts up, before
any call to @scheme[preferences:get] or @scheme[preferences:set]
(for any given preference).
If you use @scheme[preferences:set-un/marshall],
you must call this function before calling it.
This sets the default value of the preference @scheme[symbol] to
@scheme[value]. If the user has chosen a different setting,
the user's setting will take precedence over the default value.
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
preference. If @scheme[test] returns @scheme[#t], then the preference is
treated as valid. If @scheme[test] returns @scheme[#f] then the default is
used.})
(proc-doc/names
preferences:set-un/marshall
(symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
(symbol marshall unmarshall)
@{@scheme[preference:set-un/marshall] is used to specify marshalling and
unmarshalling functions for the preference
@scheme[symbol]. @scheme[marshall] will be called when the users saves their
preferences to turn the preference value for @scheme[symbol] into a
printable value. @scheme[unmarshall] will be called when the user's
preferences are read from the file to transform the printable value
into its internal representation. If @scheme[preference:set-un/marshall]
is never called for a particular preference, the values of that
preference are assumed to be printable.
If the unmarshalling function returns a value that does not meet the
guard passed to
@scheme[preferences:set-default]
for this preference, the default value is used.
The @scheme[marshall] function might be called with any value returned
from @scheme[read] and it must not raise an error
(although it can return arbitrary results if it gets bad input). This might
happen when the preferences file becomes corrupted, or is edited
by hand.
@scheme[preference:set-un/marshall] must be called before calling
@scheme[preferences:get],
@scheme[preferences:set].})
unmarshalling functions for the preference
@scheme[symbol]. @scheme[marshall] will be called when the users saves their
preferences to turn the preference value for @scheme[symbol] into a
printable value. @scheme[unmarshall] will be called when the user's
preferences are read from the file to transform the printable value
into its internal representation. If @scheme[preference:set-un/marshall]
is never called for a particular preference, the values of that
preference are assumed to be printable.
If the unmarshalling function returns a value that does not meet the
guard passed to @scheme[preferences:set-default]
for this preference, the default value is used.
The @scheme[marshall] function might be called with any value returned
from @scheme[read] and it must not raise an error
(although it can return arbitrary results if it gets bad input). This might
happen when the preferences file becomes corrupted, or is edited
by hand.
@scheme[preference:set-un/marshall] must be called before calling
@scheme[preferences:get],@scheme[preferences:set].})
(proc-doc/names
preferences:restore-defaults
(-> void?)
()
@{@scheme[(preferences:restore-defaults)]
restores the users's configuration to the
default preferences.})
@{@scheme[(preferences:restore-defaults)] restores the users' configuration
to the default preferences.})
(proc-doc/names
exn:make-unknown-preference
@ -447,28 +416,33 @@ the state transitions / contracts are:
(parameter-doc
preferences:low-level-put-preferences
(parameter/c (-> (listof symbol?) (listof any/c) any))
put-preference
@{This parameter's value
is called to save preference the preferences. Its interface should
be just like mzlib's @scheme[put-preference].})
(parameter/c ((listof symbol?) (listof any/c) . -> . any))
put-preferences
@{This parameter's value is called to save preference the preferences file.
Its interface should be just like mzlib's @scheme[put-preferences].})
(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
preferences:snapshot?
(-> any/c boolean?)
(arg)
@{Determines if its argument is a preferences snapshot.
See also
@scheme[preferences:get-prefs-snapshot] and
@scheme[preferences:restore-prefs-snapshot].})
See also @scheme[preferences:get-prefs-snapshot] and
@scheme[preferences:restore-prefs-snapshot].})
(proc-doc/names
preferences:restore-prefs-snapshot
(-> preferences:snapshot? void?)
(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
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)

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

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

@ -820,11 +820,13 @@
; check-metafunction
(let ()
(define-language empty)
(define-metafunction empty
[(m 1) whatever]
[(m 2) whatever])
(define-metafunction empty
[(n (side-condition any #f)) any])
(let ([generated null])
(test (begin
(output
@ -832,6 +834,20 @@
(check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1)))
generated)
(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 (curry eq? 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))
(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 ()
(define-language x-lang
(x variable))

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

@ -35,6 +35,35 @@
(check-exn exn:fail:contract?
(lambda ()
(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?)))
))

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

@ -10,7 +10,8 @@
test-suite-test-case-around
test-suite-check-around
delay-test
make-test-suite
apply-test-suite
define-test-suite
@ -124,6 +125,38 @@
#:after void-thunk
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
;;

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

@ -281,5 +281,13 @@
check-info?
check-info-name
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-case
test-suite
make-test-suite
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?])
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}
@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
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
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
exists relative to the current directory (since the OS-level library
function usually searches, unless the library name is an absolute
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
possible versions, use a list of version strings, and @scheme[ffi-lib]
will try all of them.
appended to the name before or after the suffix, depending on platform
conventions, unless it is @scheme[#f] or @scheme[""]. If
@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
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|).
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
relative path, or a system search. 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
places, inluding the PLT libraries (see @scheme[get-lib-search-dirs]),
a relative path, or a system search. When @scheme[version] is a list,
different versions are tried through each route before continuing the
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
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

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.}
@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
@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
values of @scheme[struct-info]:
K%
@itemize[
@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
[(windows) (ffi-lib "opengl32")]
[(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
[(windows) (ffi-lib "glu32")]
[(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGLU")]
[else (ffi-lib "libGLU")]))
[else (ffi-lib "libGLU" '("1" ""))]))
(define (unavailable name)
(lambda () (lambda x (error name "unavailable on this system"))))

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

@ -694,6 +694,36 @@
(define (q x)
(+ 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
(lambda (cons-name . args)
(test-comp `(let ([x 5])

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

@ -1,6 +1,7 @@
#lang scheme
(require net/url
web-server/http
web-server/http/bindings
web-server/dispatch
web-server/stuffers
web-server/lang/abort-resume
@ -11,6 +12,7 @@
(provide (except-out (all-from-out scheme) #%module-begin)
(all-from-out net/url
web-server/http
web-server/http/bindings
web-server/dispatch
web-server/stuffers
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]{
@filepath{private/cache-table.ss} provides a set of caching hash table
This module provides a set of caching hash table
functions.
@defproc[(make-cache-table)

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

@ -7,7 +7,7 @@
@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
for doing this.

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

@ -7,7 +7,7 @@
@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.
@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]{
@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 .
The contracts on this structure influence the valid types of values 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]{
@filepath{configuration/configuration-table.ss} provides functions for
This module provides functions for
reading, writing, parsing, and printing @scheme[configuration-table]
structures.

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

@ -27,7 +27,7 @@ documentation.
@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?]{
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]{
@filepath{dispatchers/filesystem-map.ss} provides a means of mapping
This module provides a means of mapping
URLs to paths on the filesystem.
@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
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.
@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],
@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/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/dispatch], and
@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]{
@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.
@defstruct[manager ([create-instance ((-> void) . -> . number?)]
@ -65,7 +65,7 @@ the users and implementers of managers.
@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))
manager?]{
@ -90,7 +90,7 @@ Web Language. (See @secref["stateless"].)
@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]
[instance-timeout number?]
@ -122,7 +122,7 @@ deployments of the @web-server .
@defmodule[web-server/managers/lru]{
@filepath{managers/lru.ss} defines a manager constructor:
This module defines a manager constructor:
@defproc[(create-LRU-manager
[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]{
@filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types}
This module provides function for dealing with @filepath{mime.types}
files.
@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]{
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.
@defproc[(compress-serial [sv list?])

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

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

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

@ -8,7 +8,7 @@
@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
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:
@itemize[
@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),
making all continuations explicit. (@filepath{lang/anormal.ss})}
making all continuations explicit.}
@item{All continuations (and other continuations marks) are recorded in the
continuation marks of the expression
they are the continuation of. (@filepath{lang/elim-callcc.ss})}
@item{All calls to external modules are identified and marked.
(@filepath{lang/elim-callcc.ss})}
they are the continuation of.}
@item{All calls to external modules are identified and marked.}
@item{All uses of @scheme[call/cc] are removed and replaced with
equivalent gathering of the continuations through the continuation-marks.
(@filepath{lang/elim-callcc.ss})}
equivalent gathering of the continuations through the continuation-marks.}
@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.

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

@ -6,7 +6,7 @@
@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.
@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
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
in URL params. @filepath{private/url-param.ss} provides functions for helping
in URL params. This module provides functions for helping
with this process.
@defproc[(insert-param [u url?]

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

@ -10,7 +10,7 @@
@defmodule[web-server/private/util]
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}
@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]{
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
things in the Web Language, they are sensitive to source code modification.