Move a bunch of functions from typed-scheme/utils/utils to unstable.

Add convenience lib for unstable docs.
Add char support to format-{id,symbol}
Add unstable/sequence library.

svn: r16789

collects/scheme/match/match-expander.ss

@@ -47,8 +47,10 @@
                 legacy-xform
                 (lambda (stx)
                   (syntax-case stx (set!)
-                    [(nm args (... ...)) #'(macro-xform args (... ...))]
+                    [(nm . args) #'(macro-xform . args)]
-                    [nm #'macro-xform]))
+                    [nm (identifier? #'nm) #'macro-xform]
+                    [(set! . _)
+                     (raise-syntax-error #f "match expander cannot be target of a set!" stx)]))
                 (syntax-local-certifier))))
            (syntax/loc stx
              (define-syntax id

collects/scribblings/reference/contracts.scrbl

@@ -327,7 +327,7 @@ If the @scheme[immutable] argument is @scheme[#f] or
 and the @scheme[key] and @scheme[val] arguments must also be flat
 contracts. 
 
-If @scheme[immtable] is @scheme[#t], then the other arguments do not
+If @scheme[immutable] is @scheme[#t], then the other arguments do not
 have to be flat contracts, the result is not a flat contract, and
 checking this contract involves making a copy of the hash-table.
 }

collects/scribblings/reference/mz.ss

@@ -5,14 +5,14 @@
            scribble/decode
            scheme/contract
            "../icons.ss")
-
+  
   (provide (all-from-out scribble/manual)
            (all-from-out scribble/eval)
            (all-from-out scheme/contract))
-
+  
   (require (for-label scheme))
   (provide (for-label (all-from-out scheme)))
-
+  
   (provide mz-examples)
   (define mz-eval (make-base-eval))
   (define-syntax mz-examples
@@ -21,10 +21,10 @@
        (examples #:eval . rest)]
       [(_ . rest)
        (examples #:eval mz-eval . rest)]))
-
+  
   (define AllUnix "Unix and Mac OS X")
   (provide AllUnix)
-
+  
   (provide note-lib)
   (define-syntax note-lib
     (syntax-rules ()
@@ -45,7 +45,7 @@
               . more)))]
       [(_ lib . more)
        (note-lib lib #:use-sources () . more)]))
-
+  
   (provide note-init-lib)
   (define-syntax note-init-lib
     (syntax-rules ()
@@ -64,7 +64,7 @@
               . more)))]
       [(_ lib . more)
        (note-init-lib lib #:use-sources () . more)]))
-
+  
   (provide note-lib-only)
   (define-syntax note-lib-only
     (syntax-rules ()
@@ -78,7 +78,7 @@
             . more))]
       [(_ lib . more)
        (note-lib-only lib #:use-sources () . more)]))
-    
+  
   (define (*exnraise s)
     (make-element #f (list s " exception is raised")))
   (define-syntax exnraise
@@ -88,21 +88,21 @@
     (syntax-rules ()
       [(_ s) (scheme s)]))
   (provide exnraise Exn)
-
+  
   (provide margin-note/ref
            refalso moreref Guide guideintro guidesecref
            HonuManual)
-
+  
   (define (margin-note/ref . s)
     (apply margin-note
            (decode-content (cons magnify s))))
-
+  
   (define (refalso tag . s)
     (apply margin-note
            (decode-content (append (list magnify (secref tag) " also provides information on ")
                                    s
                                    (list ".")))))
-
+  
   (define (moreref tag . s)
     (apply margin-note
            (decode-content (append (list magnify (secref tag) " provides more information on ")
@@ -111,16 +111,23 @@
   
   (define (guidesecref s)
     (secref #:doc '(lib "scribblings/guide/guide.scrbl") s))
-
+  
   (define (guideintro tag . s)
     (apply margin-note
            (decode-content (append (list finger (guidesecref tag) " in " Guide " introduces ")
                                    s
                                    (list ".")))))
-
+  
   (define Guide
     (other-manual '(lib "scribblings/guide/guide.scrbl")))
-
+  
   (define HonuManual
-    (other-manual '(lib "scribblings/honu/honu.scrbl"))))
+    (other-manual '(lib "scribblings/honu/honu.scrbl")))
-
+  
+  (provide speed)
+  (define-syntax speed
+    (syntax-rules ()
+      [(_ id what)
+       (t "An" (scheme id) "application can provide better performance for"
+          (elem what)
+          "iteration when it appears directly in a" (scheme for) "clause.")])))

collects/scribblings/reference/sequences.scrbl

@@ -4,13 +4,6 @@
           scribble/scheme
 	  (for-label scheme/generator))
 
-@(define-syntax speed
-   (syntax-rules ()
-     [(_ id what)
-      @t{An @scheme[id] application can provide better performance for
-         @elem[what]
-         iteration when it appears directly in a @scheme[for] clause.}]))
-
 @(define generator-eval
    (lambda ()
      (let ([the-eval (make-base-eval)])

collects/typed-scheme/env/lexical-env.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss"
-(require "type-environments.ss" 
+	 "type-environments.ss" 
 	 "type-env.ss"
 	 unstable/mutated-vars
          (only-in scheme/contract ->* ->)

collects/typed-scheme/env/type-alias-env.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss"
-(require syntax/boundmap
+	 syntax/boundmap
          (utils tc-utils)
          mzlib/trace
          scheme/match)

collects/typed-scheme/env/type-env.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss" 
-(require syntax/boundmap
+	 syntax/boundmap
          (utils tc-utils)
          (types utils))
 

collects/typed-scheme/infer/constraint-structs.ss

@@ -1,8 +1,6 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss" (rep type-rep) scheme/contract)
-(require (rep type-rep)
-         scheme/contract)
 
 ;; S, T types
 ;; X a var
@@ -31,9 +29,9 @@
 ;; don't want to rule them out too early
 (define-struct cset (maps) #:prefab)
 
-(provide/contract (struct c ([S Type?] [X symbol?] [T Type?]))
+(p/c (struct c ([S Type?] [X symbol?] [T Type?]))
-                  (struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
+     (struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
-                  (struct dcon-exact ([fixed (listof c?)] [rest c?]))
+     (struct dcon-exact ([fixed (listof c?)] [rest c?]))
-                  (struct dcon-dotted ([type c?] [bound symbol?]))
+     (struct dcon-dotted ([type c?] [bound symbol?]))
-                  (struct dmap ([map (hashof symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
+     (struct dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
-                  (struct cset ([maps (listof (cons/c (hashof symbol? c?) dmap?))])))
+     (struct cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))])))

collects/typed-scheme/infer/constraints.ss

@@ -1,9 +1,10 @@
 #lang scheme/unit
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss"
-(require (types convenience utils union subtype)
+	 (types convenience utils union subtype)
 	 (rep type-rep)
 	 (utils tc-utils)
+	 unstable/sequence
          "signatures.ss" "constraint-structs.ss"
          scheme/match)
 

collects/typed-scheme/infer/dmap.ss

@@ -1,8 +1,9 @@
 #lang scheme/unit
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss" 
-(require "signatures.ss" "constraint-structs.ss"
+	 "signatures.ss" "constraint-structs.ss"
 	 (utils tc-utils)
+	 unstable/sequence
          scheme/match)
 
 (import constraints^)
@@ -35,7 +36,7 @@
        (fail! fixed1 fixed2))
      (make-dcon
       (for/list ([c1 fixed1]
-                 [c2 (in-list-forever fixed2 rest)])
+                 [c2 (in-sequence-forever fixed2 rest)])
         (c-meet c1 c2 (c-X c1)))
       #f)]
     [((struct dcon (fixed1 rest)) (struct dcon (fixed2 #f)))
@@ -47,7 +48,7 @@
                        (values fixed2 fixed1 rest2 rest1))])
        (make-dcon
         (for/list ([c1 longer]
-                   [c2 (in-list-forever shorter srest)])
+                   [c2 (in-sequence-forever shorter srest)])
           (c-meet c1 c2 (c-X c1)))
         (c-meet lrest srest (c-X lrest))))]
     [((struct dcon-dotted (c1 bound1)) (struct dcon-dotted (c2 bound2)))

collects/typed-scheme/infer/infer-unit.ss

@@ -1,7 +1,7 @@
 #lang scheme/unit
 
-(require (except-in "../utils/utils.ss"))
+(require "../utils/utils.ss"
-(require (rep free-variance type-rep filter-rep rep-utils)
+	 (rep free-variance type-rep filter-rep rep-utils)
 	 (types convenience union subtype remove-intersect resolve)
 	 (except-in (utils tc-utils) make-env)
 	 (env type-name-env)
@@ -12,6 +12,7 @@
          scheme/match
          mzlib/etc
          mzlib/trace
+	 unstable/sequence unstable/list
          scheme/list)
 
 (import dmap^ constraints^ promote-demote^)

collects/typed-scheme/private/parse-type.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss"
-(require (except-in (rep type-rep) make-arr)
+	 (except-in (rep type-rep) make-arr)
          (rename-in (types convenience union utils) [make-arr* make-arr])
          (utils tc-utils stxclass-util)
          syntax/stx (prefix-in c: scheme/contract)

collects/typed-scheme/private/prims.ss

@@ -24,8 +24,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
 	 (rename-out [define-typed-struct define-struct:]
                      [define-typed-struct/exec define-struct/exec:]))
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss"
-(require (for-syntax 
+	 (for-syntax 
           syntax/parse
 	  syntax/private/util
           scheme/base

collects/typed-scheme/private/type-annotation.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss" 
-(require (rep type-rep)
+	 (rep type-rep)
 	 (utils tc-utils)
 	 (env type-env)
          (except-in (types subtype union convenience resolve utils) -> ->*)

collects/typed-scheme/private/type-contract.ss

@@ -2,8 +2,8 @@
 
 (provide type->contract define/fixup-contract? generate-contract-def change-contract-fixups)
 
-(require (except-in "../utils/utils.ss" extend))
 (require
+ "../utils/utils.ss"
  (rep type-rep filter-rep object-rep)
  (typecheck internal-forms)
  (utils tc-utils require-contract)
@@ -11,11 +11,7 @@
  (types resolve utils)
  (prefix-in t: (types convenience))
  (private parse-type)
- scheme/match
+ scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list
- syntax/struct
- syntax/stx
- mzlib/trace
- scheme/list
  (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c)
  (for-template scheme/base scheme/contract unstable/poly-c (only-in scheme/class object% is-a?/c subclass?/c)))
 
@@ -111,8 +107,8 @@
                       [else (int-err "unknown var: ~a" v)])]
 	[(Poly: vs (and b (Function: _)))
          (match-let ([(Poly-names: vs-nm _) ty])
-           (with-syntax ([(vs+ ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '+)))]
+           (with-syntax ([(vs+ ...) (generate-temporaries (for/list ([v vs-nm]) (format-symbol "~a+" v)))]
-			 [(vs- ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '-)))])
+			 [(vs- ...) (generate-temporaries (for/list ([v vs-nm]) (format-symbol "~a-" v)))])
              (parameterize ([vars (append (map list
 					       vs
 					       (syntax->list #'(vs+ ...))

collects/typed-scheme/rep/rep-utils.ss

@@ -6,6 +6,7 @@
          syntax/boundmap
          "free-variance.ss"
          "interning.ss"
+	 unstable/syntax
          mzlib/etc
          scheme/contract         
          (for-syntax 
@@ -17,6 +18,7 @@
           syntax/struct
           syntax/stx
           scheme/contract
+	  unstable/syntax
           (rename-in (except-in (utils utils stxclass-util) bytes byte-regexp regexp byte-pregexp #;pregexp)
                      [id* id]
                      [keyword* keyword])))
@@ -75,13 +77,13 @@
                                  (~optional [#:contract cnt:expr])
                                  (~optional no-provide?:no-provide-kw)) ...)
        (with-syntax* 
-        ([ex (mk-id #'nm #'nm ":")]
+        ([ex (format-id #'nm "~a:" #'nm)]
-         [fold-name (mk-id #f #'nm "-fold")]
+         [fold-name (format-id #f "~a-fold" #'nm)]
          [kw-stx (string->keyword (symbol->string (attribute nm.datum)))]
          [parent par]
          [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
-         [*maker (mk-id #'nm "*" #'nm)]
+         [*maker (format-id #'nm "*~a" #'nm)]
-         [**maker (mk-id #'nm "**" #'nm)]
+         [**maker (format-id #'nm "**~a" #'nm)]
          [*maker-cnt (if enable-contracts?
                          (or (attribute cnt) #'(flds.cnt ... . -> . pred))
                          #'any/c)]
@@ -251,12 +253,12 @@
              #:with name #'i
              #:with keyword (datum->syntax #f (string->keyword (symbol->string (syntax-e #'i))))
              #:with tmp-rec-id (generate-temporary)
-             #:with case (mk-id #'i (attribute lower-s) "-case")
+             #:with case (format-id #'i "~a-case" (attribute lower-s))
-             #:with printer (mk-id #'i "print-" (attribute lower-s) "*")
+             #:with printer (format-id #'i "print-~a*" (attribute lower-s))
-             #:with ht (mk-id #'i (attribute lower-s) "-name-ht")
+             #:with ht (format-id #'i "~a-name-ht" (attribute lower-s))
-             #:with rec-id (mk-id #'i (attribute lower-s) "-rec-id")
+             #:with rec-id (format-id #'i "~a-rec-id" (attribute lower-s))
-             #:with d-id (mk-id #'i "d" (attribute first-letter))
+             #:with d-id (format-id #'i "d~a" (attribute first-letter))
-             #:with (_ _ pred? accs ...) 
+             #:with (_ _ pred? accs ...)
                     (datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name))))
   (syntax-parse stx
     [(_ i:type-name ...)

collects/typed-scheme/typecheck/check-subforms-unit.ss

@@ -1,7 +1,7 @@
 #lang scheme/unit
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss"
-(require syntax/kerncase
+	 syntax/kerncase
          scheme/match
          "signatures.ss" "tc-metafunctions.ss"
          (types utils convenience union subtype)

collects/typed-scheme/typecheck/provide-handling.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss" 
-(require (only-in srfi/1/list s:member)
+	 (only-in srfi/1/list s:member)
          syntax/kerncase syntax/boundmap
          (env type-name-env type-alias-env)
          mzlib/trace

collects/typed-scheme/typecheck/tc-app.ss

@@ -4,6 +4,7 @@
          "signatures.ss" "tc-metafunctions.ss"
          "tc-app-helper.ss" "find-annotation.ss"
          syntax/parse scheme/match mzlib/trace scheme/list 
+	 unstable/sequence
          ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy
          scheme/bool
          (only-in scheme/private/class-internal make-object do-make-object)
@@ -677,7 +678,7 @@
              [(and rest (< (length t-a) (length dom)))
               (tc-error/expr #:return (ret t-r)
                              "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
-       (for ([dom-t (if rest (in-list-forever dom rest) (in-list dom))] [a (syntax->list args-stx)] [arg-t (in-list t-a)])
+       (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] [a (syntax->list args-stx)] [arg-t (in-list t-a)])
          (parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
      (let* (;; Listof[Listof[LFilterSet]]
             [lfs-f (for/list ([lf lf-r])

collects/typed-scheme/typecheck/tc-dots-unit.ss

@@ -1,7 +1,7 @@
 #lang scheme/unit
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss" 
-(require "signatures.ss"
+	 "signatures.ss"
          (utils tc-utils)
          (env type-environments)
          (types utils)

collects/typed-scheme/typecheck/tc-if.ss

@@ -1,7 +1,7 @@
 #lang scheme/unit
 
 
-(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend]))
+(require (rename-in "../utils/utils.ss" [infer r:infer]))
 (require "signatures.ss"
          (rep type-rep filter-rep object-rep)
          (rename-in (types convenience subtype union utils comparison remove-intersect)

collects/typed-scheme/typecheck/tc-lambda-unit.ss

@@ -1,6 +1,6 @@
 #lang scheme/unit
 
-(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])
+(require (rename-in "../utils/utils.ss" [infer r:infer])
          "signatures.ss"
          "tc-metafunctions.ss"
          mzlib/trace

collects/typed-scheme/typecheck/tc-structs.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss" 
-(require (rep type-rep)
+	 (rep type-rep)
          (private parse-type)
 	 (types convenience utils union resolve abbrev)
 	 (env type-env type-environments type-name-env)

collects/typed-scheme/typecheck/tc-toplevel.ss

@@ -3,6 +3,7 @@
 
 (require (rename-in "../utils/utils.ss" [infer r:infer]))
 (require syntax/kerncase
+	 unstable/list
          mzlib/etc
          scheme/match
          "signatures.ss"

collects/typed-scheme/typed-scheme.ss

@@ -13,7 +13,7 @@
 	  (r:infer infer)
 	  (utils tc-utils)
 	  (rep type-rep)
-	  (except-in (utils utils) infer extend)
+	  (except-in (utils utils) infer)
           (only-in (r:infer infer-dummy) infer-param)
           scheme/nest
           syntax/kerncase
@@ -36,11 +36,7 @@
 (define-syntax (module-begin stx)
   (define module-name (syntax-property stx 'enclosing-module-name))
   ;(printf "BEGIN: ~a~n" (syntax->datum stx))
-  (with-logging-to-file 
+  (syntax-case stx ()
-   (build-path (find-system-path 'temp-dir) "ts-poly.log")
-   #;
-   (log-file-name (syntax-source stx) module-name)
-   (syntax-case stx ()
      [(mb forms ...)
       (nest
           ([begin (set-box! typed-context? #t)
@@ -90,7 +86,7 @@
         #;(printf "tried to create ~a types~n" (all-count!))
         #;(printf "created ~a union types~n" (union-count!))
         ;; reconstruct the module with the extra code
-        #'(#%module-begin transformed-body ... after-code check-syntax-help))])))
+        #'(#%module-begin transformed-body ... after-code check-syntax-help))]))
 
 (define-syntax (top-interaction stx)
   (syntax-case stx ()

collects/typed-scheme/types/remove-intersect.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (except-in "../utils/utils.ss" extend))
+(require "../utils/utils.ss" 
-(require (rep type-rep rep-utils)
+	 (rep type-rep rep-utils)
 	 (types union subtype resolve convenience utils)
          scheme/match mzlib/trace)
 

collects/typed-scheme/utils/utils.ss

@@ -8,24 +8,23 @@ at least theoretically.
 (require (for-syntax scheme/base syntax/parse scheme/string)
          scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax
          mzlib/struct scheme/unit
-         (except-in syntax/parse id))
+	 scheme/pretty mzlib/pconvert
+	 (except-in syntax/parse id))
 
-(provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
+;; to move to unstable
-         with-logging-to-file log-file-name ==
+(provide == hash-union debug reverse-begin)
-         define-struct/printer
-         (rename-out [id mk-id])
-         filter-multiple
-         hash-union
-         in-pairs
-         in-list-forever
-         extend
-         debug
-         in-syntax
-	 symbol-append
-         custom-printer
-	 rep utils typecheck infer env private
-         hashof)
 
+(provide
+ ;; timing
+ start-timing do-time  
+ ;; logging
+ printf/log
+ ;; struct printing
+ custom-printer define-struct/printer
+ ;; provide macros
+ rep utils typecheck infer env private)
+
+;; fancy require syntax
 (define-syntax (define-requirer stx)
   (syntax-parse stx
     [(_ nm:id nm-out:id)
@@ -81,13 +80,7 @@ at least theoretically.
 (define-requirer private private-out)
 (define-requirer types types-out)
 
-(define-sequence-syntax in-syntax 
+;; printf debugging convenience
-  (lambda () #'syntax->list)
-  (lambda (stx)
-    (syntax-case stx ()
-      [[ids (_ arg)]
-       #'[ids (in-list (syntax->list arg))]])))
-
 (define-syntax debug
   (syntax-rules ()
     [(_ (f . args))
@@ -106,58 +99,23 @@ at least theoretically.
               (printf "result was ~a~n" e)
               e))]))
 
-(define-syntax (with-syntax* stx)
+;; run `h' last, but drop its return value
-  (syntax-case stx ()
+(define-syntax-rule (reverse-begin h . forms) (begin0 (begin . forms) h))
-    [(_ (cl) body ...) #'(with-syntax (cl) body ...)]
-    [(_ (cl cls ...) body ...)
-     #'(with-syntax (cl) (with-syntax* (cls ...) body ...))]
-    ))
 
-(define (filter-multiple l . fs)
+;; conditionalized logging
-  (apply values
+;; there's some logging code in the source
-         (map (lambda (f) (filter f l)) fs)))
+;; which was used for gathering statistics about various programs
-
+;; no longer used, probably bitrotted
-(define (syntax-map f stxl)
-  (map f (syntax->list stxl)))
-
-(define-syntax reverse-begin
-  (syntax-rules () [(_ h . forms) (begin0 (begin . forms) h)]))
-
-#;
-(define-syntax define-simple-syntax
-  (syntax-rules ()
-    [(dss (n . pattern) template)
-     (define-syntax n (syntax-rules () [(n . pattern) template]))]))
-
-(define log-file (make-parameter #f))
 (define-for-syntax logging? #f)
 
-(require (only-in mzlib/file file-name-from-path))
-
 (define-syntax (printf/log stx)
   (if logging?         
       (syntax-case stx ()
         [(_ fmt . args) 
-         #'(when (log-file)
+	 #'(log-debug (format fmt . args))])
-             (fprintf (log-file) (string-append "~a: " fmt) 
-                      (file-name-from-path (object-name (log-file)))
-                      . args))])
       #'(void)))
 
-(define (log-file-name src module-name)
+;; some macros to do some timing, only when `timing?' is #t
-  (if (path? src)
-      (path-replace-suffix src ".log")
-      (format "~a.log" module-name)))
-
-(define-syntax (with-logging-to-file stx)
-  (syntax-case stx ()
-    [(_ file . body)
-     (if logging?
-         #'(parameterize ([log-file (open-output-file file #:exists 'append)])
-             . body)
-         #'(begin . body))]))
-
-
 (define-for-syntax timing? #f)
 
 (define last-time (make-parameter #f))
@@ -184,9 +142,6 @@ at least theoretically.
       (values (lambda _ #'(void)) (lambda _ #'(void)))))
 
 
-(define (symbol-append . args)
-  (string->symbol (apply string-append (map symbol->string args))))
-
 (define-match-expander
   ==
   (lambda (stx)
@@ -194,6 +149,11 @@ at least theoretically.
       [(_ val)
        #'(? (lambda (x) (equal? val x)))])))
 
+;; custom printing
+;; this requires lots of work for two reasons:
+;; - 1 printers have to be defined at the same time as the structs
+;; - 2 we want to support things printing corectly even when the custom printer is off
+
 (define-for-syntax printing? #t)
 
 (define-syntax-rule (defprinter t ...)
@@ -217,8 +177,6 @@ at least theoretically.
 
 (define custom-printer (make-parameter #t))
   
-(require scheme/pretty mzlib/pconvert)
-
 (define-syntax (define-struct/printer stx)
   (syntax-case stx ()
     [(form name (flds ...) printer)
@@ -228,16 +186,6 @@ at least theoretically.
                #'([prop:custom-write pseudo-printer]))
          #f)]))
 
-(define (id kw . args)
-  (define (f v)
-    (cond [(string? v) v]
-          [(symbol? v) (symbol->string v)]
-          [(char? v) (string v)]
-          [(identifier? v) (symbol->string (syntax-e v))]
-	  [else (error "not coerceable:" v)]))
-  (datum->syntax kw (string->symbol (apply string-append (map f args)))))
-
-
 ;; map map (key val val -> val) -> map
 (define (hash-union h1 h2 f)
   (for/fold ([h* h1])
@@ -249,36 +197,12 @@ at least theoretically.
     (hash-set h* k new-val))))
 
 
-(define (in-pairs seq)
-  (make-do-sequence
-   (lambda ()
-     (let-values ([(more? gen) (sequence-generate seq)])
-       (values (lambda (e) (let ([e (gen)]) (values (car e) (cdr e))))
-               (lambda (_) #t)
-               #t
-               (lambda (_) (more?))
-               (lambda _ #t)
-               (lambda _ #t))))))
-
-(define (in-list-forever seq val)
-  (make-do-sequence
-   (lambda ()
-     (let-values ([(more? gen) (sequence-generate seq)])
-       (values (lambda (e) (let ([e (if (more?) (gen) val)]) e))
-               (lambda (_) #t)
-               #t
-               (lambda (_) #t)
-               (lambda _ #t)
-               (lambda _ #t))))))
-
-;; Listof[A] Listof[B] B -> Listof[B]
-;; pads out t to be as long as s
-(define (extend s t extra)
-  (append t (build-list (- (length s) (length t)) (lambda _ extra))))
 
+;; turn contracts on and off - off by default for performance.
 (define-for-syntax enable-contracts? #f)
 (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
 
+;; these are versions of the contract forms conditionalized by `enable-contracts?'
 (define-syntax p/c
   (if enable-contracts?
       (make-rename-transformer #'provide/contract)
@@ -286,7 +210,10 @@ at least theoretically.
         (define-syntax-class clause
           #:literals ()
           #:attributes (i)
-          (pattern [rename out:id in:id cnt:expr]
+          (pattern [struct nm:id (flds ...)]
+                   #:fail-unless (eq? (syntax-e #'struct) 'struct) #f
+		   #:with i #'(struct-out nm))
+	  (pattern [rename out:id in:id cnt:expr]
                    #:fail-unless (eq? (syntax-e #'rename) 'rename) #f
                    #:with i #'(rename-out [out in]))
           (pattern [i:id cnt:expr]))
@@ -323,15 +250,3 @@ at least theoretically.
      (if enable-contracts?
          (list #'[contracted (nm cnt)])     
          (list #'nm))]))
-
-
-(define (hashof k/c v/c)
-  (flat-named-contract
-   (format "#<hashof ~a ~a>" k/c v/c)
-   (lambda (h)
-     (define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c))
-     (define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c))
-     (and (hash? h)
-          (for/and ([(k v) h])
-            (and (k/c? k) 
-                 (v/c? v)))))))

collects/unstable/list.ss

@@ -28,3 +28,14 @@
 
 (provide/contract
  [list-prefix? (list? list? . -> . boolean?)])
+
+(define (filter-multiple l . fs)
+  (apply values
+         (map (lambda (f) (filter f l)) fs)))
+
+;; Listof[A] Listof[B] B -> Listof[B]
+;; pads out t to be as long as s
+(define (extend s t extra)
+  (append t (build-list (- (length s) (length t)) (lambda _ extra))))
+
+(provide filter-multiple extend)

collects/unstable/scribblings/list.scrbl

@@ -1,9 +1,14 @@
 #lang scribble/doc
 @(require scribble/base
           scribble/manual
-          (for-label unstable/list
+          scribble/eval
-                     scheme/contract
+	  "utils.ss"
-                     scheme/base))
+         (for-label unstable/list
+                    scheme/contract
+                    scheme/base))
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require unstable/list))
 
 @title[#:tag "list"]{Lists}
 
@@ -13,4 +18,26 @@
                        [r list?])
          boolean?]{
  True if @scheme[l] is a prefix of @scheme[r].
+@examples[#:eval the-eval
+(list-prefix? '(1 2) '(1 2 3 4 5))
+]
 }
+
+@addition{Sam Tobin-Hochstadt}
+
+@defproc[(filter-multiple [l list?] [f procedure?] ...) (values list? ...)]{
+Produces @scheme[(values (filter f l) ...)].
+
+@examples[#:eval the-eval
+(filter-multiple (list 1 2 3 4 5) even? odd?)
+]
+}
+
+@defproc[(extend [l1 list?] [l2 list?] [v any/c]) list?]{
+Extends @scheme[l2] to be as long as @scheme[l1] by adding @scheme[(-
+(length l1) (length l2))] copies of @scheme[v] to the end of
+@scheme[l2].   
+
+@examples[#:eval the-eval]
+(extend '(1 2 3) '(a) 'b)
+}

collects/unstable/scribblings/sequence.scrbl

@@ -0,0 +1,40 @@
+#lang scribble/doc
+@(require scribble/base
+          scribble/manual
+          scribble/eval
+	  scribblings/reference/mz
+	  "utils.ss"
+         (for-label unstable/sequence
+                    scheme/contract
+                    scheme/base))
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require unstable/sequence))
+
+@title[#:tag "sequence"]{Sequences}
+
+@defmodule[unstable/sequence]
+
+@unstable[@author+email["Sam Tobin-Hochstadt" "samth@ccs.neu.edu"]]
+
+
+@defproc[(in-syntax [stx syntax?]) sequence?]{
+Produces a sequence equivalent to @scheme[(syntax->list lst)].
+@speed[in-syntax "syntax"]
+
+@examples[#:eval the-eval
+(for/list ([x (in-syntax #'(1 2 3))])
+  x)]}
+
+@defproc[(in-pairs [seq sequence?]) sequence?]{
+Produces a sequence equivalent to
+ @scheme[(in-parallel (lift car seq) (lift cdr seq))].
+}
+
+@defproc[(in-sequence-forever [seq sequence?] [val any/c]) sequence?]{
+Produces a sequence whose values are the elements of @scheme[seq], followed by @scheme[val] repeated.
+}
+
+@defproc[(sequence-lift [f procedure?] [seq sequence?]) sequence?]{
+Produces the sequence of @scheme[f] applied to each element of @scheme[seq].
+}

collects/unstable/scribblings/syntax.scrbl

@@ -2,6 +2,7 @@
 @(require scribble/struct
           scribble/decode
           scribble/eval
+	  "utils.ss"
           (for-label scheme/base
                      scheme/contract
                      unstable/syntax))
@@ -183,7 +184,7 @@ or similar, has no effect.
 @;{----}
 
 @defproc[(format-symbol [fmt string?]
-                        [v (or/c string? symbol? identifier? keyword? number?)] ...)
+                        [v (or/c string? symbol? identifier? keyword? char? number?)] ...)
          symbol?]{
 
 Like @scheme[format], but produces a symbol. The format string must
@@ -200,7 +201,7 @@ are automatically converted to symbols.
                     [#:props props (or/c syntax? #f) #f]
                     [#:cert cert (or/c syntax? #f) #f]
                     [fmt string?]
-                    [v (or/c string? symbol? identifier? keyword? number?)] ...)
+                    [v (or/c string? symbol? identifier? keyword? char? number?)] ...)
          identifier?]{
 
 Like @scheme[format-symbol], but converts the symbol into an
@@ -230,3 +231,25 @@ in the argument list are automatically converted to symbols.
 (Scribble doesn't show it, but the DrScheme pinpoints the location of
 the second error but not of the first.)
 }
+
+@addition{Sam Tobin-Hochstadt}
+                     
+@defform[(with-syntax* ([pattern stx-expr] ...)
+           body ...+)]{
+Similar to @scheme[with-syntax], but the pattern variables are bound in the remaining
+@scheme[stx-expr]s as well as the @scheme[body]s, and the @scheme[pattern]s need not 
+bind distinct pattern variables; later bindings shadow earlier bindings.
+
+@examples[#:eval the-eval
+(with-syntax* ([(x y) (list #'val1 #'val2)]
+               [nest #'((x) (y))])
+  #'nest)
+]
+}
+
+@defproc[(syntax-map [f (-> syntax? A)] [stxl syntax?] ...) (listof A)]{
+Performs @scheme[(map f (syntax->list stxl) ...)].
+
+@examples[#:eval the-eval
+(syntax-map syntax-e #'(a b c))]
+}

collects/unstable/scribblings/unstable.scrbl

@@ -84,6 +84,7 @@ Keep documentation and tests up to date.
 @include-section["mutated-vars.scrbl"]
 @include-section["find.scrbl"]
 @include-section["class-iop.scrbl"]
+@include-section["sequence.scrbl"]
 
 @;{--------}
 

collects/unstable/scribblings/utils.ss

@@ -0,0 +1,15 @@
+#lang at-exp scheme/base
+
+(require scribble/base scribble/manual)
+
+(provide unstable addition)
+(define (unstable . authors)
+  (begin
+    (apply author authors)
+    @para{This library is @emph{unstable}; compatibility will not be maintained.
+	       See @secref{unstable} for more information.}))
+
+(define (addition name)
+  @margin-note{The subsequent bindings were added by @|name|.})
+
+

collects/unstable/sequence.ss

@@ -0,0 +1,45 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base))
+
+(provide in-syntax in-pairs in-sequence-forever sequence-lift)
+
+(define-sequence-syntax in-syntax 
+  (lambda () #'(lambda (e) (in-list (syntax->list e))))
+  (lambda (stx)
+    (syntax-case stx ()
+      [[ids (_ arg)]
+       #'[ids (in-list (syntax->list arg))]])))
+
+(define (in-pairs seq)
+  (make-do-sequence
+   (lambda ()
+     (let-values ([(more? gen) (sequence-generate seq)])
+       (values (lambda (e) (let ([e (gen)]) (values (car e) (cdr e))))
+               (lambda (_) #t)
+               #t
+               (lambda (_) (more?))
+               (lambda _ #t)
+               (lambda _ #t))))))
+
+(define (in-sequence-forever seq val)
+  (make-do-sequence
+   (lambda ()
+     (let-values ([(more? gen) (sequence-generate seq)])
+       (values (lambda (e) (let ([e (if (more?) (gen) val)]) e))
+               (lambda (_) #t)
+               #t
+               (lambda (_) #t)
+               (lambda _ #t)
+               (lambda _ #t))))))
+
+(define (sequence-lift f seq)
+  (make-do-sequence
+   (lambda ()
+     (let-values ([(more? gen) (sequence-generate seq)])
+       (values (lambda (e) (compose f gen))
+               (lambda (_) #t)
+               #t
+               (lambda (_) (more?))
+               (lambda _ #t)
+               (lambda _ #t))))))

collects/unstable/syntax.ss

@@ -24,7 +24,10 @@
          format-id
 
          current-syntax-context
-         wrong-syntax)
+         wrong-syntax
+         
+         with-syntax*
+         syntax-map)
 
 ;; Unwrapping syntax
 
@@ -158,8 +161,9 @@
         [(identifier? x) (syntax-e x)]
         [(keyword? x) (keyword->string x)]
         [(number? x) x]
+	[(char? x) x]
         [else (raise-type-error err
-                                "string, symbol, identifier, keyword, or number"
+                                "string, symbol, identifier, keyword, character, or number"
                                 x)]))
 
 ;; Error reporting
@@ -177,3 +181,12 @@
                         stx
                         extras)))
 ;; Eli: The `report-error-as' thing seems arbitrary to me.
+
+(define-syntax (with-syntax* stx)
+  (syntax-case stx ()
+    [(_ (cl) body ...) #'(with-syntax (cl) body ...)]
+    [(_ (cl cls ...) body ...)
+     #'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))
+
+(define (syntax-map f . stxls)
+  (apply map f (map syntax->list stxls)))