sync to trunk

svn: r14750

collects/framework/preferences.ss

@@ -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 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)))
 
@@ -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-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)
   (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)
-     
+     (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))
      (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))
+       (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))
      (error 'preferences:set-default
             "tried to call set-default for preference ~e but it cannot be configured any more"
@@ -377,19 +352,16 @@ the state transitions / contracts are:
   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
+  @{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).
     
-         If you use
+    If you use @scheme[preferences:set-un/marshall],
-         @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
+    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
     called to determine if a preference read in from a file is a valid
@@ -411,8 +383,7 @@ the state transitions / contracts are:
     preference are assumed to be printable.
     
     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.
     
     The @scheme[marshall] function might be called with any value returned
@@ -422,16 +393,14 @@ the state transitions / contracts are:
     by hand.
     
     @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
   preferences:restore-defaults
   (-> 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
   exn:make-unknown-preference 
@@ -447,11 +416,17 @@ the state transitions / contracts are:
  
  (parameter-doc
   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
   preferences:snapshot? 
@@ -459,8 +434,7 @@ the state transitions / contracts are:
   (arg)
   @{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].})
  (proc-doc/names
   preferences:restore-prefs-snapshot 

collects/lang/private/todo.ss

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

collects/redex/private/reduction-semantics.ss

@@ -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,16 +1012,19 @@
                                       (loop name (cdr names))]))])
                
                (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)])
+                   (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 (and tl-side-conds ...)) ...))))]
+                                             (syntax->list (syntax ((side-condition lhs tl-withs) ...))))]
                                        [dom-side-conditions-rewritten
                                         (and dom-ctcs
                                              (rewrite-side-conditions/check-errs
@@ -1119,7 +1122,7 @@
                                      'name)))
                                 (term-define-fn name name2))
                             'disappeared-use
-                      (map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))]
+                            (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)
+  (define (parse-extras extras)
-    (let loop ([stuffs (syntax->list stuffs)]
+    (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"

collects/redex/private/rg-test.ss

@@ -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")

collects/redex/private/tl-test.ss

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

collects/schemeunit/test-suite-test.ss

@@ -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?)))
    ))
 
 

collects/schemeunit/test-suite.ss

@@ -10,6 +10,7 @@
          test-suite-test-case-around
          test-suite-check-around
          delay-test
+         make-test-suite
          
          apply-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
 ;;

collects/schemeunit/test-test.ss

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

collects/schemeunit/test.ss

@@ -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

collects/scribblings/foreign/libs.scrbl

@@ -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
+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
 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
+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
 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

collects/scribblings/reference/class.scrbl

@@ -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

collects/sgl/gl.ss

@@ -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"))))

collects/tests/mzscheme/optimize.ss

@@ -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])

collects/web-server/lang/lang-api.ss

@@ -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

collects/web-server/scribblings/cache-table.scrbl

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

collects/web-server/scribblings/connection-manager.scrbl

@@ -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.
 

collects/web-server/scribblings/contracts.scrbl

@@ -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?]{

collects/web-server/scribblings/ctable-structs.scrbl

@@ -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

collects/web-server/scribblings/ctable.scrbl

@@ -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.
 

collects/web-server/scribblings/dispatchers.scrbl

@@ -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?]{

collects/web-server/scribblings/file-box.scrbl

@@ -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])

collects/web-server/scribblings/lang-api.scrbl

@@ -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].

collects/web-server/scribblings/managers.scrbl

@@ -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]

collects/web-server/scribblings/mime-types.scrbl

@@ -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?])

collects/web-server/scribblings/mod-map.scrbl

@@ -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?])

collects/web-server/scribblings/namespace.scrbl

@@ -6,9 +6,9 @@
 
 @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?]{
  Equivalent to 

collects/web-server/scribblings/responders.scrbl

@@ -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.
 

collects/web-server/scribblings/stateless-usage.scrbl

@@ -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})}
+       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
-       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
-       anonymous lambda. (@filepath{lang/defun.ss})}
+       anonymous lambda.}
 ]
 
 This process allows the continuations captured by your servlet to be serialized.

collects/web-server/scribblings/timer.scrbl

@@ -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?]

collects/web-server/scribblings/url-param.scrbl

@@ -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?]

collects/web-server/scribblings/util.scrbl

@@ -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.}

collects/web-server/scribblings/web-param.scrbl

@@ -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.