Adding contents of (planet cce/scheme:7) to collects/unstable/cce.

This is a staging area; these modules will be adapted to collects/unstable.

collects/unstable/cce/class.ss

@@ -0,0 +1,74 @@
+#lang scheme/base
+(require scheme/contract scheme/class
+         (for-syntax scheme/base))
+
+(define class-or-interface/c (or/c class? interface?))
+
+(define (subclass-or-implements/c class-or-iface)
+  (cond
+   [(class? class-or-iface) (subclass?/c class-or-iface)]
+   [(interface? class-or-iface) (implementation?/c class-or-iface)]
+   [else (error 'subclass-or-implements/c
+                "not a class or interface: ~s"
+                class-or-iface)]))
+
+(define (object-provides/c . class-or-ifaces)
+  (apply and/c object? (map is-a?/c class-or-ifaces)))
+
+(define (class-provides/c . class-or-ifaces)
+  (apply and/c class? (map subclass-or-implements/c class-or-ifaces)))
+
+(define-syntax (mixin-provides/c stx)
+  (syntax-case stx ()
+    [(form (super-in ...)
+           (sub-out ...))
+     (with-syntax ([(super-var ...)
+                    (generate-temporaries (syntax (super-in ...)))]
+                   [(sub-var ...)
+                    (generate-temporaries (syntax (sub-out ...)))])
+       (syntax/loc stx
+         (let* ([super-var super-in] ...
+                [sub-var sub-out] ...)
+           (->d ([super (class-provides/c super-var ...)])
+                ()
+                [_ (class-provides/c super sub-var ...)]))))]))
+
+(define-syntax (send+ stx)
+  (syntax-case stx ()
+    [(s+ expr clause ...)
+     (syntax/loc stx
+       (let* ([obj expr])
+         (send obj . clause) ...
+         obj))]))
+
+(define-syntax (send-each stx)
+  (syntax-case stx ()
+    [(se objs-expr method arg-expr ...)
+     (with-syntax ([(arg-var ...) (generate-temporaries #'(arg-expr ...))])
+       (syntax/loc stx
+         (let ([objs-var objs-expr]
+               [arg-var arg-expr]
+               ...)
+           (for-each (lambda (obj)
+                       (send obj method arg-var ...))
+                     objs-var))))]))
+
+(define (ensure-interface iface<%> mx class%)
+  (if (implementation? class% iface<%>)
+      class%
+      (mx class%)))
+
+(provide/contract
+ [class-or-interface/c flat-contract?]
+ [object-provides/c
+  (->* [] [] #:rest (listof class-or-interface/c) flat-contract?)]
+ [class-provides/c
+  (->* [] [] #:rest (listof class-or-interface/c) flat-contract?)]
+ [ensure-interface
+  (->d ([the-interface interface?]
+        [the-mixin (mixin-provides/c [] [the-interface])]
+        [the-class class?])
+       ()
+       [_ (class-provides/c the-class the-interface)])])
+
+(provide mixin-provides/c send+ send-each)

collects/unstable/cce/contract.ss

@@ -0,0 +1,268 @@
+#lang scheme
+
+(require (for-syntax syntax/parse))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Flat Contracts
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define nat/c
+  (flat-named-contract '|natural number| exact-nonnegative-integer?))
+
+(define pos/c
+  (flat-named-contract '|positive integer| exact-positive-integer?))
+
+(define truth/c
+  (flat-named-contract '|truth value| (lambda (x) #t)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Function Contracts
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define thunk/c (-> any/c))
+(define unary/c (-> any/c any/c))
+(define binary/c (-> any/c any/c any/c))
+(define predicate/c (-> any/c boolean?))
+(define comparison/c (-> any/c any/c boolean?))
+(define predicate-like/c (-> any/c truth/c))
+(define comparison-like/c (-> any/c any/c truth/c))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Contracted Sequences
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (sequence/c . elem/cs)
+  (let* ([elem/cs (for/list ([elem/c (in-list elem/cs)])
+                    (coerce-contract 'sequence/c elem/c))]
+         [n-cs (length elem/cs)])
+    (make-proj-contract
+     (apply build-compound-type-name 'sequence/c elem/cs)
+     (lambda (pos neg src name blame)
+       (lambda (seq)
+         (unless (sequence? seq)
+           (raise-contract-error
+            seq src pos name
+            "expected a sequence, got: ~e"
+            seq))
+           (make-do-sequence
+            (lambda ()
+              (let*-values ([(more? next) (sequence-generate seq)])
+                (values
+                 (lambda (idx)
+                   (call-with-values next
+                     (lambda elems
+                       (define n-elems (length elems))
+                       (unless (= n-elems n-cs)
+                         (raise-contract-error
+                          seq src pos name
+                          "expected a sequence of ~a values, got ~a values: ~s"
+                          n-cs n-elems elems))
+                       (apply
+                        values
+                        (for/list ([elem (in-list elems)]
+                                   [elem/c (in-list elem/cs)])
+                          ((((proj-get elem/c) elem/c) pos neg src name blame) elem))))))
+                 (lambda (idx) idx)
+                 #f
+                 (lambda (idx) (more?))
+                 (lambda (elem) #t)
+                 (lambda (idx elem) #t)))))))
+     sequence?)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Contracted Dictionaries
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; A CDict is (make-contracted-dictionary (Listof (Cons Proj Proj)) Dict)
+;; A Proj is (make-projection Contract Symbol Symbol Any Any)
+(define-struct contracted-dictionary [projections bindings])
+(define-struct projection [contract out in source name blame])
+
+(define (dict/c key/c value/c)
+  (let* ([key/c (coerce-contract 'dict/c key/c)]
+         [value/c (coerce-contract 'dict/c value/c)])
+    (make-proj-contract
+     (build-compound-type-name 'dict/c key/c value/c)
+     (lambda (pos neg src name blame)
+       (lambda (dict)
+         (unless (dict? dict)
+           (raise-contract-error dict src pos name
+                                 "expected a dictionary, got: ~e"
+                                 dict))
+         (wrap
+          (cons (cons (make-projection key/c pos neg src name blame)
+                      (make-projection value/c pos neg src name blame))
+                (dict->projections dict))
+          (dict->bindings dict))))
+     dict?)))
+
+(define-match-expander cdict
+  (syntax-rules () [(_ p b) (struct contracted-dictionary [p b])]))
+
+(define-match-expander proj
+  (syntax-rules () [(_ c o i s n b) (struct projection [c o i s n b])]))
+
+(define -ref
+  (case-lambda
+    [(dict key)
+     (match dict
+       [(cdict projs binds)
+        (let* ([key (key-in projs key)])
+          (value-out projs (dict-ref binds key)))])]
+    [(dict key failure)
+     (match dict
+       [(cdict projs binds)
+        (let* ([key (key-in projs key)])
+          (let/ec return
+            (define (fail)
+              (return (if (procedure? failure) (failure) failure)))
+            (value-out projs (dict-ref binds key fail))))])]))
+
+(define (-set! dict key value)
+  (match dict
+    [(cdict projs binds)
+     (dict-set! binds (key-in projs key) (value-in projs value))]))
+
+(define (-set dict key value)
+  (match dict
+    [(cdict projs binds)
+     (wrap projs (dict-set binds (key-in projs key) (value-in projs value)))]))
+
+(define (-rem! dict key)
+  (match dict
+    [(cdict projs binds)
+     (dict-remove! binds (key-in projs key))]))
+
+(define (-rem dict key)
+  (match dict
+    [(cdict projs binds)
+     (wrap projs (dict-remove binds (key-in projs key)))]))
+
+(define (-size dict)
+  (match dict
+    [(cdict projs binds)
+     (dict-count binds)]))
+
+(define (-fst dict)
+  (match dict
+    [(cdict projs binds)
+     (dict-iterate-first binds)]))
+
+(define (-nxt dict iter)
+  (match dict
+    [(cdict projs binds)
+     (dict-iterate-next binds iter)]))
+
+(define (-key dict iter)
+  (match dict
+    [(cdict projs binds)
+     (key-out projs (dict-iterate-key binds iter))]))
+
+(define (-val dict iter)
+  (match dict
+    [(cdict projs binds)
+     (value-out projs (dict-iterate-value binds iter))]))
+
+(define (key-in projs key)
+  (if (null? projs)
+      key
+      (key-in (cdr projs) (project-in (caar projs) key))))
+
+(define (value-in projs value)
+  (if (null? projs)
+      value
+      (value-in (cdr projs) (project-in (cdar projs) value))))
+
+(define (key-out projs key)
+  (if (null? projs)
+      key
+      (project-out (caar projs) (key-out (cdr projs) key))))
+
+(define (value-out projs value)
+  (if (null? projs)
+      value
+      (project-out (cdar projs) (value-out (cdr projs) value))))
+
+(define (project-in p x)
+  (match p
+    [(proj c o i s n b)
+     ((((proj-get c) c) i o s n (not b)) x)]))
+
+(define (project-out p x)
+  (match p
+    [(proj c o i s n b)
+     ((((proj-get c) c) o i s n b) x)]))
+
+(define (dict->bindings dict)
+  (match dict
+    [(cdict projs binds) binds]
+    [_ dict]))
+
+(define (dict->projections dict)
+  (match dict
+    [(cdict projs binds) projs]
+    [_ null]))
+
+(define (wrap projs binds)
+  ((dict->wrapper binds) projs binds))
+
+(define (dict->wrapper dict)
+  (if (dict-mutable? dict)
+      (if (dict-can-functional-set? dict)
+          (if (dict-can-remove-keys? dict) make-:!+- make-:!+_)
+          (if (dict-can-remove-keys? dict) make-:!_- make-:!__))
+      (if (dict-can-functional-set? dict)
+          (if (dict-can-remove-keys? dict) make-:_+- make-:_+_)
+          (if (dict-can-remove-keys? dict) make-:__- make-:___))))
+
+;; The __- case (removal without functional or mutable update) is nonsensical.
+(define prop:!+- (vector -ref -set! -set -rem! -rem -size -fst -nxt -key -val))
+(define prop:!+_ (vector -ref -set! -set  #f    #f  -size -fst -nxt -key -val))
+(define prop:!_- (vector -ref -set!  #f  -rem!  #f  -size -fst -nxt -key -val))
+(define prop:!__ (vector -ref -set!  #f   #f    #f  -size -fst -nxt -key -val))
+(define prop:_+- (vector -ref  #f   -set  #f   -rem -size -fst -nxt -key -val))
+(define prop:_+_ (vector -ref  #f   -set  #f   -rem -size -fst -nxt -key -val))
+(define prop:__- (vector -ref  #f    #f   #f    #f  -size -fst -nxt -key -val))
+(define prop:___ (vector -ref  #f    #f   #f    #f  -size -fst -nxt -key -val))
+
+;; The __- case (removal without functional or mutable update) is nonsensical.
+(define-struct (:!+- contracted-dictionary) [] #:property prop:dict prop:!+-)
+(define-struct (:!+_ contracted-dictionary) [] #:property prop:dict prop:!+_)
+(define-struct (:!_- contracted-dictionary) [] #:property prop:dict prop:!_-)
+(define-struct (:!__ contracted-dictionary) [] #:property prop:dict prop:!__)
+(define-struct (:_+- contracted-dictionary) [] #:property prop:dict prop:_+-)
+(define-struct (:_+_ contracted-dictionary) [] #:property prop:dict prop:_+_)
+(define-struct (:__- contracted-dictionary) [] #:property prop:dict prop:__-)
+(define-struct (:___ contracted-dictionary) [] #:property prop:dict prop:___)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Exports
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide/contract
+
+ [nat/c flat-contract?]
+ [pos/c flat-contract?]
+ [truth/c flat-contract?]
+
+ [thunk/c contract?]
+ [unary/c contract?]
+ [binary/c contract?]
+ [predicate/c contract?]
+ [comparison/c contract?]
+ [predicate-like/c contract?]
+ [comparison-like/c contract?]
+
+ [sequence/c (->* [] [] #:rest (listof contract?) contract?)]
+ [dict/c (-> contract? contract? contract?)]
+ )

collects/unstable/cce/debug.ss

@@ -0,0 +1,161 @@
+#lang scheme
+
+(provide debug
+         dprintf
+         begin/debug
+         define/debug
+         define/private/debug
+         define/public/debug
+         define/override/debug
+         define/augment/debug
+         let/debug
+         let*/debug
+         letrec/debug
+         let-values/debug
+         let*-values/debug
+         letrec-values/debug
+         with-syntax/debug
+         with-syntax*/debug
+         parameterize/debug
+         with-debugging)
+
+(require unstable/srcloc
+         unstable/location
+         unstable/syntax
+         (for-syntax scheme/match syntax/parse unstable/syntax))
+
+(define-syntax (let/debug stx)
+  (syntax-parse stx
+    [(_ (~optional loop:id) ([lhs:id rhs:expr] ...) body:expr ...+)
+     #`(with-debugging
+        #:name '#,(if (attribute loop) #'loop #'let/debug)
+        #:source (quote-srcloc #,stx)
+        (let #,@(if (attribute loop) (list #'loop) null)
+          ([lhs (with-debugging #:name 'lhs rhs)] ...)
+          (debug body) ...))]))
+
+(define-syntaxes
+  [ let*/debug
+    letrec/debug
+    let-values/debug
+    let*-values/debug
+    letrec-values/debug
+    with-syntax/debug
+    with-syntax*/debug
+    parameterize/debug ]
+
+  (let ()
+
+    (define ((expander binder-id) stx)
+      (with-syntax ([binder binder-id])
+        (syntax-parse stx
+          [(binder/debug:id ([lhs rhs:expr] ...) body:expr ...+)
+           #`(with-debugging
+              #:name 'binder/debug
+              #:source (quote-srcloc #,stx)
+              (binder
+               ([lhs (with-debugging #:name 'lhs rhs)] ...)
+               (debug body) ...))])))
+
+    (values (expander #'let*)
+            (expander #'letrec)
+            (expander #'let-values)
+            (expander #'let*-values)
+            (expander #'letrec-values)
+            (expander #'with-syntax)
+            (expander #'with-syntax*)
+            (expander #'parameterize))))
+
+(define-syntaxes
+  [ define/debug
+    define/private/debug
+    define/public/debug
+    define/override/debug
+    define/augment/debug ]
+
+  (let ()
+
+    (define-syntax-class header
+      #:attributes [name]
+      (pattern (name:id . _))
+      (pattern (inner:header . _) #:attr name (attribute inner.name)))
+
+    (define ((expander definer-id) stx)
+      (with-syntax ([definer definer-id])
+        (syntax-parse stx
+          [(definer/debug:id name:id body:expr)
+           #`(definer name
+               (with-debugging
+                #:name 'name
+                #:source (quote-srcloc #,stx)
+                body))]
+          [(definer/debug:id spec:header body:expr ...+)
+           #`(definer spec
+               (with-debugging
+                #:name 'spec.name
+                #:source (quote-srcloc #,stx)
+                (let () body ...)))])))
+
+    (values (expander #'define)
+            (expander #'define/private)
+            (expander #'define/public)
+            (expander #'define/override)
+            (expander #'define/augment))))
+
+(define-syntax (begin/debug stx)
+  (syntax-parse stx
+    [(_ term:expr ...)
+     #`(with-debugging
+        #:name 'begin/debug
+        #:source (quote-srcloc #,stx)
+        (begin (debug term) ...))]))
+
+(define-syntax (debug stx)
+  (syntax-parse stx
+    [(_ term:expr)
+     (syntax (with-debugging term))]))
+
+(define-syntax (with-debugging stx)
+  (syntax-parse stx
+    [(_ (~or (~optional (~seq #:name name:expr))
+             (~optional (~seq #:source source:expr)))
+        ...
+        body:expr)
+     (with-syntax* ([name (or (attribute name) #'(quote body))]
+                    [source (or (attribute source) #'(quote-srcloc body))])
+       #'(with-debugging/proc
+          name
+          source
+          (quote body)
+          (lambda () (#%expression body))))]))
+
+(define (with-debugging/proc name source term thunk)
+  (let* ([src (source-location->prefix source)])
+    (begin
+      (dprintf ">> ~a~s" src name)
+      (begin0
+        (parameterize ([current-debug-depth
+                        (add1 (current-debug-depth))])
+          (call-with-values thunk
+            (lambda results
+              (match results
+                [(list v) (dprintf "~s" v)]
+                [(list vs ...)
+                 (dprintf "(values~a)"
+                          (apply string-append
+                            (for/list ([v (in-list vs)])
+                              (format " ~s" v))))])
+              (apply values results))))
+        (dprintf "<< ~a~s" src name)))))
+
+(define (dprintf fmt . args)
+  (let* ([message (apply format fmt args)]
+         [prefix (make-string (* debug-indent (current-debug-depth)) #\space)]
+         [indented
+          (string-append
+           prefix
+           (regexp-replace* "\n" message (string-append "\n" prefix)))])
+    (log-debug indented)))
+
+(define current-debug-depth (make-parameter 0))
+(define debug-indent 2)

collects/unstable/cce/define.ss

@@ -0,0 +1,140 @@
+#lang scheme
+
+(require "private/define-core.ss"
+         (for-syntax scheme/match
+                     syntax/kerncase
+                     "syntax.ss"))
+
+(provide
+
+ in-phase1 in-phase1/pass2
+
+ block
+ at-end
+
+ declare-names
+ define-renamings
+ define-single-definition
+ define-with-parameter
+
+ define-if-unbound
+ define-values-if-unbound
+ define-syntax-if-unbound
+ define-syntaxes-if-unbound)
+
+(define-syntax (at-end stx)
+  (syntax-case stx ()
+    [(_ e ...)
+     (match (syntax-local-context)
+       ['module
+         (begin
+           (syntax-local-lift-module-end-declaration
+            (syntax/loc stx (begin e ...)))
+           (syntax/loc stx (begin)))]
+       [ctx (syntax-error stx
+                          "can only be used in module context; got: ~s"
+                          ctx)])]))
+
+(define-syntax-rule (define-with-parameter name parameter)
+  (define-syntax-rule (name value body (... ...))
+    (parameterize ([parameter value]) body (... ...))))
+
+(define-syntax (#%definition stx0)
+  (syntax-case stx0 ()
+    [(_ form)
+     (let* ([stx (head-expand #'form)])
+       (syntax-case stx ( module
+                          #%require
+                          #%provide
+                          define-values
+                          define-syntaxes
+                          define-values-for-syntax
+                          begin )
+         [(module . _) stx]
+         [(#%require . _) stx]
+         [(#%provide . _) stx]
+         [(define-values . _) stx]
+         [(define-syntaxes . _) stx]
+         [(define-values-for-syntax . _) stx]
+         [(begin d ...) (syntax/loc stx0 (begin (#%definition d) ...))]
+         [_ (raise-syntax-error '#%definition "not a definition" stx0 stx)]))]))
+
+(define-syntax (#%as-definition stx0)
+  (syntax-case stx0 ()
+    [(_ form)
+     (let* ([stx (head-expand #'form)])
+       (syntax-case stx ( module
+                          #%require
+                          #%provide
+                          define-values
+                          define-syntaxes
+                          define-values-for-syntax
+                          begin )
+         [(module . _) stx]
+         [(#%require . _) stx]
+         [(#%provide . _) stx]
+         [(define-values . _) stx]
+         [(define-syntaxes . _) stx]
+         [(define-values-for-syntax . _) stx]
+         [(begin d ...) (syntax/loc stx0 (begin (#%as-definition d) ...))]
+         [e
+          (syntax/loc stx0
+            (define-values [] (begin e (#%plain-app values))))]))]))
+
+(define-syntax (#%as-expression stx0)
+  (syntax-case stx0 ()
+    [(_ form)
+     (let* ([stx (head-expand #'form)]
+            ;; pre-compute this to save duplicated code below
+            [done (quasisyntax/loc stx0 (begin #,stx (#%plain-app void)))])
+       (syntax-case stx ( module
+                          #%require
+                          #%provide
+                          define-values
+                          define-syntaxes
+                          define-values-for-syntax
+                          begin )
+         [(module . _) done]
+         [(#%require . _) done]
+         [(#%provide . _) done]
+         [(define-values . _) done]
+         [(define-syntaxes . _) done]
+         [(define-values-for-syntax . _) done]
+         [(begin) (syntax/loc stx0 (#%plain-app void))]
+         [(begin d ... e)
+          (syntax/loc stx0 (begin (#%as-definition d) ... (#%as-expression e)))]
+         [_ stx]))]))
+
+(define-syntax-rule (block form ...)
+  (let-values () (#%as-expression (begin form ...))))
+
+(define-syntax (declare-names stx)
+  (match (syntax-local-context)
+    ['top-level
+     (syntax-case stx []
+       [(_ name ...) (syntax/loc stx (define-syntaxes [name ...] (values)))])]
+    [_ (syntax/loc stx (begin))]))
+
+(define-syntax-rule (define-renamings [new old] ...)
+  (define-syntaxes [new ...] (values (make-rename-transformer #'old) ...)))
+
+(define-syntax (in-phase1 stx)
+  (syntax-case stx []
+    [(_ e)
+     (match (syntax-local-context)
+       ['expression (syntax/loc stx (let-syntax ([dummy e]) (void)))]
+       [(or 'module 'top-level (? pair?))
+        (syntax/loc stx
+          (begin
+            (define-syntax (macro stx*) (begin e (syntax/loc stx* (begin))))
+            (macro)))]
+       ['module-begin (syntax-error stx "cannot be used as module body")])]))
+
+(define-syntax (in-phase1/pass2 stx)
+  (syntax-case stx []
+    [(_ e)
+     (match (syntax-local-context)
+       [(? pair?)
+        (syntax/loc stx (define-values [] (begin (in-phase1 e) (values))))]
+       [(or 'expression 'top-level 'module 'module-begin)
+        (syntax/loc stx (#%expression (in-phase1 e)))])]))

collects/unstable/cce/dict.ss

@@ -0,0 +1,279 @@
+#lang scheme
+
+(require "define.ss" "contract.ss")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  "Missing" Functions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-if-unbound dict-has-key?
+  (let ()
+    (with-contract
+     dict-has-key?
+     ([dict-has-key? (-> dict? any/c boolean?)])
+     (define (dict-has-key? dict key)
+       (let/ec return
+         (dict-ref dict key (lambda () (return #f)))
+         #t)))
+    dict-has-key?))
+
+(define-if-unbound dict-ref!
+  (let ()
+    (with-contract
+     dict-ref!
+     ([dict-ref! (-> (and/c dict? dict-mutable?)
+                     any/c
+                     (or/c (-> any/c) any/c)
+                     any/c)])
+     (define (dict-ref! dict key failure)
+       (dict-ref
+        dict key
+        (lambda ()
+          (let* ([value (if (procedure? failure) (failure) failure)])
+            (dict-set! dict key value)
+            value)))))
+    dict-ref!))
+
+(define-if-unbound (dict-empty? dict)
+  (= (dict-count dict) 0))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Constructors
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (empty-dict #:weak? [weak? #f]
+                    #:mutable? [mutable? weak?]
+                    #:compare [compare 'equal])
+  (match* [mutable? weak? compare]
+    ;; Immutable
+    ([#f #f 'equal] (make-immutable-hash null))
+    ([#f #f 'eqv] (make-immutable-hasheqv null))
+    ([#f #f 'eq] (make-immutable-hasheq null))
+    ;; Mutable
+    ([#t #f 'equal] (make-hash))
+    ([#t #f 'eqv] (make-hasheqv))
+    ([#t #f 'eq] (make-hasheq))
+    ;; Weak
+    ([#t #t 'equal] (make-weak-hash))
+    ([#t #t 'eqv] (make-weak-hash))
+    ([#t #t 'eq] (make-weak-hash))
+    ;; Impossible
+    ([#f #t _] (error 'empty-set "cannot create an immutable weak hash"))))
+
+(define (make-dict dict
+                   #:weak? [weak? #f]
+                   #:mutable? [mutable? weak?]
+                   #:compare [compare 'equal])
+  (let* ([MT (empty-dict #:mutable? mutable? #:weak? weak? #:compare compare)])
+    (if mutable?
+      (begin (dict-union! MT dict) MT)
+      (dict-union MT dict))))
+
+(define (custom-dict equiv?
+                     [hash1 (lambda (x) 0)]
+                     [hash2 (lambda (x) 0)]
+                     #:weak? [weak? #f]
+                     #:mutable? [mutable? weak?])
+  (match* [mutable? weak?]
+    ([#f #f] (make-immutable-custom-hash equiv? hash1 hash2))
+    ([#t #f] (make-custom-hash equiv? hash1 hash2))
+    ([#t #t] (make-weak-custom-hash equiv? hash1 hash2))
+    ([#f #t] (error 'custom-set "cannot create an immutable weak hash"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Ref Wrappers
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (dict-ref/check dict key)
+  (dict-ref dict key))
+
+(define (dict-ref/identity dict key)
+  (dict-ref dict key (lambda () key)))
+
+(define (dict-ref/default dict key default)
+  (dict-ref dict key (lambda () default)))
+
+(define (dict-ref/failure dict key failure)
+  (dict-ref dict key (lambda () (failure))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Extra Accessors
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (dict-domain dict)
+  (for/list ([i (in-dict-keys dict)]) i))
+
+(define (dict-range dict)
+  (for/list ([i (in-dict-values dict)]) i))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Union
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define ((dict-duplicate-error name) key value1 value2)
+  (error name "duplicate values for key ~e: ~e and ~e" key value1 value2))
+
+(define (dict-union
+         #:combine [combine #f]
+         #:combine/key [combine/key
+                        (if combine
+                          (lambda (k x y) (combine x y))
+                          (dict-duplicate-error 'dict-union))]
+         one . rest)
+  (for*/fold ([one one]) ([two (in-list rest)] [(k v) (in-dict two)])
+    (dict-set one k (if (dict-has-key? one k)
+                        (combine/key k (dict-ref one k) v)
+                        v))))
+
+(define (dict-union!
+         #:combine [combine #f]
+         #:combine/key [combine/key
+                        (if combine
+                          (lambda (k x y) (combine x y))
+                          (dict-duplicate-error 'dict-union))]
+         one . rest)
+  (for* ([two (in-list rest)] [(k v) (in-dict two)])
+    (dict-set! one k (if (dict-has-key? one k)
+                         (combine/key k (dict-ref one k) v)
+                         v))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Property delegation
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (wrapped-dict-property
+         #:unwrap unwrap
+         #:wrap [wrap #f]
+         #:predicate [pred (lambda (x) #t)]
+         #:mutable? [mutable? #t]
+         #:functional? [functional? (if wrap #t #f)]
+         #:remove? [remove? #t])
+  (let* ([unwrap (protect-unwrap pred unwrap)]
+         [wrap (and wrap (protect-wrap pred wrap))])
+    (vector (wrapped-ref unwrap)
+            (and mutable? (wrapped-set! unwrap))
+            (and functional? wrap (wrapped-set unwrap wrap))
+            (and mutable? remove? (wrapped-remove! unwrap))
+            (and functional? remove? wrap (wrapped-remove unwrap wrap))
+            (wrapped-count unwrap)
+            (wrapped-iterate-first unwrap)
+            (wrapped-iterate-next unwrap)
+            (wrapped-iterate-key unwrap)
+            (wrapped-iterate-value unwrap))))
+
+(define ((protect-unwrap pred unwrap) op x)
+  (unless (pred x)
+    (raise
+     (make-exn:fail:contract
+      (format "~a: expected a <~a>, but got: ~e"
+              op (object-name pred) x)
+      (current-continuation-marks))))
+  (unwrap x))
+
+(define ((protect-wrap pred wrap) op x)
+  (let* ([y (wrap x)])
+    (unless (pred y)
+      (raise
+       (make-exn:fail:contract
+        (format "~a: tried to construct a <~a>, but got: ~e"
+                op (object-name pred) x)
+        (current-continuation-marks))))
+    y))
+
+(define (wrapped-ref unwrap)
+  (case-lambda
+    [(dict key) (dict-ref (unwrap 'dict-ref dict) key)]
+    [(dict key fail) (dict-ref (unwrap 'dict-ref dict) key fail)]))
+
+(define ((wrapped-set! unwrap) dict key value)
+  (dict-set! (unwrap 'dict-set! dict) key value))
+
+(define ((wrapped-set unwrap wrap) dict key value)
+  (wrap 'dict-set (dict-set (unwrap 'dict-set dict) key value)))
+
+(define ((wrapped-remove! unwrap) dict key)
+  (dict-remove! (unwrap 'dict-remove! dict) key))
+
+(define ((wrapped-remove unwrap wrap) dict key)
+  (wrap 'dict-remove (dict-remove (unwrap 'dict-remove dict) key)))
+
+(define ((wrapped-count unwrap) dict)
+  (dict-count (unwrap 'dict-count dict)))
+
+(define ((wrapped-iterate-first unwrap) dict)
+  (dict-iterate-first (unwrap 'dict-iterate-first dict)))
+
+(define ((wrapped-iterate-next unwrap) dict pos)
+  (dict-iterate-next (unwrap 'dict-iterate-next dict) pos))
+
+(define ((wrapped-iterate-key unwrap) dict pos)
+  (dict-iterate-key (unwrap 'dict-iterate-key dict) pos))
+
+(define ((wrapped-iterate-value unwrap) dict pos)
+  (dict-iterate-value (unwrap 'dict-iterate-value dict) pos))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Exports
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide dict/c dict-has-key? dict-ref!)
+(provide/contract
+ [dict-empty? (-> dict? boolean?)]
+ [empty-dict
+  (->* []
+       [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)]
+       hash?)]
+ [make-dict
+  (->* [dict?]
+       [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)]
+       hash?)]
+ [custom-dict
+  (->* [(-> any/c any/c any/c)]
+       [(-> any/c exact-integer?) (-> any/c exact-integer?)
+        #:mutable? boolean? #:weak? boolean?]
+       dict?)]
+ [wrapped-dict-property
+  (->* [#:unwrap (-> dict? dict?)]
+       [#:wrap (-> dict? dict?)
+        #:predicate (-> any/c boolean?)
+        #:mutable? boolean?
+        #:remove? boolean?
+        #:functional? boolean?]
+       vector?)]
+ [dict-ref/identity (-> dict? any/c any/c)]
+ [dict-ref/default (-> dict? any/c any/c any/c)]
+ [dict-ref/failure (-> dict? any/c (-> any/c) any/c)]
+ [dict-ref/check
+  (->d ([table dict?] [key any/c]) ()
+       #:pre-cond (dict-has-key? table key)
+       [_ any/c])]
+ [dict-domain (-> dict? list?)]
+ [dict-range (-> dict? list?)]
+ [dict-union (->* [(and/c dict? dict-can-functional-set?)]
+                  [#:combine
+                   (-> any/c any/c any/c)
+                   #:combine/key
+                   (-> any/c any/c any/c any/c)]
+                  #:rest (listof dict?)
+                  (and/c dict? dict-can-functional-set?))]
+ [dict-union! (->* [(and/c dict? dict-mutable?)]
+                   [#:combine
+                   (-> any/c any/c any/c)
+                   #:combine/key
+                   (-> any/c any/c any/c any/c)]
+                   #:rest (listof dict?)
+                   void?)])

collects/unstable/cce/drscheme.ss

@@ -0,0 +1,198 @@
+#lang scheme/gui
+
+(require drscheme/tool
+         string-constants
+         "dict.ss"
+         (only-in test-engine/scheme-gui make-formatter)
+         (only-in test-engine/scheme-tests
+                  scheme-test-data test-format test-execute)
+         (lib "test-display.scm" "test-engine"))
+
+(provide language-level^
+         language-level@)
+
+(define (read-all-syntax [port (current-input-port)]
+                         [source (object-name port)]
+                         [reader read-syntax])
+  (let loop ()
+    (let* ([next (reader source port)])
+      (if (eof-object? next)
+          null
+          (cons next (loop))))))
+
+(define (read-module-body [port (current-input-port)]
+                          [source (object-name port)]
+                          [reader read-syntax]
+                          [path 'scheme]
+                          [name 'program])
+  (let*-values ([(line-1 col-1 pos-1) (port-next-location port)]
+                [(terms) (read-all-syntax port source reader)]
+                [(line-2 col-2 pos-2) (port-next-location port)]
+                [(loc) (list source line-1 col-1 pos-1
+                             (and pos-1 pos-2 (- pos-2 pos-1)))])
+    (map (lambda (datum) (datum->syntax #'here datum loc))
+         (list `(module ,name ,path
+                  (,(datum->syntax #f '#%module-begin) ,@terms))
+               `(require ',name)
+               `(current-namespace (module->namespace '',name))))))
+
+(define-signature language-level^
+  (simple-language-level%
+   make-language-level
+   language-level-render-mixin
+   language-level-capability-mixin
+   language-level-eval-as-module-mixin
+   language-level-no-executable-mixin
+   language-level-macro-stepper-mixin
+   language-level-check-expect-mixin
+   language-level-metadata-mixin))
+
+(define-unit language-level@
+  (import drscheme:tool^)
+  (export language-level^)
+
+  (define (make-language-level
+           name path
+           #:number [number (equal-hash-code name)]
+           #:hierarchy [hierarchy experimental-language-hierarchy]
+           #:summary [summary name]
+           #:url [url #f]
+           #:reader [reader read-syntax]
+           . mixins)
+    (let* ([mx-default (drscheme:language:get-default-mixin)]
+           [mx-custom (apply compose (reverse mixins))])
+      (new (mx-custom (mx-default simple-language-level%))
+           [module path]
+           [language-position (append (map car hierarchy) (list name))]
+           [language-numbers (append (map cdr hierarchy) (list number))]
+           [one-line-summary summary]
+           [language-url url]
+           [reader (make-namespace-syntax-reader reader)])))
+
+  (define simple-language-level%
+    (drscheme:language:module-based-language->language-mixin
+     (drscheme:language:simple-module-based-language->module-based-language-mixin
+      drscheme:language:simple-module-based-language%)))
+
+  (define (language-level-render-mixin to-sexp show-void?)
+    (mixin (drscheme:language:language<%>) ()
+      (super-new)
+
+      (define/override (render-value/format value settings port width)
+        (unless (and (void? value) (not show-void?))
+          (super render-value/format (to-sexp value) settings port width)))))
+
+  (define (language-level-capability-mixin dict)
+    (mixin (drscheme:language:language<%>) ()
+      (super-new)
+
+      (define/augment (capability-value key)
+        (dict-ref/failure
+         dict key
+         (lambda ()
+           (inner (drscheme:language:get-capability-default key)
+                  capability-value key))))))
+
+  (define language-level-no-executable-mixin
+    (mixin (drscheme:language:language<%>) ()
+      (super-new)
+      (inherit get-language-name)
+
+      (define/override (create-executable settings parent filename)
+        (message-box
+         "Create Executable: Error"
+         (format "Sorry, ~a does not support creating executables."
+                 (get-language-name))
+         #f '(ok stop)))))
+
+  (define language-level-eval-as-module-mixin
+    (mixin (drscheme:language:language<%>
+            drscheme:language:module-based-language<%>) ()
+      (super-new)
+
+      (inherit get-reader get-module)
+
+      (define/override (front-end/complete-program port settings)
+        (let* ([terms #f])
+          (lambda ()
+            ;; On the first run through, initialize the list.
+            (unless terms
+              (set! terms (read-module-body port
+                                            (object-name port)
+                                            (get-reader)
+                                            (get-module))))
+            ;; Produce each list element in order.
+            (if (pair? terms)
+                ;; Produce and remove a list element.
+                (begin0 (car terms) (set! terms (cdr terms)))
+                ;; After null, eof forever.
+                eof))))))
+
+  (define language-level-macro-stepper-mixin
+    (language-level-capability-mixin
+     (make-immutable-hasheq
+      (list (cons 'macro-stepper:enabled #t)))))
+
+  (define language-level-check-expect-mixin
+    (mixin (drscheme:language:language<%>) ()
+      (super-new)
+      (inherit render-value/format)
+
+      (define/augment (capability-value key)
+        (case key
+          [(tests:test-menu tests:dock-menu) #t]
+          [else (inner (drscheme:language:get-capability-default key)
+                       capability-value
+                       key)]))
+
+      (define/override (on-execute settings run-in-user-thread)
+        (let* ([drscheme-namespace (current-namespace)]
+               [test-engine-path
+                ((current-module-name-resolver)
+                 'test-engine/scheme-tests #f #f)])
+          (run-in-user-thread
+           (lambda ()
+             (namespace-attach-module drscheme-namespace test-engine-path)
+             (namespace-require test-engine-path)
+             (scheme-test-data
+              (list (drscheme:rep:current-rep)
+                    drscheme-eventspace
+                    test-display%))
+             (test-execute (get-preference 'tests:enable? (lambda () #t)))
+             (test-format
+              (make-formatter
+               (lambda (v o) (render-value/format v settings o 40))))))
+          (super on-execute settings run-in-user-thread)))))
+
+  (define (language-level-metadata-mixin reader-module
+                                         meta-lines
+                                         meta->settings
+                                         settings->meta)
+    (mixin (drscheme:language:language<%>) ()
+      (inherit default-settings)
+      (super-new)
+
+      (define/override (get-reader-module) reader-module)
+
+      (define/override (get-metadata modname settings)
+        (settings->meta modname settings))
+
+      (define/override (metadata->settings metadata)
+        (meta->settings metadata (default-settings)))
+
+      (define/override (get-metadata-lines) meta-lines)))
+
+  (define (generic-syntax-reader . args)
+    (parameterize ([read-accept-reader #t])
+      (apply read-syntax args)))
+
+  (define (make-namespace-syntax-reader reader)
+    (lambda args
+      (let ([stx (apply reader args)])
+        (if (syntax? stx) (namespace-syntax-introduce stx) stx))))
+
+  (define drscheme-eventspace (current-eventspace))
+
+  (define experimental-language-hierarchy
+    (list (cons (string-constant experimental-languages)
+                1000))))

collects/unstable/cce/exn.ss

@@ -0,0 +1,11 @@
+#lang scheme
+
+(define-syntax (try stx)
+  (syntax-case stx ()
+    [(_ e) #'(#%expression e)]
+    [(_ e0 e ...)
+     (syntax/loc stx
+       (with-handlers* ([exn:fail? (lambda (x) (try e ...))])
+         (#%expression e0)))]))
+
+(provide try)

collects/unstable/cce/function.ss

@@ -0,0 +1,382 @@
+#lang scheme/base
+(require scheme/dict scheme/match scheme/function "define.ss"
+         (for-syntax scheme/base scheme/list))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  HIGHER ORDER TOOLS
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Automatic case-lambda repetition
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-for-syntax (split-syntax-at orig stx id)
+  (let loop ([found #f]
+             [seen null]
+             [stx stx])
+    (syntax-case stx []
+      [(head . tail)
+       (and (identifier? #'head)
+            (free-identifier=? #'head id))
+       (if found
+           (raise-syntax-error
+            #f
+            (format "duplicate occurrence of ~a" (syntax-e id))
+            orig
+            #'head)
+           (loop (list (reverse seen) #'head #'tail)
+                 (cons #'head seen)
+                 #'tail))]
+      [(head . tail) (loop found (cons #'head seen) #'tail)]
+      [_ found])))
+
+(define-for-syntax (expand-ellipsis-clause stx pattern expr)
+  (cond
+   [(split-syntax-at stx pattern #'(... ...))
+    =>
+    (lambda (found)
+      (syntax-case found [...]
+        [([pre ... repeat] (... ...) [count post ... . tail])
+         (and (identifier? #'repeat)
+              (exact-nonnegative-integer? (syntax-e #'count)))
+         (build-list
+          (add1 (syntax-e #'count))
+          (lambda (i)
+            (with-syntax ([(var ...)
+                           (generate-temporaries
+                            (build-list i (lambda (j) #'repeat)))]
+                          [body expr])
+              (list
+               (syntax/loc pattern (pre ... var ... post ... . tail))
+               (syntax/loc expr
+                 (let-syntax ([the-body
+                               (lambda _
+                                 (with-syntax ([(repeat (... ...)) #'(var ...)])
+                                   #'body))])
+                   the-body))))))]
+        [(pre mid post)
+         (raise-syntax-error
+          #f
+          "expected ellipsis between identifier and natural number literal"
+          stx
+          #'mid)]))]
+   [else (list (list pattern expr))]))
+
+(define-syntax (case-lambda* stx)
+  (syntax-case stx []
+    [(_ [pattern body] ...)
+     (with-syntax ([([pattern body] ...)
+                    (append-map
+                     (lambda (p e) (expand-ellipsis-clause stx p e))
+                     (syntax->list #'(pattern ...))
+                     (syntax->list #'(body ...)))])
+       (syntax/loc stx
+         (case-lambda [pattern body] ...)))]))
+
+(define-syntax (make-intermediate-procedure stx)
+  (syntax-case stx [quote]
+    [(_ (quote name) positional-clause ... #:keyword keyword-clause)
+     (syntax/loc stx
+       (make-keyword-procedure
+        (let* ([name (case-lambda keyword-clause)]) name)
+        (let* ([name (case-lambda* positional-clause ...)]) name)))]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Degenerate Functions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (identity x) x)
+
+(define-if-unbound (const v)
+  (make-intermediate-procedure
+   'constant-function
+   [(x ... 8) v]
+   [xs v]
+   #:keyword
+   [(ks vs . xs) v]))
+
+(define-syntax (thunk stx)
+  (syntax-case stx ()
+    [(thunk body ...)
+     (syntax/loc stx
+       (make-keyword-thunk (lambda () body ...)))]))
+
+(define (make-keyword-thunk f)
+  (make-intermediate-procedure
+   'thunk-function
+    [(x ... 8) (f)]
+    [xs (f)]
+    #:keyword
+    [(ks vs . xs) (f)]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Higher-Order Boolean Operations
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define conjoin
+  (case-lambda*
+   [(f ... 8)
+    (make-intermediate-procedure
+     'conjoined
+      [(x (... ...) 8) (and (f x (... ...)) ...)]
+      [xs (and (apply f xs) ...)]
+      #:keyword
+      [(keys vals . args)
+       (and (keyword-apply f keys vals args) ...)])]
+   [fs
+    (make-intermediate-procedure
+     'conjoined
+     [(x ... 8) (andmap (lambda (f) (f x ...)) fs)]
+     [xs (andmap (lambda (f) (apply f xs)) fs)]
+     #:keyword
+     [(keys vals . args)
+      (andmap (lambda (f) (keyword-apply f keys vals args)) fs)])]))
+
+(define disjoin
+  (case-lambda*
+   [(f ... 8)
+    (make-intermediate-procedure
+     'disjoined
+      [(x (... ...) 8) (or (f x (... ...)) ...)]
+      [xs (or (apply f xs) ...)]
+      #:keyword
+      [(keys vals . args)
+       (or (keyword-apply f keys vals args) ...)])]
+   [fs
+    (make-intermediate-procedure
+     'disjoined
+     [(x ... 8) (ormap (lambda (f) (f x ...)) fs)]
+     [xs (ormap (lambda (f) (apply f xs)) fs)]
+     #:keyword
+     [(keys vals . args)
+      (ormap (lambda (f) (keyword-apply f keys vals args)) fs)])]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Function Invocation (partial or indirect)
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax-rule (cons2 one two rest)
+  (let*-values ([(ones twos) rest])
+    (values (cons one ones) (cons two twos))))
+
+(define merge-keywords
+  (match-lambda*
+    [(or (list _ '() '() keys vals)
+         (list _ keys vals '() '()))
+     (values keys vals)]
+    [(list name
+           (and keys1* (cons key1 keys1)) (and vals1* (cons val1 vals1))
+           (and keys2* (cons key2 keys2)) (and vals2* (cons val2 vals2)))
+     (cond
+      [(keyword<? key1 key2)
+       (cons2 key1 val1 (merge-keywords name keys1 vals1 keys2* vals2*))]
+      [(keyword<? key2 key1)
+       (cons2 key2 val2 (merge-keywords name keys1* vals1* keys2 vals2))]
+      [else
+       (error name
+              "duplicate values for ~s: ~s and ~s"
+              key1 val1 val2)])]))
+
+(define curryn
+  (make-intermediate-procedure
+   'curryn
+   [(n f x ... 8)
+    (if (<= n 0)
+        (f x ...)
+        (make-intermediate-procedure
+         'curried
+         [(y (... ...) 8) (curryn (sub1 n) f x ... y (... ...))]
+         [ys (curryn (sub1 n) f x ... ys)]
+         #:keyword
+         [(ks vs . ys)
+          (keyword-apply curryn ks vs (sub1 n) f x ... ys)]))]
+   [(n f . xs)
+    (if (<= n 0)
+        (apply f xs)
+        (make-intermediate-procedure
+         'curried
+         [ys (apply curryn (sub1 n) f (append xs ys))]
+         #:keyword
+         [(ks vs . ys)
+          (keyword-apply curryn ks vs (sub1 n) f (append xs ys))]))]
+   #:keyword
+   [(ks vs n f . xs)
+    (if (<= n 0)
+        (keyword-apply f ks vs xs)
+        (make-intermediate-procedure
+         'curried
+         [ys (keyword-apply curryn ks vs (sub1 n) f (append xs ys))]
+         #:keyword
+         [(ks* vs* . ys)
+          (let*-values ([(keys vals) (merge-keywords 'curryn ks vs ks* vs*)])
+            (keyword-apply curryn keys vals (sub1 n) f (append xs ys)))]))]))
+
+(define currynr
+  (make-intermediate-procedure
+   'currynr
+   [(n f x ... 8)
+    (if (<= n 0)
+        (f x ...)
+        (make-intermediate-procedure
+         'curried
+         [(y (... ...) 8) (currynr (sub1 n) f y (... ...) x ...)]
+         [ys (currynr (sub1 n) f (append ys (list x ...)))]
+         #:keyword
+         [(ks vs . ys)
+          (keyword-apply currynr ks vs (sub1 n) f (append ys (list x ...)))]))]
+   [(n f . xs)
+    (if (<= n 0)
+        (apply f xs)
+        (make-intermediate-procedure
+         'curried
+         [ys (apply currynr (sub1 n) f (append ys xs))]
+         #:keyword
+         [(ks vs . ys)
+          (keyword-apply currynr ks vs (sub1 n) f (append ys xs))]))]
+   #:keyword
+   [(ks vs n f . xs)
+    (if (<= n 0)
+        (keyword-apply f ks vs xs)
+        (make-intermediate-procedure
+         'curried
+         [ys (keyword-apply currynr ks vs (sub1 n) f (append ys xs))]
+         #:keyword
+         [(ks* vs* . ys)
+          (let*-values ([(keys vals) (merge-keywords 'currynr ks vs ks* vs*)])
+            (keyword-apply currynr keys vals (sub1 n) f (append ys xs)))]))]))
+
+(define papply
+  (make-intermediate-procedure
+   'papply
+   [(f x ... 8)
+    (make-intermediate-procedure
+     'partially-applied
+     [(y (... ...) 8) (f x ... y (... ...))]
+     [ys (apply f x ... ys)]
+     #:keyword
+     [(ks vs . ys) (keyword-apply f ks vs x ... ys)])]
+   [(f . xs)
+    (make-intermediate-procedure
+     'partially-applied
+     [ys (apply f (append xs ys))]
+     #:keyword
+     [(ks vs . ys) (keyword-apply f ks vs (append xs ys))])]
+   #:keyword
+   [(ks vs f . xs)
+    (make-intermediate-procedure
+     'partially-applied
+     [ys (keyword-apply f ks vs (append xs ys))]
+     #:keyword
+     [(ks* vs* . ys)
+      (let*-values ([(keys vals) (merge-keywords 'papply ks vs ks* vs*)])
+        (keyword-apply f keys vals (append xs ys)))])]))
+
+(define papplyr
+  (make-intermediate-procedure
+   'papplyr
+   [(f x ... 8)
+    (make-intermediate-procedure
+     'partially-applied
+     [(y (... ...) 8) (f y (... ...) x ...)]
+     [ys (apply f (append ys (list x ...)))]
+     #:keyword
+     [(ks vs . ys) (keyword-apply f ks vs (append ys (list x ...)))])]
+   [(f . xs)
+    (make-intermediate-procedure
+     'partially-applied
+     [ys (apply f (append ys xs))]
+     #:keyword
+     [(ks vs . ys) (keyword-apply f ks vs (append ys xs))])]
+   #:keyword
+   [(ks vs f . xs)
+    (make-intermediate-procedure
+     'partially-applied
+     [ys (keyword-apply f ks vs (append ys xs))]
+     #:keyword
+     [(ks* vs* . ys)
+      (let*-values ([(keys vals) (merge-keywords 'papplyr ks vs ks* vs*)])
+        (keyword-apply f keys vals (append ys xs)))])]))
+
+(define call
+  (make-intermediate-procedure
+   'call
+   [(f x ... 8) (f x ...)]
+   [(f . xs) (apply f xs)]
+   #:keyword
+   [(ks vs f . xs) (keyword-apply f ks vs xs)]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Eta expansion
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax eta*
+  (syntax-rules ()
+    [(_ f arg ...) (lambda (arg ...) (f arg ...))]
+    [(_ f arg ... . rest) (lambda (arg ... . rest) (apply f arg ... rest))]))
+
+(define-syntax-rule (eta f) (make-eta-expansion (lambda () f)))
+
+(define (make-eta-expansion f*)
+  (make-intermediate-procedure
+   'eta
+   [(x ... 8) ((f*) x ...)]
+   [xs (apply (f*) xs)]
+   #:keyword
+   [(ks vs . xs) (keyword-apply (f*) ks vs xs)]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parameter arguments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-for-syntax (strip-param orig p-arg)
+  (syntax-case p-arg ()
+    [(id #:param param)
+     (values (syntax/loc p-arg (id (param)))
+             (syntax/loc p-arg [param id]))]
+    [_ (values p-arg #f)]))
+
+(define-for-syntax (strip-params orig p-args)
+  (syntax-case p-args ()
+    [(key p-arg . rest)
+     (keyword? #'key)
+     (let*-values ([(arg param) (strip-param orig #'p-arg)]
+                   [(args params) (strip-params orig #'rest)])
+       (values (cons #'key (cons arg args))
+               (if param (cons param params) params)))]
+    [(p-arg . rest)
+     (let*-values ([(arg param) (strip-param orig #'p-arg)]
+                   [(args params) (strip-params orig #'rest)])
+       (values (cons arg args)
+               (if param (cons param params) params)))]
+    [_ (values p-args null)]))
+
+(define-syntax (lambda/parameter stx)
+  (syntax-case stx ()
+    [(_ p-args . body)
+     (let*-values ([(args params) (strip-params stx #'p-args)])
+       (quasisyntax/loc stx
+         (lambda #,args (parameterize #,params . body))))]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Exports
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide
+ ;; functions
+ identity
+ thunk const
+ negate conjoin disjoin
+ curryn currynr papply papplyr call
+ ;; macros
+ eta eta*
+ lambda/parameter)

collects/unstable/cce/gui.ss

@@ -0,0 +1,92 @@
+#lang scheme/gui
+
+(provide
+ locked-text-field-mixin
+ locked-text-field%
+ locked-combo-field%
+ union-container-mixin
+ union-pane%
+ union-panel%)
+
+;; ======================================================================
+;;
+;;  LOCKED TEXT FIELD CLASS / MIXIN
+;;
+;; ======================================================================
+
+(define locked-text-field-mixin
+  (mixin [(class->interface text-field%)] []
+
+    (inherit get-editor)
+
+    (define/override (set-value str)
+      (send (get-editor) lock #f)
+      (super set-value str)
+      (send (get-editor) lock #t))
+
+    (super-new)
+
+    (init [undo-history 0])
+
+    (send (get-editor) lock #t)
+    (send (get-editor) set-max-undo-history undo-history)))
+
+(define locked-text-field%
+  (locked-text-field-mixin text-field%))
+
+(define locked-combo-field%
+  (locked-text-field-mixin combo-field%))
+
+
+;; ======================================================================
+;;
+;;  UNION PANEL CLASS / MIXIN
+;;
+;; ======================================================================
+
+(define union-container-mixin
+  (mixin [area-container<%>] []
+
+    (super-new)
+
+    (inherit get-children get-alignment)
+
+    (define/public (choose child)
+      (for ([child* (get-children)])
+        (send child* show (eq? child* child))))
+
+    (define/override (container-size info)
+      (match info
+        [(list (list w h _ _) ...)
+         (values (apply max 0 w)
+                 (apply max 0 h))]))
+
+    (define/override (place-children info w0 h0)
+      (let*-values ([(ha va) (get-alignment)]
+                    [(hp) (horiz->place ha)]
+                    [(vp) (vert->place va)])
+        (map (lambda (child) (place-child hp vp w0 h0 child)) info)))
+
+    (define/private (place-child hp vp w0 h0 child)
+      (match child
+        [(list cw ch sw sh)
+         (let*-values ([(x w) (place-dim hp w0 cw sw)]
+                       [(y h) (place-dim vp h0 ch sh)])
+           (list x y w h))]))
+
+    (define/private (place-dim p maximum minimum stretch?)
+      (match (list p stretch?)
+        [(list _ #t) (values 0 maximum)]
+        [(list 'min #f) (values 0 minimum)]
+        [(list 'mid #f) (values (floor (/ (- maximum minimum) 2)) minimum)]
+        [(list 'max #f) (values (- maximum minimum) minimum)]))
+
+    (define/private horiz->place
+      (match-lambda ['left 'min] ['center 'mid] ['right 'max]))
+
+    (define/private vert->place
+      (match-lambda ['top 'min] ['center 'mid] ['bottom 'max]))))
+
+(define union-pane% (union-container-mixin pane%))
+(define union-panel% (union-container-mixin panel%))
+

collects/unstable/cce/hash.ss

@@ -0,0 +1,136 @@
+#lang scheme
+
+(require "define.ss" (for-syntax syntax/parse))
+
+(define-if-unbound (hash-has-key? table key)
+  (let/ec return
+    (hash-ref table key (lambda () (return #f)))
+    #t))
+
+(define-if-unbound (hash-equal? table)
+  (and (hash? table)
+       (not (hash-eq? table))
+       (not (hash-eqv? table))))
+
+(define (hash-ref/check table key)
+  (hash-ref table key))
+
+(define (hash-ref/identity table key)
+  (hash-ref table key (lambda () key)))
+
+(define (hash-ref/default table key default)
+  (hash-ref table key (lambda () default)))
+
+(define (hash-ref/failure table key failure)
+  (hash-ref table key (lambda () (failure))))
+
+(define (hash-domain table)
+  (for/list ([i (in-hash-keys table)]) i))
+
+(define (hash-range table)
+  (for/list ([i (in-hash-values table)]) i))
+
+(define ((hash-duplicate-error name) key value1 value2)
+  (error name "duplicate values for key ~e: ~e and ~e" key value1 value2))
+
+(define (hash-union
+         #:combine [combine #f]
+         #:combine/key [combine/key
+                        (if combine
+                          (lambda (k x y) (combine x y))
+                          (hash-duplicate-error 'hash-union))]
+         one . rest)
+  (for*/fold ([one one]) ([two (in-list rest)] [(k v) (in-hash two)])
+    (hash-set one k (if (hash-has-key? one k)
+                        (combine/key k (hash-ref one k) v)
+                        v))))
+
+(define (hash-union!
+         #:combine [combine #f]
+         #:combine/key [combine/key
+                        (if combine
+                          (lambda (k x y) (combine x y))
+                          (hash-duplicate-error 'hash-union))]
+         one . rest)
+  (for* ([two (in-list rest)] [(k v) (in-hash two)])
+    (hash-set! one k (if (hash-has-key? one k)
+                         (combine/key k (hash-ref one k) v)
+                         v))))
+
+(define-syntaxes [ hash hash! ]
+  (let ()
+
+    (define-syntax-class key/value
+      #:attributes [key value]
+      (pattern [key:expr value:expr]))
+
+    (define-splicing-syntax-class immutable-hash-type
+      #:attributes [constructor]
+      (pattern (~seq #:eqv) #:attr constructor #'make-immutable-hasheqv)
+      (pattern (~seq #:eq) #:attr constructor #'make-immutable-hasheq)
+      (pattern (~seq (~optional #:equal))
+               #:attr constructor #'make-immutable-hash))
+
+    (define-splicing-syntax-class mutable-hash-type
+      #:attributes [constructor]
+      (pattern (~seq #:base constructor:expr))
+      (pattern (~seq (~or (~once #:eqv) (~once #:weak)) ...)
+               #:attr constructor #'(make-weak-hasheqv))
+      (pattern (~seq (~or (~once #:eq) (~once #:weak)) ...)
+               #:attr constructor #'(make-weak-hasheq))
+      (pattern (~seq (~or (~optional #:equal) (~once #:weak)) ...)
+               #:attr constructor #'(make-weak-hash))
+      (pattern (~seq #:eqv) #:attr constructor #'(make-hasheqv))
+      (pattern (~seq #:eq) #:attr constructor #'(make-hasheq))
+      (pattern (~seq (~optional #:equal)) #:attr constructor #'(make-hash)))
+
+    (define (parse-hash stx)
+      (syntax-parse stx
+        [(_ (~seq type:immutable-hash-type) elem:key/value ...)
+         (syntax/loc stx
+           (type.constructor (list (cons elem.key elem.value) ...)))]
+        [(_ #:base h:expr elem:key/value ...)
+         (syntax/loc stx
+           (for/fold
+               ([table h])
+               ([key (in-list (list elem.key ...))]
+                [value (in-list (list elem.value ...))])
+             (hash-set table key value)))]))
+
+    (define (parse-hash! stx)
+      (syntax-parse stx
+        [(_ (~seq type:mutable-hash-type) elem:key/value ...)
+         (syntax/loc stx
+           (let ([table type.constructor])
+             (for ([key (in-list (list elem.key ...))]
+                   [value (in-list (list elem.value ...))])
+               (hash-set! table key value))
+             table))]))
+
+    (values parse-hash parse-hash!)))
+
+(provide hash hash! hash-has-key? hash-equal?)
+(provide/contract
+ [hash-ref/identity (-> hash? any/c any/c)]
+ [hash-ref/default (-> hash? any/c any/c any/c)]
+ [hash-ref/failure (-> hash? any/c (-> any/c) any/c)]
+ [hash-ref/check
+  (->d ([table hash?] [key any/c]) ()
+       #:pre-cond (hash-has-key? table key)
+       [_ any/c])]
+ [hash-domain (-> hash? list?)]
+ [hash-range (-> hash? list?)]
+ [hash-union (->* [(and/c hash? immutable?)]
+                  [#:combine
+                   (-> any/c any/c any/c)
+                   #:combine/key
+                   (-> any/c any/c any/c any/c)]
+                  #:rest (listof hash?)
+                  (and/c hash? immutable?))]
+ [hash-union! (->* [(and/c hash? (not/c immutable?))]
+                   [#:combine
+                   (-> any/c any/c any/c)
+                   #:combine/key
+                   (-> any/c any/c any/c any/c)]
+                   #:rest (listof hash?)
+                   void?)])

collects/unstable/cce/info.ss

@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define name "Carl Eastlund's Scheme Utilities")

collects/unstable/cce/match.ss

@@ -0,0 +1,127 @@
+#lang scheme
+(require
+ (for-syntax scheme/match
+             scheme/struct-info
+             "define.ss"
+             "function.ss"
+             "syntax.ss"))
+
+(define-syntax-rule (match? e p ...)
+  (match e [p #t] ... [_ #f]))
+
+(define-syntax (define-struct-pattern stx)
+  (parameterize ([current-syntax stx])
+    (syntax-case stx ()
+      [(_ pattern-name struct-name)
+       (block
+
+        (define pattern-id #'pattern-name)
+        (define struct-id #'struct-name)
+
+        (unless (identifier? pattern-id)
+          (syntax-error pattern-id "expected an identifier"))
+
+        (unless (identifier? struct-id)
+          (syntax-error struct-id "expected an identifier"))
+
+        (define struct-info (syntax-local-value struct-id))
+
+        (unless (struct-info? struct-info)
+          (syntax-error struct-id "expected a struct name"))
+
+        (match (extract-struct-info struct-info)
+          [(list type-id
+                 constructor-id
+                 predicate-id
+                 accessor-ids
+                 mutator-ids
+                 super-id)
+           (with-syntax ([make constructor-id]
+                         [(p ...) (generate-temporaries accessor-ids)])
+             (syntax/loc stx
+               (define-match-expander pattern-name
+                 (syntax-rules ()
+                   [(_ p ...) (struct struct-name [p ...])])
+                 (redirect-transformer #'make))))]))])))
+
+(define-for-syntax (get-struct-info id)
+  (block
+
+   (define (fail)
+     (syntax-error id "expected a structure name"))
+
+   (define value
+     (syntax-local-value id fail))
+
+   (unless (struct-info? value) (fail))
+
+   (extract-struct-info value)))
+
+(define-for-syntax (struct-match-expander stx)
+  (parameterize ([current-syntax stx])
+    (syntax-case stx ()
+      [(_ s f ...)
+       (match (get-struct-info #'s)
+         [(list _
+                _
+                (? identifier? pred)
+                (list-rest (? identifier? rev-gets) ... (or (list) (list #f)))
+                _
+                _)
+          (let* ([n-patterns (length (syntax-list f ...))]
+                 [n-fields (length rev-gets)])
+            (unless (= n-patterns n-fields)
+              (syntax-error #'s
+                            "got ~a patterns for ~a fields of ~a"
+                            n-patterns n-fields (syntax-e #'s))))
+          (with-syntax ([pred? pred]
+                        [(get ...) (reverse rev-gets)])
+            (syntax/loc stx
+              (and (? pred?) (app get f) ...)))]
+         [_
+          (syntax-error
+           #'s
+           "expected a structure name with predicate and ~a fields; got ~a"
+           (length (syntax-list f ...))
+           (syntax-e #'s))])])))
+
+(define-for-syntax (struct-make-expander stx)
+  (parameterize ([current-syntax stx])
+    (syntax-case stx ()
+      [(_ s f ...)
+       (match (get-struct-info #'s)
+         [(list _
+                (? identifier? make)
+                _
+                rev-gets
+                _
+                _)
+          (match rev-gets
+            [(list (? identifier?) ...)
+             (let* ([n-fields (length rev-gets)]
+                    [n-exprs (length (syntax-list f ...))])
+               (unless (= n-exprs n-fields)
+                 (syntax-error
+                  #'s
+                  "got ~a arguments for ~a fields in structure ~a"
+                  n-exprs n-fields (syntax-e #'s))))]
+            [_ (void)])
+          (with-syntax ([mk make])
+            (syntax/loc stx
+              (mk f ...)))]
+         [_
+          (syntax-error
+           #'s
+           "expected a structure name with constructor; got ~a"
+           (syntax-e #'s))])])))
+
+(define-match-expander $
+  ;; define-match-expander is STUPIDLY non-uniform about variable expressions
+  (identity struct-match-expander)
+  (identity struct-make-expander))
+
+(define-match-expander as
+  (syntax-rules ()
+    [(as ([x e] ...) p ...) (and (app (lambda (y) e) x) ... p ...)]))
+
+(provide match? define-struct-pattern $ as)

collects/unstable/cce/planet.ss

@@ -0,0 +1,26 @@
+#lang scheme
+
+(require (for-syntax "syntax.ss")
+         "syntax.ss"
+         "require-provide.ss")
+
+(define-syntax (this-package-version-symbol stx)
+  (syntax-case stx ()
+    [(tpvi)
+     (quasisyntax/loc stx
+       '#,(syntax-source-planet-package-symbol stx #f))]
+    [(tpvi name)
+     (identifier? #'name)
+     (quasisyntax/loc stx
+       '#,(syntax-source-planet-package-symbol stx #'name))]))
+
+(provide this-package-version-symbol
+         this-package-in
+         define-planet-package
+         make-planet-path
+         syntax-source-planet-package
+         syntax-source-planet-package-owner
+         syntax-source-planet-package-name
+         syntax-source-planet-package-major
+         syntax-source-planet-package-minor
+         syntax-source-planet-package-symbol)

collects/unstable/cce/port.ss

@@ -0,0 +1,56 @@
+#lang scheme
+
+(require "function.ss" "syntax.ss" "private/define-core.ss")
+
+(define-if-unbound (eprintf fmt . args)
+  (apply fprintf (current-error-port) fmt args))
+
+(define buffer (make-bytes 1024))
+
+(define (read-available-bytes [port (current-input-port)])
+  (read-available-bytes/offset port 0))
+
+(define (read-available-bytes/offset port offset)
+  (let* ([result (read-bytes-avail!* buffer port offset)])
+    (if (eof-object? result)
+        (if (zero? offset) result (subbytes buffer 0 offset))
+        (let* ([new-offset (+ offset result)])
+          (if (= new-offset (bytes-length buffer))
+              (begin (set! buffer (bytes-append buffer buffer))
+                     (read-available-bytes/offset port new-offset))
+              (subbytes buffer 0 new-offset))))))
+
+(define (port->srcloc port [source (object-name port)] [span 0])
+  (let*-values ([(line col pos) (port-next-location port)])
+    (make-srcloc source line col pos span)))
+
+(define read-all
+  (case-lambda
+    [() (read-all read)]
+    [(reader)
+     (let loop ()
+       (match (reader)
+         [(? eof-object?) null]
+         [term (cons term (loop))]))]
+    [(reader port)
+     (parameterize ([current-input-port port])
+       (read-all reader))]))
+
+(define read-all-syntax
+  (case-lambda
+    [() (read-all-syntax read-syntax)]
+    [(reader) (read-all-syntax reader (current-input-port))]
+    [(reader port)
+     (define start (port->srcloc port))
+     (define terms (read-all reader port))
+     (define end (port->srcloc port))
+     (to-syntax #:src (src->list start end) terms)]))
+
+(provide eprintf)
+(provide/contract
+ [read-all (->* [] [(-> any/c) input-port?] list?)]
+ [read-all-syntax
+  (->* [] [(-> (or/c syntax? eof-object?)) input-port?]
+       (syntax/c list?))]
+ [read-available-bytes (->* [] [input-port?] (or/c bytes? eof-object?))]
+ [port->srcloc (->* [port?] [any/c exact-nonnegative-integer?] srcloc?)])

collects/unstable/cce/private/define-core.ss

@@ -0,0 +1,68 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base scheme/list "syntax-core.ss"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Definition Generalization
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide define-single-definition)
+
+(define-syntax-rule (define-single-definition define-one define-many)
+  (define-syntax define-one
+    (syntax-rules []
+      [(_ (head . args) . body) (define-one head (lambda args . body))]
+      [(_ name expr) (define-many [name] expr)])))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Potentially Redundant Bindings
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide define-if-unbound
+         define-values-if-unbound
+         define-syntaxes-if-unbound
+         define-syntax-if-unbound)
+
+(define-syntax (define-many-if-unbound stx)
+  (syntax-case stx []
+    [(_ def [name ...] expr)
+     (let* ([ids (syntax->list #'(name ...))])
+       (for ([bad (in-list ids)] #:when (not (identifier? bad)))
+         (syntax-error bad "expected an identifier"))
+       (let*-values ([(bound unbound) (partition identifier-binding ids)])
+         (cond
+          [(null? bound) (syntax/loc stx (def [name ...] expr))]
+          [(null? unbound) (syntax/loc stx (def [] (values)))]
+          [else (syntax-error
+                 stx
+                 "conflicting definitions for ~s; none for ~s"
+                 (map syntax-e bound)
+                 (map syntax-e unbound))])))]))
+
+(define-syntax-rule (define-values-if-unbound [name ...] expr)
+  (define-many-if-unbound define-values [name ...] expr))
+
+(define-single-definition define-if-unbound define-values-if-unbound)
+
+(define-syntax-rule (define-syntaxes-if-unbound [name ...] expr)
+  (define-many-if-unbound define-syntaxes [name ...] expr))
+
+(define-single-definition define-syntax-if-unbound define-syntaxes-if-unbound)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Trampoline Expansion
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide #%trampoline)
+
+(define-syntax (#%trampoline stx)
+  (syntax-case stx ()
+    [(_ thunk)
+     (procedure? (syntax-e #'thunk))
+     (#%app (syntax-e #'thunk))]))

collects/unstable/cce/private/syntax-core.ss

@@ -0,0 +1,160 @@
+#lang scheme/base
+
+(require scheme/contract
+         scheme/match
+         (only-in unstable/syntax with-syntax*)
+         "../text.ss"
+         (for-syntax scheme/base))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Source Locations
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide src-known? src->srcloc src->list src->vector src->syntax)
+
+(define srcloc->list
+  (match-lambda
+    [(struct srcloc [src line col pos span])
+     (list src line col pos span)]))
+
+(define srcloc->vector
+  (match-lambda
+    [(struct srcloc [src line col pos span])
+     (vector src line col pos span)]))
+
+(define (srcloc->syntax loc [v null])
+  (datum->syntax #f v (srcloc->list loc)))
+
+(define (src->srcloc . locs) (combine-srclocs (map convert-loc locs)))
+
+(define src->list   (compose srcloc->list   src->srcloc))
+(define src->vector (compose srcloc->vector src->srcloc))
+(define src->syntax (compose srcloc->syntax src->srcloc))
+
+(define (src-known? x)
+  (not (equal? (convert-loc x) (convert-loc #f))))
+
+(define convert-loc
+  (match-lambda
+    [(? srcloc? loc) loc]
+    [(or (list   src line col pos span)
+         (vector src line col pos span)
+         (and #f src line col pos span)
+         (and (? syntax?)
+              (app syntax-source   src)
+              (app syntax-line     line)
+              (app syntax-column   col)
+              (app syntax-position pos)
+              (app syntax-span     span)))
+     (make-srcloc src line col pos span)]))
+
+(define combine-srclocs
+  (match-lambda
+    ;; Two locations with matching source
+    [(list (struct srcloc [src line1 col1 pos1 span1])
+           (struct srcloc [src line2 col2 pos2 span2])
+           locs ...)
+     (let* ([line (and line1 line2 (min line1 line2))]
+            [col (and line col1 col2
+                      (cond [(< line1 line2) col1]
+                            [(= line1 line2) (min col1 col2)]
+                            [(> line1 line2) col2]))]
+            [pos (and pos1 pos2 (min pos1 pos2))]
+            [span (and pos span1 span2
+                       (- (max (+ pos1 span1) (+ pos2 span2)) pos))])
+       (combine-srclocs (cons (make-srcloc src line col pos span) locs)))]
+    ;; One location
+    [(list loc) loc]
+    ;; No locations, or mismatched sources
+    [_ (make-srcloc #f #f #f #f #f)]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Syntax Conversions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide syntax-map to-syntax to-datum)
+
+(define (syntax-map f stx)
+  (map f (syntax->list stx)))
+
+(define (to-syntax datum
+                   #:stx [stx #f]
+                   #:src [src stx]
+                   #:ctxt [ctxt stx]
+                   #:prop [prop stx]
+                   #:cert [cert stx])
+  (datum->syntax ctxt
+                 datum
+                 (if (srcloc? src) (srcloc->list src) src)
+                 prop
+                 cert))
+
+(define (to-datum v)
+  (if (syntax? v)
+      (syntax->datum v)
+      v))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Pattern Bindings
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide with-syntax* syntax-list)
+
+(define-syntax-rule (syntax-list template ...)
+  (syntax->list (syntax (template ...))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Syntax Errors
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide current-syntax syntax-error)
+
+(define current-syntax (make-parameter #f))
+
+(define (syntax-error #:name [name #f] stx msg . args)
+  (let* ([cur (current-syntax)]
+         [one (if cur cur stx)]
+         [two (if cur stx #f)]
+         [sym (if name (text->symbol name) #f)]
+         [str (apply format msg args)])
+    (raise-syntax-error sym str one two)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Syntax Contracts
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide syntax-datum/c syntax-listof/c syntax-list/c)
+
+(define (syntax-datum/c datum)
+  (let* ([datum/c (coerce-contract datum datum)])
+    (flat-named-contract (build-compound-type-name 'syntax-datum/c datum/c)
+      (lambda (v)
+        (and (syntax? v)
+             ((flat-contract-predicate datum/c)
+              (syntax->datum v)))))))
+
+(define (syntax-listof/c elem)
+  (let* ([elem/c (coerce-contract elem elem)])
+    (flat-named-contract (build-compound-type-name 'syntax-listof/c elem/c)
+      (lambda (v)
+        (and (syntax? v)
+             ((flat-contract-predicate (listof elem/c))
+              (syntax->list v)))))))
+
+(define (syntax-list/c . elems)
+  (let* ([elem/cs (map (lambda (elem) (coerce-contract elem elem)) elems)])
+    (flat-named-contract (apply build-compound-type-name 'syntax-list/c elem/cs)
+      (lambda (v)
+        (and (syntax? v)
+             ((flat-contract-predicate (apply list/c elem/cs))
+              (syntax->list v)))))))

collects/unstable/cce/queue.ss

@@ -0,0 +1,58 @@
+#lang scheme
+
+;; A Queue is a circularly linked list of queue structures.
+;; The head of the circle is identified by the distinguished head value.
+;; The top of the queue (front of the line) is to the right of the head.
+;; The bottom of the queue (back of the line) is to the left of the head.
+(define-struct queue (value left right) #:mutable)
+
+(define head (gensym 'queue-head))
+
+(define (empty-queue)
+  (let* ([q (make-queue head #f #f)])
+    (set-queue-left! q q)
+    (set-queue-right! q q)
+    q))
+
+(define (queue-head? q)
+  (eq? (queue-value q) head))
+
+(define (head-queue? v)
+  (and (queue? v) (queue-head? v)))
+
+(define (queue-empty? q)
+  (and (queue-head? q) (queue-head? (queue-right q))))
+
+(define (nonempty-queue? v)
+  (and (queue? v)
+       (queue-head? v)
+       (queue? (queue-right v))
+       (not (queue-head? (queue-right v)))))
+
+(define (enqueue! q v)
+  (let* ([bot (queue-left q)]
+         [new (make-queue v bot q)])
+    (set-queue-left! q new)
+    (set-queue-right! bot new)))
+
+(define (dequeue! q)
+  (let* ([old (queue-right q)]
+         [top (queue-right old)])
+    (set-queue-right! q top)
+    (set-queue-left! top q)
+    (queue-value old)))
+
+(define queue/c
+  (flat-named-contract "queue" head-queue?))
+
+(define nonempty-queue/c
+  (flat-named-contract "nonempty-queue" nonempty-queue?))
+
+(provide/contract
+ [queue/c flat-contract?]
+ [nonempty-queue/c flat-contract?]
+ [rename head-queue? queue? (-> any/c boolean?)]
+ [rename empty-queue make-queue (-> queue/c)]
+ [queue-empty? (-> queue/c boolean?)]
+ [enqueue! (-> queue/c any/c void?)]
+ [dequeue! (-> nonempty-queue/c any/c)])

collects/unstable/cce/reference/class.scrbl

@@ -0,0 +1,90 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/class))
+
+@title[#:style 'quiet #:tag "cce-class"]{Classes and Objects}
+
+@defmodule[unstable/cce/class]
+
+This module provides tools for classes, objects, and mixins.
+
+@section{Predicates and Contracts}
+
+@defthing[class-or-interface/c flat-contract?]{
+
+Recognizes classes and interfaces.
+
+}
+
+@defproc[(object-provides/c [spec class-or-interface/c] ...) flat-contract?]{
+
+Recognizes objects which are instances of all the given classes and interfaces.
+
+}
+
+@defproc[(class-provides/c [spec class-or-interface/c] ...) flat-contract?]{
+
+Recognizes classes which are subclasses (not strictly) and implementations,
+respectively, of all the given classes and interfaces.
+
+}
+
+@defform[(mixin-provides/c [super-expr ...] [sub-expr ...])]{
+
+Function contract for a mixin whose argument is the parent class @var[c%]
+matching @scheme[(class-provides/c super-expr ...)] and whose result matches
+@scheme[(class-provides/c #,(var c%) sub-expr ...)].
+
+}
+
+@section{Mixins}
+
+@defproc[(ensure-interface [i<%> interface?]
+                           [mx (mixin-provides/c [] [i<%>])]
+                           [c% class?])
+         (class-provides/c c% i<%>)]{
+
+Returns @scheme[c%] if it implements @scheme[i<%>]; otherwise, returns
+@scheme[(mx c%)].
+
+}
+
+@section{Methods}
+
+@defform[(send+ obj [message arg ...] ...)]{
+
+Sends each message (with arguments) to @scheme[obj], then returns @scheme[obj].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/class)
+(define c%
+  (class object%
+    (super-new)
+    (define/public (say msg) (printf "~a!\n" msg))))
+(send+ (new c%) [say 'Hello] [say 'Good-bye])
+]
+
+}
+
+@defform[(send-each objs message arg ...)]{
+
+Sends the message to each object in the list @scheme[objs], returning
+@scheme[(void)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/class)
+(define c%
+  (class object%
+    (super-new)
+    (init-field msg)
+    (define/public (say to) (printf "~a, ~a!\n" msg to))))
+(send-each
+ (list (new c% [msg 'Hello])
+       (new c% [msg 'Good-bye]))
+ say 'World)
+]
+
+}

collects/unstable/cce/reference/contract.scrbl

@@ -0,0 +1,131 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/contract))
+
+@title[#:style 'quiet #:tag "cce-contract"]{Contracts}
+
+@defmodule[unstable/cce/contract]
+
+This module provides useful contracts and contract constructors.
+
+@section{Flat Contracts}
+
+@defthing[nat/c flat-contract?]{
+
+This contract recognizes natural numbers that satisfy
+@scheme[exact-nonnegative-integer?].
+
+}
+
+@defthing[pos/c flat-contract?]{
+
+This contract recognizes positive integers that satisfy
+@scheme[exact-positive-integer?].
+
+}
+
+@defthing[truth/c flat-contract?]{
+
+This contract recognizes Scheme truth values, i.e., any value, but with a more
+informative name and description.  Use it in negative positions for arguments
+that accept arbitrary truth values that may not be booleans.
+
+}
+
+@section{Higher-Order Contracts}
+
+@deftogether[(
+@defthing[thunk/c contract?]
+@defthing[unary/c contract?]
+@defthing[binary/c contract?]
+)]{
+
+These contracts recognize functions that accept 0, 1, or 2 arguments,
+respectively, and produce a single result.
+
+}
+
+@deftogether[(
+@defthing[predicate/c contract?]
+@defthing[predicate-like/c contract?]
+)]{
+
+These contracts recognize predicates: functions of a single argument that
+produce a boolean result.
+
+The first constrains its output to satisfy @scheme[boolean?].  Use
+@scheme[predicate/c] in positive position for predicates that guarantee a result
+of @scheme[#t] or @scheme[#f].
+
+The second constrains its output to satisfy @scheme[truth/c].  Use
+@scheme[predicate-like/c] in negative position for predicates passed as
+arguments that may return arbitrary values as truth values.
+
+}
+
+@deftogether[(
+@defthing[comparison/c contract?]
+@defthing[comparison-like/c contract?]
+)]{
+
+These contracts recognize comparisons: functions of two arguments that
+produce a boolean result.
+
+The first constrains its output to satisfy @scheme[boolean?].  Use
+@scheme[comparison/c] in positive position for comparisons that guarantee a
+result of @scheme[#t] or @scheme[#f].
+
+The second constrains its output to satisfy @scheme[truth/c].  Use
+@scheme[comparison-like/c] in negative position for comparisons passed as
+arguments that may return arbitrary values as truth values.
+
+}
+
+@defproc[(sequence/c [elem/c contract?] ...) contract?]{
+
+Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{sequence},
+obligating it to produce as many values as there are @scheme[elem/c] contracts,
+and obligating each value to satisfy the corresponding @scheme[elem/c].  The
+result is not guaranteed to be the same kind of sequence as the original value;
+for instance, a wrapped list is not guaranteed to satisfy @scheme[list?].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/contract)
+(define/contract predicates
+  (sequence/c (-> any/c boolean?))
+  (list integer? string->symbol))
+(for ([P predicates])
+  (printf "~s\n" (P "cat")))
+]
+
+}
+
+@defproc[(dict/c [key/c contract?] [value/c contract?]) contract?]{
+
+Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{dictionary},
+obligating its keys to satisfy @scheme[key/c] and their corresponding values to
+satisfy @scheme[value/c].  The result is not guaranteed to be the same kind of
+dictionary as the original value; for instance, a wrapped hash table is not
+guaranteed to satisfy @scheme[hash?].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/contract)
+(define/contract table
+  (dict/c symbol? string?)
+  (make-immutable-hash (list (cons 'A "A") (cons 'B 2) (cons 3 "C"))))
+(dict-ref table 'A)
+(dict-ref table 'B)
+(dict-ref table 3)
+]
+
+@emph{Warning:} Bear in mind that key and value contracts are re-wrapped on
+every dictionary operation, and dictionaries wrapped in @scheme[dict/c] multiple
+times will perform the checks as many times for each operation.  Especially for
+immutable dictionaries (which may be passed through a constructor that involves
+@scheme[dict/c] on each update), contract-wrapped dictionaries may be much less
+efficient than the original dictionaries.
+
+}

collects/unstable/cce/reference/debug.scrbl

@@ -0,0 +1,71 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/debug unstable/syntax))
+
+@title[#:style 'quiet #:tag "cce-debug"]{Debugging}
+
+@defmodule[unstable/cce/debug]
+
+This module provides macros and functions for printing out debugging
+information.
+
+@defform[(debug expr)]{
+
+Logs debugging information before and after the evaluation of expression
+@scheme[expr].
+
+}
+
+@defform/subs[
+(with-debugging options ... expr)
+([options (code:line #:name name-expr)
+          (code:line #:source srcloc-expr)])
+]{
+
+Logs debugging information like @scheme[debug], with the option of explicitly
+overriding the name and source location information for the expression.
+
+}
+
+@defproc[(dprintf [fmt string?] [arg any/c] ...) void?]{
+
+Constructs a message in the same manner as @scheme[format], and logs it at the
+debugging priority (like @scheme[log-debug]).
+
+}
+
+@deftogether[(
+@defform[(begin/debug expr ...)]
+@defform*[[(define/debug id expr)
+           (define/debug (head args) body ...+)]]
+@defform*[[(define/private/debug id expr)
+           (define/private/debug (head args) body ...+)]]
+@defform*[[(define/public/debug id expr)
+           (define/public/debug (head args) body ...+)]]
+@defform*[[(define/override/debug id expr)
+           (define/override/debug (head args) body ...+)]]
+@defform*[[(define/augment/debug id expr)
+           (define/augment/debug (head args) body ...+)]]
+@defform*[[(let/debug ([lhs-id rhs-expr] ...) body ...+)
+           (let/debug loop-id ([lhs-id rhs-expr] ...) body ...+)]]
+@defform[(let*/debug ([lhs-id rhs-expr] ...) body ...+)]
+@defform[(letrec/debug ([lhs-id rhs-expr] ...) body ...+)]
+@defform[(let-values/debug ([(lhs-id ...) rhs-expr] ...) body ...+)]
+@defform[(let*-values/debug ([(lhs-id ...) rhs-expr] ...) body ...+)]
+@defform[(letrec-values/debug ([(lhs-id ...) rhs-expr] ...) body ...+)]
+@defform[(with-syntax/debug ([pattern stx-expr] ...) body ...+)]
+@defform[(with-syntax*/debug ([pattern stx-expr] ...) body ...+)]
+@defform[(parameterize/debug ([param-expr value-expr] ...) body ...+)]
+)]{
+
+These macros add logging based on @scheme[with-debugging] to the evaluation of
+expressions in @scheme[begin], @scheme[define], @scheme[define/private],
+@scheme[define/public], @scheme[define/override], @scheme[define/augment],
+@scheme[let], @scheme[let*], @scheme[letrec], @scheme[let-values],
+@scheme[let*-values], @scheme[letrec-values], @scheme[with-syntax],
+@scheme[with-syntax*], and @scheme[parameterize].
+
+}

collects/unstable/cce/reference/define.scrbl

@@ -0,0 +1,176 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/define))
+
+@title[#:style 'quiet #:tag "cce-define"]{Definitions}
+
+@defmodule[unstable/cce/define]
+
+This module provides macros for creating and manipulating definitions.
+
+@section{Interleaving Definitions and Expressions}
+
+@defform[(block def-or-expr ...)]{
+
+This expression establishes a lexically scoped block (i.e. an internal
+definition context) in which definitions and expressions may be interleaved.
+Its result is that of the last term (after @scheme[begin]-splicing), executed in
+tail position, if the term is an expression; if there are no terms, or the last
+term is a definition, its result is @scheme[(void)].
+
+This form is equivalent to @scheme[(begin-with-definitions def-or-expr ...)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/define)
+(define (intersection list-one list-two)
+  (block
+
+    (define hash-one (make-hash))
+    (for ([x (in-list list-one)])
+      (hash-set! hash-one x #t))
+
+    (define hash-two (make-hash))
+    (for ([x (in-list list-two)])
+      (hash-set! hash-two x #t))
+
+    (for/list ([x (in-hash-keys hash-one)]
+               #:when (hash-has-key? hash-two x))
+      x)))
+
+(intersection (list 1 2 3) (list 2 3 4))
+]
+
+}
+
+@section{Deferred Evaluation in Modules}
+
+@defform[(at-end expr)]{
+
+When used at the top level of a module, evaluates @scheme[expr] at the end of
+the module.  This can be useful for calling functions before their definitions.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/define)
+(module Failure scheme
+  (f 5)
+  (define (f x) x))
+(require 'Failure)
+(module Success scheme
+  (require unstable/cce/define)
+  (at-end (f 5))
+  (define (f x) x))
+(require 'Success)
+]
+
+}
+
+@section{Conditional Binding}
+
+@deftogether[(
+@defform*[[(define-if-unbound x e)
+           (define-if-unbound (f . args) body ...)]]
+@defform[(define-values-if-unbound [x ...] e)]
+@defform*[[(define-syntax-if-unbound x e) 
+           (define-syntax-if-unbound (f . args) body ...)]]
+@defform[(define-syntaxes-if-unbound [x ...] e)]
+)]{
+
+These forms define each @scheme[x] (or @scheme[f]) if no such binding exists, or
+do nothing if the name(s) is(are) already bound.  The
+@scheme[define-values-if-unbound] and @scheme[define-syntaxes-if-unbound] forms
+raise a syntax error if some of the given names are bound and some are not.
+
+These are useful for writing programs that are portable across versions of PLT
+Scheme with different bindings, to provide an implementation of a binding for
+versions that do not have it but use the built-in one in versions that do.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/define)
+(define-if-unbound x 1)
+x
+(define y 2)
+(define-if-unbound y 3)
+y
+]
+
+}
+
+@section{Renaming Definitions}
+
+@defform[(define-renamings [new old] ...)]{
+
+This form establishes a rename transformer for each @scheme[new] identifier,
+redirecting it to the corresponding @scheme[old] identifier.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/define)
+(define-renamings [def define] [lam lambda])
+(def plus (lam (x y) (+ x y)))
+(plus 1 2)
+]
+
+}
+
+@section{Forward Declarations}
+
+@defform[(declare-names x ...)]{
+
+This form provides forward declarations of identifiers to be defined later.  It
+is useful for macros which expand to mutually recursive definitions, including
+forward references, that may be used at the PLT Scheme top level.
+
+}
+
+@section{Definition Shorthands}
+
+@defform[(define-with-parameter name parameter)]{
+
+Defines the form @scheme[name] as a shorthand for setting the parameter
+@scheme[parameter].  Specifically, @scheme[(name value body ...)] is equivalent
+to @scheme[(parameterize ([parameter value]) body ...)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/define)
+(define-with-parameter with-input current-input-port)
+(with-input (open-input-string "Tom Dick Harry") (read))
+]
+
+}
+
+@defform[(define-single-definition define-one-name define-many-name)]{
+
+This form defines a marco @scheme[define-one-name] as a single identifier
+definition form with function shorthand like @scheme[define] and
+@scheme[define-syntax], based on an existing macro @scheme[define-many-name]
+which works like @scheme[define-values] or @scheme[define-syntaxes].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/define)
+(define-single-definition define-like define-values)
+(define-like x 0)
+x
+(define-like (f a b c) (printf "~s, ~s\n" a b) c)
+(f 1 2 3)
+]
+
+}
+
+@section{Effectful Transformation}
+
+@defform[(in-phase1 e)]{
+
+This form executes @scheme[e] during phase 1 (the syntax transformation phase)
+relative to its context, during pass 1 if it occurs in a head expansion
+position.
+
+}
+
+@defform[(in-phase1/pass2 e)]{
+
+This form executes @scheme[e] during phase 1 (the syntax transformation phase)
+relative to its context, during pass 2 (after head expansion).
+
+}

collects/unstable/cce/reference/dict.scrbl

@@ -0,0 +1,300 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/dict))
+
+@title[#:style 'quiet #:tag "cce-dict"]{Dictionaries}
+
+@defmodule[unstable/cce/dict]
+
+This module provides tools for manipulating dictionary values.
+
+@section{Dictionary Constructors}
+
+@defproc[(empty-dict [#:mutable? mutable? boolean? weak?]
+                     [#:weak? weak? boolean? #f]
+                     [#:compare compare (or/c 'eq 'eqv 'equal) equal])
+         hash?]{
+
+Constructs an empty hash table based on the behavior specified by
+@scheme[mutable?], @scheme[weak?], and @scheme[compare].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(empty-dict)
+(empty-dict #:mutable? #t)
+(empty-dict #:weak? #t)
+(empty-dict #:compare 'eqv)
+]
+
+}
+
+@defproc[(make-dict [d dict?]
+                    [#:mutable? mutable? boolean? weak?]
+                    [#:weak? weak? boolean? #f]
+                    [#:compare compare (or/c 'eq 'eqv 'equal) equal])
+         hash?]{
+
+Converts a given dictionary @scheme[d] to a hash table based on the behavior
+specified by @scheme[mutable?], @scheme[weak?], and @scheme[compare].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(make-dict '([1 . one] [2 . two]))
+(make-dict '([1 . one] [2 . two]) #:mutable? #t)
+(make-dict '([1 . one] [2 . two]) #:weak? #t)
+(make-dict '([1 . one] [2 . two]) #:compare 'eqv)
+]
+
+}
+
+@defproc[(custom-dict [equiv? (-> any/c any/c any/c)]
+                      [hash-primary (-> any/c exact-integer?) (lambda (x) 0)]
+                      [hash-secondary (-> any/c exact-integer?) (lambda (x) 0)]
+                      [#:mutable? mutable? boolean? weak?]
+                      [#:weak? weak? boolean? #f])
+         dict?]{
+
+Constructs a dictionary based on custom comparison and optional hash functions.
+Given no hash functions, the dictionary defaults to a degenerate hash function
+and is thus essentially equivalent to a list-based dictionary.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(define table (custom-dict = add1 sub1 #:mutable? #t))
+(dict-set! table 1 'one)
+(dict-set! table 2 'two)
+(for/list ([(key val) (in-dict table)])
+  (cons key val))
+]
+
+}
+
+@section{Dictionary Lookup}
+
+@defproc[(dict-ref! [d (and/c dict? dict-mutable?)]
+                    [k any/c]
+                    [v (or/c (-> any/c) any/c)])
+         any/c]{
+
+Looks up key @scheme[k] in dictionary @scheme[d].  If @scheme[d] has no entry
+for @scheme[k], updates @scheme[d] to map @scheme[k] to the result of
+@scheme[(v)] (if @scheme[v] is a procedure) or @scheme[v] (otherwise), and
+returns the new mapping.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(define d (make-hash))
+(dict-set! d 1 'one)
+(dict-set! d 2 'two)
+d
+(dict-ref! d 2 'dos)
+d
+(dict-ref! d 3 'tres)
+d
+(dict-ref! d 4 gensym)
+d
+]
+
+}
+
+@defproc[(dict-ref/check [d dict?] [k (lambda (k) (dict-has-key? d k))])
+         any/c]{
+
+Looks up key @scheme[k] in dictionary @scheme[d].  Raises a contract error if
+@scheme[d] has no entry for @scheme[k].  Equivalent to @scheme[(dict-ref d k)],
+except for the specific exception value raised.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-ref/check '([1 . one] [2 . two] [3 . three]) 2)
+]
+
+}
+
+@defproc[(dict-ref/identity [d dict?] [k any/c]) any/c]{
+
+Looks up key @scheme[k] in dictionary @scheme[d].  Returns @scheme[k] if
+@scheme[d] has no entry for @scheme[k].  Equivalent to
+@scheme[(dict-ref d k (lambda () k))].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-ref/identity '([1 . one] [2 . two] [3 . three]) 2)
+(dict-ref/identity '([1 . one] [2 . two] [3 . three]) 4)
+]
+
+}
+
+@defproc[(dict-ref/default [d dict?] [k any/c] [v any/c]) any/c]{
+
+Looks up key @scheme[k] in dictionary @scheme[d].  Returns @scheme[v] if
+@scheme[d] has no entry for @scheme[k].  Equivalent to
+@scheme[(dict-ref d k (lambda () v))].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-ref/default '([1 . one] [2 . two] [3 . three]) 2 'other)
+(dict-ref/default '([1 . one] [2 . two] [3 . three]) 4 'other)
+]
+
+}
+
+@defproc[(dict-ref/failure [d dict?] [k any/c] [f (-> any/c)]) any/c]{
+
+Looks up key @scheme[k] in dictionary @scheme[d].  Returns the result of
+applying @scheme[f] (in tail position) if @scheme[d] has no entry for
+@scheme[k].  Equivalent to @scheme[(dict-ref d k f)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-ref/failure '([1 . one] [2 . two] [3 . three]) 2 gensym)
+(dict-ref/failure '([1 . one] [2 . two] [3 . three]) 4 gensym)
+]
+
+}
+
+@section{Dictionary Accessors}
+
+@defproc[(dict-empty? [d dict?]) boolean?]{
+
+Reports whether @scheme[d] is empty (has no keys).
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-empty? '())
+(dict-empty? '([1 . one] [2 . two]))
+]
+
+}
+
+@defproc[(dict-has-key? [d dict?] [k any/c]) boolean?]{
+
+Reports whether @scheme[d] has an entry for @scheme[k].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-has-key? '([1 . one] [2 . two] [3 . three]) 2)
+(dict-has-key? '([1 . one] [2 . two] [3 . three]) 4)
+]
+
+}
+
+@defproc[(dict-domain [d dict?]) list?]{
+
+Produces the domain of a dictionary as a list of keys.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-domain '([1 . one] [2 . two] [3 . three]))
+]
+
+}
+
+@defproc[(dict-range [d dict?]) list?]{
+
+Produces the range of a dictionary as a list of values.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-range '([1 . one] [2 . two] [3 . three]))
+]
+
+}
+
+@section{Dictionary Combinations}
+
+@defproc[(dict-union [d0 (and/c dict? dict-can-functional-set?)]
+                     [d dict?] ...
+                     [#:combine combine
+                                (-> any/c any/c any/c)
+                                (lambda _ (error 'dict-union ...))]
+                     [#:combine/key combine/key
+                                    (-> any/c any/c any/c any/c)
+                                    (lambda (k a b) (combine a b))])
+         (and/c dict? dict-can-functional-set?)]{
+
+Computes the union of @scheme[d0] with each dictionary @scheme[d] by functional
+update, adding each element of each @scheme[d] to @scheme[d0] in turn.  For each
+key @scheme[k] and value @scheme[v], if a mapping from @scheme[k] to some value
+@scheme[v0] already exists, it is replaced with a mapping from @scheme[k] to
+@scheme[(combine/key k v0 v)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(dict-union '([1 . one]) '([2 . two]) '([3 . three]))
+(dict-union '([1 . (one uno)] [2 . (two dos)])
+            '([1 . (ein une)] [2 . (zwei deux)])
+            #:combine/key (lambda (k v1 v2) (append v1 v2)))
+]
+
+}
+
+@defproc[(dict-union! [d0 (and/c dict? dict-mutable?)]
+                      [d dict?] ...
+                      [#:combine combine
+                                 (-> any/c any/c any/c)
+                                 (lambda _ (error 'dict-union! ...))]
+                      [#:combine/key combine/key
+                                     (-> any/c any/c any/c any/c)
+                                     (lambda (k a b) (combine a b))])
+         void?]{
+
+Computes the union of @scheme[d0] with each dictionary @scheme[d] by mutable
+update, adding each element of each @scheme[d] to @scheme[d0] in turn.  For each
+key @scheme[k] and value @scheme[v], if a mapping from @scheme[k] to some value
+@scheme[v0] already exists, it is replaced with a mapping from @scheme[k] to
+@scheme[(combine/key k v0 v)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(define d (make-hash))
+d
+(dict-union! d '([1 . (one uno)] [2 . (two dos)]))
+d
+(dict-union! d
+             '([1 . (ein une)] [2 . (zwei deux)])
+             #:combine/key (lambda (k v1 v2) (append v1 v2)))
+d
+]
+
+}
+
+@section{Dictionary Structure Properties}
+
+@defproc[(wrapped-dict-property
+          [#:unwrap unwrap (-> (and/c dict? pred) dict?)]
+          [#:wrap wrap (-> dict? (and/c dict? pred)) (lambda (x) x)]
+          [#:predicate pred (-> any/c boolean?) (lambda (x) #t)]
+          [#:mutable? mutable? boolean? weak?]
+          [#:weak? mutable? boolean? #f]
+          [#:functional? functional? boolean? #t])
+         vector?]{
+
+Produces a value appropriate for @scheme[prop:dict] for a derived dictionary
+type recognized by @scheme[pred].  Dictionaries constructed from this property
+will extract a nested dictionary using @scheme[unwrap] and will produce a
+wrapped dictionary during functional update using @scheme[wrap].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/dict)
+(define-struct table [dict]
+  #:transparent
+  #:property prop:dict
+  (wrapped-dict-property
+   #:unwrap (lambda (d) (table-dict d))
+   #:wrap (lambda (d) (make-table d))
+   #:predicate (lambda (d) (table? d))))
+(dict? (make-table '([1 . one] [2 . two])))
+(dict-ref (make-table '([1 . one] [2 . two])) 1)
+(dict-set (make-table '([1 . one] [2 . two])) 3 'three)
+]
+
+}
+
+@section{Contracted Dictionaries}
+
+This library re-provides @scheme[dict/c] from
+@schememodname[unstable/cce/contract].

collects/unstable/cce/reference/drscheme.scrbl

@@ -0,0 +1,138 @@
+#lang scribble/doc
+@(require scribble/manual
+          "../scribble.ss"
+          (for-label scheme/gui
+                     drscheme/tool-lib
+                     unstable/cce/drscheme))
+
+@title[#:style 'quiet #:tag "cce-drscheme"]{DrScheme Plugins}
+
+@defmodule[unstable/cce/drscheme]
+
+@defthing[language-level@ unit?]{
+
+This unit imports @scheme[drscheme:tool^] and exports @scheme[language-level^].
+
+}
+
+@defsignature[language-level^ ()]{
+
+@defproc[(make-language-level
+          [name string?]
+          [path module-path?]
+          [mixin (-> class? class?)] ...
+          [#:number number integer? ...]
+          [#:hierarchy hierarchy (listof (cons/c string? integer?)) ...]
+          [#:summary summary string? name]
+          [#:url url (or/c string? #f) #f]
+          [#:reader reader
+                    (->* [] [any/c input-port?] (or/c syntax? eof-object?))
+                    read-syntax])
+         (object-provides/c drscheme:language:language<%>)]{
+
+Constructs a language level as an instance of
+@scheme[drscheme:language:language<%>] with the given @scheme[name] based on the
+language defined by the module at @scheme[path].  Applies
+@scheme[(drscheme:language:get-default-mixin)] and the given @scheme[mixin]s to
+@sigelem[language-level^ simple-language-level%] to construct the class, and
+uses the optional keyword arguments to fill in the language's description and
+reader.
+
+}
+
+@defthing[simple-language-level%
+          (class-provides/c drscheme:language:language<%>
+                            drscheme:language:module-based-language<%>
+                            drscheme:language:simple-module-based-language<%>)]{
+
+Equal to
+@scheme[
+(drscheme:language:module-based-language->language-mixin
+ (drscheme:language:simple-module-based-language->module-based-language-mixin
+  drscheme:language:simple-module-based-language%))].
+
+}
+
+@defproc[(language-level-render-mixin [to-sexp (-> any/c any/c)]
+                                      [show-void? boolean?])
+         (mixin-provides/c [drscheme:language:language<%>] [])]{
+
+Produces a mixin that overrides @method[drscheme:language:language<%>
+render-value/format] to apply @scheme[to-sexp] to each value before printing it,
+and to skip @scheme[void?] values (pre-transformation) if @scheme[show-void?] is
+@scheme[#f].
+
+}
+
+@defproc[(language-level-capability-mixin [dict dict?])
+         (mixin-provides/c [drscheme:language:language<%>] [])]{
+
+Produces a mixin that augments @method[drscheme:language:language<%>
+capability-value] to look up each key in @scheme[dict], producing the
+corresponding value if the key is found and deferring to @scheme[inner]
+otherwise.
+
+}
+
+@defthing[language-level-no-executable-mixin
+          (mixin-provides/c [drscheme:language:language<%>] [])]{
+
+Overrides @method[drscheme:language:language<%> create-executable] to print an
+error message in a dialog box.
+
+}
+
+@defthing[language-level-eval-as-module-mixin
+          (mixin-provides/c [drscheme:language:language<%>
+                             drscheme:language:module-based-language<%>]
+                            [])]{
+
+Overrides @method[drscheme:language:language<%> front-end/complete-program] to
+wrap terms from the definition in a module based on the language level's
+definition module.  This duplicates the behavior of the HtDP teaching languages,
+for instance.
+
+}
+
+@defthing[language-level-macro-stepper-mixin
+          (mixin-provides/c [drscheme:language:language<%>
+                             language/macro-stepper<%>]
+                            [])]{
+
+This mixin enables the macro stepper for its language level.
+
+}
+
+@defthing[language-level-check-expect-mixin
+          (mixin-provides/c [drscheme:language:language<%>] [])]{
+
+This mixin overrides @method[drscheme:language:language<%> on-execute] to set up
+the @scheme[check-expect] test engine to a language level similarly to the HtDP
+teaching languages.
+
+}
+
+@defproc[(language-level-metadata-mixin
+          [reader-module module-path?]
+          [meta-lines exact-nonnegative-integer?]
+          [meta->settings (-> string? any/c any/c)]
+          [settings->meta (-> symbol? any/c string?)])
+         (mixin-provides/c [drscheme:language:language<%>] [])]{
+
+This mixin constructs a language level that stores metadata in saved files
+allowing DrScheme to automatically switch back to this language level upon
+opening them.  It overrides @method[drscheme:language:language<%>
+get-reader-module], @method[drscheme:language:language<%> get-metadata],
+@method[drscheme:language:language<%> metadata->settings], and
+@method[drscheme:language:language<%> get-metadata-lines].
+
+The resulting language level uses the reader from @scheme[reader-module], and is
+recognized in files that start with a reader directive for that module path
+within the first @scheme[meta-lines] lines.  Metadata about the language's
+settings is marshalled between a string and a usable value (based on a default
+value) by @scheme[meta->settings], and between a usable value for a current
+module (with a symbolic name) by @scheme[settings->meta].
+
+}
+
+}

collects/unstable/cce/reference/eval.ss

@@ -0,0 +1,10 @@
+#lang scheme
+
+(require scheme/sandbox unstable/syntax "../sandbox.ss")
+
+(define (evaluator . require-specs)
+  (let* ([ev (make-scribble-evaluator 'scheme)])
+    (ev `(require ,@require-specs))
+    ev))
+
+(provide evaluator)

collects/unstable/cce/reference/exn.scrbl

@@ -0,0 +1,31 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/exn))
+
+@title[#:style 'quiet #:tag "cce-exn"]{Exceptions}
+
+@defmodule[unstable/cce/exn]
+
+This module provides tools for dealing with exceptions.
+
+@defform[(try expr ...+)]{
+
+Executes the first expression @scheme[expr] in the sequence, producing its
+result value(s) if it returns any.  If it raises an exception instead,
+@scheme[try] continues with the next @scheme[expr].  Exceptions raised by
+intermediate expressions are reported to the @tech[#:doc '(lib
+"scribblings/reference/reference.scrbl")]{current logger} at the @scheme['debug]
+level before continuing.  Exceptions raised by the final expression are not
+caught by @scheme[try].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/exn)
+(try (+ 1 2) (+ 3 4))
+(try (+ 'one 'two) (+ 3 4))
+(try (+ 'one 'two) (+ 'three 'four))
+]
+
+}

collects/unstable/cce/reference/function.scrbl

@@ -0,0 +1,289 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/function))
+
+@title[#:style 'quiet #:tag "cce-function"]{Functions}
+
+@defmodule[unstable/cce/function]
+
+This module provides tools for higher-order programming and creating functions.
+
+@section{Simple Functions}
+
+@defproc[(identity [x any/c]) (one-of/c x)]{
+
+Returns @scheme[x].
+
+}
+
+@defform[(thunk body ...)]{
+
+Creates a function that ignores its inputs and evaluates the given body.  Useful
+for creating event handlers with no (or irrelevant) arguments.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define f (thunk (define x 1) (printf "~a\n" x)))
+(f)
+(f 'x)
+(f #:y 'z)
+]
+
+}
+
+@defproc[(const [x any/c]) (unconstrained-domain-> (one-of/c x))]{
+
+Produces a function that returns @scheme[x] regardless of input.
+
+This function is reprovided from @schememodname[scheme/function].  In versions
+of PLT Scheme before @scheme[const] was implemented, this module provides its
+own definition.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define f (const 5))
+(f)
+(f 'x)
+(f #:y 'z)
+]
+
+}
+
+@section{Higher Order Predicates}
+
+@defproc[((negate [f (-> A ... boolean?)]) [x A] ...) boolean?]{
+
+Negates the results of @scheme[f]; equivalent to @scheme[(not (f x ...))].
+
+This function is reprovided from @schememodname[scheme/function].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define f (negate exact-integer?))
+(f 1)
+(f 'one)
+]
+
+}
+
+@defproc[((conjoin [f (-> A ... boolean?)] ...) [x A] ...) boolean?]{
+
+Combines calls to each function with @scheme[and].  Equivalent to
+@scheme[(and (f x ...) ...)]
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define f (conjoin exact? integer?))
+(f 1)
+(f 1.0)
+(f 1/2)
+(f 0.5)
+]
+
+}
+
+@defproc[((disjoin [f (-> A ... boolean?)] ...) [x A] ...) boolean?]{
+
+Combines calls to each function with @scheme[or].  Equivalent to
+@scheme[(or (f x ...) ...)]
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define f (disjoin exact? integer?))
+(f 1)
+(f 1.0)
+(f 1/2)
+(f 0.5)
+]
+
+}
+
+@section{Currying and (Partial) Application}
+
+@defproc[(call [f (-> A ... B)] [x A] ...) B]{
+
+Passes @scheme[x ...] to @scheme[f].  Keyword arguments are allowed.  Equivalent
+to @scheme[(f x ...)].  Useful for application in higher-order contexts.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(map call
+     (list + - * /)
+     (list 1 2 3 4)
+     (list 5 6 7 8))
+(define count 0)
+(define (inc)
+  (set! count (+ count 1)))
+(define (reset)
+  (set! count 0))
+(define (show)
+  (printf "~a\n" count))
+(for-each call (list inc inc show reset show))
+]
+
+}
+
+@deftogether[(
+@defproc[(papply [f (A ... B ... -> C)] [x A] ...) (B ... -> C)]
+@defproc[(papplyr [f (A ... B ... -> C)] [x B] ...) (A ... -> C)]
+)]{
+
+The @scheme[papply] and @scheme[papplyr] functions partially apply @scheme[f] to
+@scheme[x ...], which may include keyword arguments.  They obey the following
+equations:
+
+@schemeblock[
+((papply f x ...) y ...) = (f x ... y ...)
+((papplyr f x ...) y ...) = (f y ... x ...)
+]
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define reciprocal (papply / 1))
+(reciprocal 3)
+(reciprocal 4)
+(define halve (papplyr / 2))
+(halve 3)
+(halve 4)
+]
+
+}
+
+@deftogether[(
+@defproc[(curryn [n exact-nonnegative-integer?]
+                 [f (A0 ... A1 ... ooo An ... -> B)]
+                 [x A0] ...)
+         (A1 ... -> ooo -> An ... -> B)]
+@defproc[(currynr [n exact-nonnegative-integer?]
+                  [f (A1 ... ooo An ... An+1 ... -> B)]
+                  [x An+1] ...)
+         (An ... -> ooo -> A1 ... -> B)]
+)]{
+
+@emph{Note:} The @scheme[ooo] above denotes a loosely associating ellipsis.
+
+The @scheme[curryn] and @scheme[currynr] functions construct a curried version
+of @scheme[f], specialized at @scheme[x ...], that produces a result after
+@scheme[n] further applications.  Arguments at any stage of application may
+include keyword arguments, so long as no keyword is duplicated.  These curried
+functions obey the following equations:
+
+@schemeblock[
+(curryn 0 f x ...) = (f x ...)
+((curryn (+ n 1) f x ...) y ...) = (curryn n f x ... y ...)
+
+(currynr 0 f x ...) = (f x ...)
+((currynr (+ n 1) f x ...) y ...) = (currynr n f y ... x ...)
+]
+
+The @scheme[call], @scheme[papply], and @scheme[papplyr] utilities are related
+to @scheme[curryn] and @scheme[currynr] in the following manner:
+
+@schemeblock[
+(call f x ...) = (curryn 0 f x ...) = (currynr 0 f x ...)
+(papply f x ...) = (curryn 1 f x ...)
+(papplyr f x ...) = (currynr 1 f x ...)
+]
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+
+(define reciprocal (curryn 1 / 1))
+(reciprocal 3)
+(reciprocal 4)
+
+(define subtract-from (curryn 2 -))
+(define from-10 (subtract-from 10))
+(from-10 5)
+(from-10 10)
+(define from-0 (subtract-from 0))
+(from-0 5)
+(from-0 10)
+
+(define halve (currynr 1 / 2))
+(halve 3)
+(halve 4)
+
+(define subtract (currynr 2 -))
+(define minus-10 (subtract 10))
+(minus-10 5)
+(minus-10 10)
+(define minus-0 (subtract 0))
+(minus-0 5)
+(minus-0 10)
+
+]
+
+}
+
+@section{Eta Expansion}
+
+@defform[(eta f)]{
+
+Produces a function equivalent to @scheme[f], except that @scheme[f] is
+evaluated every time it is called.
+
+This is useful for function expressions that may be run, but not called, before
+@scheme[f] is defined.  The @scheme[eta] expression will produce a function
+without evaluating @scheme[f].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define f (eta g))
+f
+(define g (lambda (x) (+ x 1)))
+(f 1)
+]
+
+}
+
+@defform[(eta* f x ...)]{
+
+Produces a function equivalent to @scheme[f], with argument list @scheme[x ...].
+In simple cases, this is equivalent to @scheme[(lambda (x ...) (f x ...))].
+Optional (positional or keyword) arguments are not allowed.
+
+This macro behaves similarly to @scheme[eta], but produces a function with
+statically known arity which may improve efficiency and error reporting.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define f (eta* g x))
+f
+(procedure-arity f)
+(define g (lambda (x) (+ x 1)))
+(f 1)
+]
+
+}
+
+@section{Parameter Arguments}
+
+@defform/subs[
+  (lambda/parameter (param-arg ...) body ...)
+  ([param-arg param-arg-spec (code:line keyword param-spec)]
+   [param-arg-spec id [id default-expr] [id #:param param-expr]])
+]{
+
+Constructs a function much like @scheme[lambda], except that some optional
+arguments correspond to the value of a parameter.  For each clause of the form
+@scheme[[id #:param param-expr]], @scheme[param-expr] must evaluate to a value
+@scheme[param] satisfying @scheme[parameter?].  The default value of the
+argument @scheme[id] is @scheme[(param)]; @scheme[param] is bound to @scheme[id]
+via @scheme[parameterize] during the function call.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/function)
+(define p (open-output-string))
+(define hello-world
+  (lambda/parameter ([port #:param current-output-port])
+    (display "Hello, World!")
+    (newline port)))
+(hello-world p)
+(get-output-string p)
+]
+
+}

collects/unstable/cce/reference/gui.scrbl

@@ -0,0 +1,80 @@
+#lang scribble/doc
+@(require scribble/manual
+          "../scribble.ss"
+          (for-label scheme/gui unstable/cce/gui))
+
+@title[#:style 'quiet #:tag "cce-gui"]{GUI Widgets}
+
+@defmodule[unstable/cce/gui]
+
+@section{Locked Text Fields}
+
+These classes and mixins provide text and combo field controls that cannot be
+directly edited by the user, but may be updated by other controls.
+
+@defmixin[locked-text-field-mixin (text-field%) ()]{
+
+This mixin updates text field classes to prevent user edits, but allow
+programmatic update of the text value.  It also sets the undo history length to
+a default of 0, as user undo commands are disabled and the history takes up
+space.
+
+@defconstructor[([undo-history exact-nonnegative-integer? 0])]{
+
+The mixin adds the @scheme[undo-history] initialization argument to control the
+length of the undo history.  It defaults to 0 to save space, but may be set
+higher.
+
+The mixin inherits all the initialization arguments of its parent class; it does
+not override any of them.
+
+}
+
+@defmethod[#:mode override (set-value [str string?]) void?]{
+
+Unlocks the text field's nested editor, calls the parent class's
+@method[text-field% set-value], and then re-locks the editor.
+
+}
+
+}
+
+@defclass[locked-text-field% text-field% ()]{
+
+Equal to @scheme[(locked-text-field-mixin text-field%)].
+
+}
+
+@defclass[locked-combo-field% combo-field% ()]{
+
+Equal to @scheme[(locked-text-field-mixin combo-field%)].
+
+}
+
+@section{Union GUIs}
+
+@defmixin[union-container-mixin (area-container<%>) ()]{
+
+This mixin modifies a container class to display only one of its child areas at
+a time, but to leave room to switch to any of them.
+
+@defmethod[(choose [child (is-a?/c subwindow<%>)]) void?]{
+
+This method changes which of the container's children is displayed.  The chosen
+child is shown and the previous choice is hidden.
+
+}
+
+}
+
+@defclass[union-pane% pane% ()]{
+
+Equal to @scheme[(union-container-mixin pane%)].
+
+}
+
+@defclass[union-panel% panel% ()]{
+
+Equal to @scheme[(union-container-mixin panel%)].
+
+}

collects/unstable/cce/reference/hash.scrbl

@@ -0,0 +1,223 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/hash))
+
+@title[#:style 'quiet #:tag "cce-hash"]{Hash Tables}
+
+@defmodule[unstable/cce/hash]
+
+This module provides tools for manipulating hash tables.
+
+@section{Hash Table Construction}
+
+@defform/subs[
+(hash immutable-hash-type [key-expr value-expr] ...)
+[(immutable-hash-type code:blank #:eq #:eqv #:equal)]
+]{
+
+Produces an immutable hash table based on the given comparison, defaulting to
+@scheme[#:equal], and mapping the result of each @scheme[key-expr] to the result
+of each @scheme[value-expr].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash ['one 1] ['two 2])
+(hash #:eq ['one 1] ['two 2])
+(hash #:eqv ['one 1] ['two 2])
+(hash #:equal ['one 1] ['two 2])
+]
+
+}
+
+@defform/subs[
+(hash! mutable-hash-spec [key-expr value-expr] ...)
+[(mutable-hash-spec (code:line mutable-hash-type mutable-hash-weak)
+                    (code:line mutable-hash-weak mutable-hash-type))
+ (mutable-hash-type code:blank #:eq #:eqv #:equal)
+ (mutable-hash-weak code:blank #:weak)]
+]{
+
+Produces a mutable hash table based on the given comparison and weakness
+specification, defaulting to @scheme[#:equal] and not @scheme[#:weak], and
+mapping the result of each @scheme[key-expr] to the result of each
+@scheme[value-expr].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash! ['one 1] ['two 2])
+(hash! #:eq ['one 1] ['two 2])
+(hash! #:eqv #:weak ['one 1] ['two 2])
+(hash! #:weak #:equal ['one 1] ['two 2])
+]
+
+}
+
+@section{Hash Table Lookup}
+
+@defproc[(hash-ref/check [h hash?] [k (lambda (k) (hash-has-key? h k))])
+         any/c]{
+
+Looks up key @scheme[k] in hash table @scheme[h].  Raises a contract error if
+@scheme[h] has no entry for @scheme[k].  Equivalent to @scheme[(hash-ref h k)],
+except for the specific exception value raised.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-ref/check (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2)
+]
+
+}
+
+@defproc[(hash-ref/identity [h hash?] [k any/c]) any/c]{
+
+Looks up key @scheme[k] in hash table @scheme[h].  Returns @scheme[k] if
+@scheme[h] has no entry for @scheme[k].  Equivalent to
+@scheme[(hash-ref h k (lambda () k))].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-ref/identity (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2)
+(hash-ref/identity (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 4)
+]
+
+}
+
+@defproc[(hash-ref/default [h hash?] [k any/c] [v any/c]) any/c]{
+
+Looks up key @scheme[k] in hash table @scheme[h].  Returns @scheme[v] if
+@scheme[h] has no entry for @scheme[k].  Equivalent to
+@scheme[(hash-ref h k (lambda () v))].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-ref/default (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2 'other)
+(hash-ref/default (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 4 'other)
+]
+
+}
+
+@defproc[(hash-ref/failure [h hash?] [k any/c] [f (-> any/c)]) any/c]{
+
+Looks up key @scheme[k] in hash table @scheme[h].  Returns the result of
+applying @scheme[f] (in tail position) if @scheme[h] has no entry for
+@scheme[k].  Equivalent to @scheme[(hash-ref h k f)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-ref/failure (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2 gensym)
+(hash-ref/failure (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 4 gensym)
+]
+
+}
+
+@section{Hash Table Accessors}
+
+@defproc[(hash-equal? [h hash?]) boolean?]{
+
+Reports whether @scheme[h] maps keys according to @scheme[equal?].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-equal? #hash())
+(hash-equal? #hasheq())
+(hash-equal? #hasheqv())
+]
+
+}
+
+@defproc[(hash-has-key? [h hash?] [k any/c]) boolean?]{
+
+Reports whether @scheme[h] has an entry for @scheme[k].  This function is
+re-exported from @schememodname[scheme/base].  In versions of PLT Scheme before
+@scheme[hash-has-key?] was implemented, this module provides its own definition.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-has-key? (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2)
+(hash-has-key? (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 4)
+]
+
+}
+
+@defproc[(hash-domain [h hash?]) list?]{
+
+Produces the domain of a hash table as a list of keys.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-domain (make-immutable-hash '([1 . one] [2 . two] [3 . three])))
+]
+
+}
+
+@defproc[(hash-range [h hash?]) list?]{
+
+Produces the range of a hash table as a list of values.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-range (make-immutable-hash '([1 . one] [2 . two] [3 . three])))
+]
+
+}
+
+@section{Hash Table Combinations}
+
+@defproc[(hash-union [h0 (and/c hash? hash-can-functional-set?)]
+                     [h hash?] ...
+                     [#:combine combine
+                                (-> any/c any/c any/c)
+                                (lambda _ (error 'hash-union ...))]
+                     [#:combine/key combine/key
+                                    (-> any/c any/c any/c any/c)
+                                    (lambda (k a b) (combine a b))])
+         (and/c hash? hash-can-functional-set?)]{
+
+Computes the union of @scheme[h0] with each hash table @scheme[h] by functional
+update, adding each element of each @scheme[h] to @scheme[h0] in turn.  For each
+key @scheme[k] and value @scheme[v], if a mapping from @scheme[k] to some value
+@scheme[v0] already exists, it is replaced with a mapping from @scheme[k] to
+@scheme[(combine/key k v0 v)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(hash-union (make-immutable-hash '([1 . one])) (make-immutable-hash '([2 . two])) (make-immutable-hash '([3 . three])))
+(hash-union (make-immutable-hash '([1 . (one uno)] [2 . (two dos)]))
+            (make-immutable-hash '([1 . (ein une)] [2 . (zwei deux)]))
+            #:combine/key (lambda (k v1 v2) (append v1 v2)))
+]
+
+}
+
+@defproc[(hash-union! [h0 (and/c hash? hash-mutable?)]
+                      [h hash?] ...
+                      [#:combine combine
+                                 (-> any/c any/c any/c)
+                                 (lambda _ (error 'hash-union ...))]
+                      [#:combine/key combine/key
+                                     (-> any/c any/c any/c any/c)
+                                     (lambda (k a b) (combine a b))])
+         void?]{
+
+Computes the union of @scheme[h0] with each hash table @scheme[h] by mutable
+update, adding each element of each @scheme[h] to @scheme[h0] in turn.  For each
+key @scheme[k] and value @scheme[v], if a mapping from @scheme[k] to some value
+@scheme[v0] already exists, it is replaced with a mapping from @scheme[k] to
+@scheme[(combine/key k v0 v)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/hash)
+(define h (make-hash))
+h
+(hash-union! h (make-immutable-hash '([1 . (one uno)] [2 . (two dos)])))
+h
+(hash-union! h
+             (make-immutable-hash '([1 . (ein une)] [2 . (zwei deux)]))
+             #:combine/key (lambda (k v1 v2) (append v1 v2)))
+h
+]
+
+}

collects/unstable/cce/reference/manual.scrbl

@@ -0,0 +1,49 @@
+#lang scribble/doc
+@(require scribble/manual
+          "../../scribblings/utils.rkt"
+          "../scribble.ss"
+          (for-label scheme/base))
+
+@title[#:style '(toc)]{@bold{Carl Eastlund's Scheme Utilities}}
+
+@unstable[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
+
+@table-of-contents[]
+
+@include-section["function.scrbl"]
+
+@include-section["values.scrbl"]
+
+@include-section["text.scrbl"]
+@include-section["regexp.scrbl"]
+@include-section["web.scrbl"]
+
+@include-section["set.scrbl"]
+@include-section["dict.scrbl"]
+@include-section["hash.scrbl"]
+@include-section["queue.scrbl"]
+
+@include-section["syntax.scrbl"]
+@include-section["define.scrbl"]
+
+@include-section["match.scrbl"]
+
+@include-section["class.scrbl"]
+
+@include-section["contract.scrbl"]
+
+@include-section["require-provide.scrbl"]
+@include-section["planet.scrbl"]
+
+@include-section["exn.scrbl"]
+
+@include-section["port.scrbl"]
+
+@include-section["debug.scrbl"]
+
+@include-section["sandbox.scrbl"]
+@include-section["scribble.scrbl"]
+
+@include-section["gui.scrbl"]
+@include-section["drscheme.scrbl"]
+@include-section["slideshow.scrbl"]

collects/unstable/cce/reference/match.scrbl

@@ -0,0 +1,81 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/match))
+
+@title[#:style 'quiet #:tag "cce-match"]{Pattern Matching}
+
+@defmodule[unstable/cce/match]
+
+This module provides tools for pattern matching with @scheme[match].
+
+@defform[(match? val-expr pat ...)]{
+
+Returns @scheme[#t] if the result of @scheme[val-expr] matches any of
+@scheme[pat], and returns @scheme[#f] otherwise.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/match)
+(match? (list 1 2 3)
+  (list a b c)
+  (vector x y z))
+(match? (vector 1 2 3)
+  (list a b c)
+  (vector x y z))
+(match? (+ 1 2 3)
+  (list a b c)
+  (vector x y z))
+]
+
+}
+
+@defform[(define-struct-pattern pat-id struct-id)]{
+
+Defines @scheme[pat-id] as a match expander that takes one pattern argument per
+field of the structure described by @scheme[struct-id].  The resulting match
+expander recognizes instances of the structure and matches their fields against
+the corresponding patterns.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/match)
+(define-struct pair [a b] #:transparent)
+(define-struct-pattern both pair)
+(match (make-pair 'left 'right)
+  [(both a b) (list a b)])
+]
+
+}
+
+@defform[(as ([lhs-id rhs-expr] ...) pat ...)]{
+
+As a match expander, binds each @scheme[lhs-id] as a pattern variable with the
+result value of @scheme[rhs-expr], and continues matching each subsequent
+@scheme[pat].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/match)
+(match (list 1 2 3)
+  [(as ([a 0]) (list b c d)) (list a b c d)])
+]
+
+}
+
+@defform*[[($ struct-id expr ...) ($ struct-id pat ...)]]{
+
+As an expression, constructs an instance of the structure described by
+@scheme[struct-id] with fields specified by each @scheme[expr].
+
+As a match expander, matches instances of the structure described by
+@scheme[struct-id] with fields matched by each @scheme[pat].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/match)
+(define-struct pair [a b] #:transparent)
+($ pair 1 2)
+(match ($ pair 1 2)
+  [($ pair a b) (list a b)])
+]
+
+}

collects/unstable/cce/reference/planet.scrbl

@@ -0,0 +1,35 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          scribble/bnf
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme/base scribble/manual unstable/cce/planet))
+
+@title[#:style 'quiet #:tag "cce-planet"]{@|PLaneT| Packages}
+
+@defmodule[unstable/cce/planet]
+
+This module provides tools relating to @|PLaneT| packages.  In addition to the
+binding described below, it provides @scheme[define-planet-package] and
+@scheme[this-package-in] from @schememodname[unstable/cce/require-provide], and
+@scheme[make-planet-path], @scheme[syntax-source-planet-package],
+@scheme[syntax-source-planet-package-owner],
+@scheme[syntax-source-planet-package-name],
+@scheme[syntax-source-planet-package-major],
+@scheme[syntax-source-planet-package-minor], and
+@scheme[syntax-source-planet-package-symbol] from
+@schememodname[unstable/cce/syntax].
+
+@defform*[[
+(this-package-version-symbol)
+(this-package-version-symbol path)
+]]{
+
+Produces a symbol corresponding to a @scheme[planet] module path for the current
+planet package, possibly with a @nonterm{path} (from the grammar of
+@scheme[planet] module specs) into the package.  This is similar to
+@scheme[this-package-version] and similar tools from
+@schememodname[planet/util].
+
+}

collects/unstable/cce/reference/port.scrbl

@@ -0,0 +1,105 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/port))
+
+@title[#:style 'quiet #:tag "cce-port"]{Ports}
+
+@defmodule[unstable/cce/port]
+
+This module provides tools for port I/O.
+
+@defproc[(eprintf [fmt string?] [arg any/c] ...) void?]{
+
+Like @scheme[printf], but prints to @scheme[(current-error-port)].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/port)
+(eprintf "Danger, ~a!" "Will Robinson")
+]
+
+}
+
+@defproc[(read-all [reader (-> any/c) read]
+                   [port input-port? (current-input-port)])
+         list?]{
+
+This function produces a list of all the values produced by calling
+@scheme[(reader)] while @scheme[current-input-port] is set to @scheme[port], up
+until it produces @scheme[eof].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/port)
+(read-all read (open-input-string "1 2 3"))
+(parameterize ([current-input-port (open-input-string "a b c")])
+  (read-all))
+]
+
+}
+
+@defproc[(read-all-syntax [reader (-> (or/c syntax? eof-object?)) read]
+                          [port input-port? (current-input-port)])
+         (syntax/c list?)]{
+
+This function produces a syntax object containing a list of all the syntax
+objects produced by calling @scheme[(reader)] while @scheme[current-input-port]
+is set to @scheme[port], up until it produces @scheme[eof].  The source location
+of the result spans the entire portion of the port that was read.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/port)
+(define port1 (open-input-string "1 2 3"))
+(port-count-lines! port1)
+(read-all-syntax read-syntax port1)
+(define port2 (open-input-string "a b c"))
+(port-count-lines! port2)
+(parameterize ([current-input-port port2])
+  (read-all-syntax))
+]
+
+}
+
+@defproc[(port->srcloc [port port?]
+                       [source any/c (object-name port)]
+                       [span exact-nonnegative-integer? 0])
+         srcloc?]{
+
+Produces a @scheme[srcloc] structure representing the current position of a
+port, using the provided @scheme[source] and @scheme[span] values to fill in
+missing fields.  This function relies on @scheme[port-next-location], so line
+counting must be enabled for @scheme[port] to get meaningful results.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/port)
+(define port (open-input-string "1 2 3"))
+(port-count-lines! port)
+(read port)
+(port->srcloc port)
+(port->srcloc port "1 2 3" 1)
+]
+
+}
+
+@defproc[(read-available-bytes [port input-port? (current-input-port)])
+         (or/c bytes? eof-object?)]{
+
+This function reads all immediately available bytes from a port and produces a
+byte string containing them.  If there are no bytes available and the port is
+known to have no more input, it produces @scheme[eof]; if there are none
+available but the port may have more input, it produces an empty byte string.
+This procedure never blocks to wait for input from the port.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/port)
+(define-values [in out] (make-pipe))
+(parameterize ([current-input-port in]) (read-available-bytes))
+(write-byte (char->integer #\c) out)
+(read-available-bytes in)
+(read-available-bytes in)
+(close-output-port out)
+(read-available-bytes in)
+]
+
+}

collects/unstable/cce/reference/queue.scrbl

@@ -0,0 +1,67 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/queue))
+
+@title[#:style 'quiet #:tag "cce-queue"]{Imperative Queues}
+
+@defmodule[unstable/cce/queue]
+
+This module provides a mutable queue representation.
+
+@defproc[(make-queue) queue/c]{
+Produces an empty queue.
+}
+
+@defproc[(enqueue! [q queue/c] [v any/c]) void?]{
+Adds an element to the back of a queue.
+}
+
+@defproc[(dequeue! [q nonempty-queue/c]) any/c]{
+Removes an element from the front of a nonempty queue, and returns that element.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/queue)
+(define q (make-queue))
+(enqueue! q 1)
+(dequeue! q)
+(enqueue! q 2)
+(enqueue! q 3)
+(dequeue! q)
+(dequeue! q)
+]
+}
+
+@defproc[(queue-empty? [q queue/c]) boolean?]{
+Recognizes whether a queue is empty or not.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/queue)
+(define q (make-queue))
+(queue-empty? q)
+(enqueue! q 1)
+(queue-empty? q)
+(dequeue! q)
+(queue-empty? q)
+]
+}
+
+@defproc[(queue? [v any/c]) boolean?]{
+This predicate recognizes queues.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/queue)
+(queue? (make-queue))
+(queue? 'not-a-queue)
+]
+}
+
+@deftogether[(
+@defthing[queue/c flat-contract?]
+@defthing[nonempty-queue/c flat-contract?]
+)]{
+These contracts recognize queues; the latter requires the queue to contain at
+least one value.
+}

collects/unstable/cce/reference/regexp.scrbl

@@ -0,0 +1,129 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/regexp))
+
+@title[#:style 'quiet #:tag "cce-regexp"]{Regular Expressions}
+
+@defmodule[unstable/cce/regexp]
+
+This module provides tools for building strings which can be compiled to regular
+expressions.  In particular, the constructors wrap their arguments in
+appropriate delimeters to prevent misparsing after concatenation.
+
+@defproc[(regexp-sequence [#:start start string? ""]
+                          [#:between between string? ""]
+                          [#:end end string? ""]
+                          [re string?] ...)
+         string?]{
+
+Produces a regular expression string that matches @scheme[start], followed by
+each @scheme[re] interleaved with @scheme[between], followed by @scheme[end].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/regexp)
+(define re
+  (pregexp
+   (regexp-sequence "[0-9]+" "[0-9]+" "[0-9]+"
+                    #:start (regexp-quote "(")
+                    #:between (regexp-quote ",")
+                    #:end (regexp-quote ")"))))
+(regexp-match-exact? re "(1,10,100)")
+(regexp-match-exact? re "(1,10)")
+(regexp-match-exact? re " ( 1 , 10 , 100 ) ")
+]
+
+}
+
+@defproc[(regexp-or [re string?] ...+) string?]{
+
+Produces a regular expression string that matches any of the given @scheme[re]s.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/regexp)
+(define re (pregexp (regexp-or "[0-9]+" "[a-z]")))
+(regexp-match-exact? re "123")
+(regexp-match-exact? re "c")
+(regexp-match-exact? re "12c")
+]
+
+}
+
+@defproc[(regexp-maybe [re string?] ...+) string?]{
+
+Produces a regular expression string that matches either the empty string, or
+the concatenation of all the given @scheme[re]s.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/regexp)
+(define re (pregexp (regexp-maybe "[0-9]+" "[.]" "[0-9]+")))
+(regexp-match-exact? re "123.456")
+(regexp-match-exact? re "")
+(regexp-match-exact? re "123")
+]
+
+}
+
+@defproc[(regexp-star [re string?] ...+) string?]{
+
+Produces a regular expression string that matches zero or more consecutive
+occurrences of the concatenation of the given @scheme[re]s.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/regexp)
+(define re (pregexp (regexp-star "a" "b" "c")))
+(regexp-match-exact? re "")
+(regexp-match-exact? re "abc")
+(regexp-match-exact? re "abcabcabc")
+(regexp-match-exact? re "a")
+]
+
+}
+
+@defproc[(regexp-plus [re string?] ...+) string?]{
+
+Produces a regular expression string that matches one or more consecutive
+occurrences of the concatenation of the given @scheme[re]s.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/regexp)
+(define re (pregexp (regexp-plus "a" "b" "c")))
+(regexp-match-exact? re "")
+(regexp-match-exact? re "abc")
+(regexp-match-exact? re "abcabcabc")
+(regexp-match-exact? re "a")
+]
+
+}
+
+@defproc[(regexp-save [re string?] ...+) string?]{
+
+Produces a regular expression string that matches the concatenation of the given
+@scheme[re]s and saves the result.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/regexp)
+(define re
+  (pregexp (regexp-sequence (regexp-save "[0-9]+") "\\1")))
+(regexp-match-exact? re "11")
+(regexp-match-exact? re "123123")
+(regexp-match-exact? re "123456")
+]
+
+}
+
+@defproc[(regexp-multi [re string?] ...+) string?]{
+
+Produces a regular expression string that matches the concatenation of the given
+@scheme[re]s in multiple-line mode.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/regexp)
+(define re (pregexp (regexp-multi "^abc$")))
+(regexp-match? re "abc")
+(regexp-match? re "xyz\nabc\ndef")
+]
+
+}

collects/unstable/cce/reference/require-provide.scrbl

@@ -0,0 +1,107 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/require-provide))
+
+@title[#:style 'quiet #:tag "cce-require-provide"]{Require and Provide}
+
+@defmodule[unstable/cce/require-provide]
+
+This module provides tools for managing the imports and exports of modules.
+
+@defform[(require/provide module-path ...)]{
+
+Re-exports all bindings provided by each @scheme[module-path].  Equivalent to:
+
+@schemeblock[
+(require module-path ...)
+(provide (all-from-out module-path ...))
+]
+
+}
+
+@defform[(quote-require require-spec ...)]{
+
+Produces the names exported by the @scheme[require-spec]s as a list of symbols.
+
+@examples[
+#:eval (evaluator 'unstable/cce/require-provide)
+(quote-require scheme/bool scheme/function)
+]
+
+}
+
+@defform[(local-require require-spec ...)]{
+
+This form performs a require into a local definition context.  It achieves this
+by lifting a @scheme[#%require] form to the top level and introducing the
+bindings locally with rename transformers.  For many purposes this is the same
+as a regular @scheme[require]; however, only bindings for the current phase are
+made available, and all names are introduced as syntax bindings even if the
+exported identifiers included value bindings.
+
+}
+
+@defform[(do-local-require rename require-spec ...)]{
+
+This form generalizes @scheme[do-local-require] to use an arbitrary macro
+@scheme[rename] (of the same syntactic form as @scheme[define-renamings]) to
+introduce local bindings.
+
+}
+
+@defform[(define-planet-package name package)]{
+
+Defines a shortcut @scheme[name] for importing modules from planet package
+@scheme[package].  Subsequently, @scheme[(name module)] is equivalent to
+@scheme[(planet package/module)] as a require path.  For instance, to import the
+@scheme[text] and @scheme[web] modules from this package:
+
+@schemeblock[
+(define-planet-package my-package cce/scheme)
+(require (my-package web) (my-package text))
+]
+
+The above @scheme[require] is equivalent to:
+
+@schemeblock[
+(require (planet cce/scheme/web) (planet cce/scheme/text))
+]
+
+}
+
+@defform[(define-collection name collect)]{
+
+Defines a shortcut @scheme[name] for importing modules from @scheme[collect] and
+its subcollections.  Subsequently, @scheme[(name)] is equivalent to
+@scheme[collect] as a require path, and @scheme[(name path)] is equivalent to
+@scheme[collect/path].
+
+@schemeblock[
+(define-collection macro syntax)
+(require (macro parse))
+]
+
+The above @scheme[require] is equivalent to the below:
+
+@schemeblock[
+(require syntax/parse)
+]
+
+}
+
+@defform[
+(this-package-in path)
+]{
+
+This
+@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{require transformer}
+imports the file at @scheme[path] in the current planet package.  For instance,
+in the package @schememodname[(planet cce/scheme:7)], writing:
+@schemeblock[(require (this-package-in function))]
+... is equivalent to writing:
+@schemeblock[(require (planet cce/scheme:7/function))]
+
+}

collects/unstable/cce/reference/sandbox.scrbl

@@ -0,0 +1,66 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme scheme/sandbox unstable/cce/sandbox))
+
+@title[#:style 'quiet #:tag "cce-sandbox"]{Sandboxed Evaluation}
+
+@defmodule[unstable/cce/sandbox]
+
+This module provides tools for sandboxed evaluation.
+
+@deftogether[(
+@defproc[(make-trusted-evaluator
+          [language (or/c module-path?
+                          (list/c 'special symbol?)
+                          (cons/c 'begin list?))]
+          [input-program any/c] ...
+          [#:requires requires (listof (or/c module-path? path?))]
+          [#:allow-read allow (listof or/c module-path? path?)])
+         (any/c . -> . any)]
+@defproc[(make-trusted-module-evaluator
+          [module-decl (or/c syntax? pair?)]
+          [#:language lang (or/c #f module-path?)]
+          [#:allow-read allow (listof (or/c module-path? path?))])
+         (any/c . -> . any)]
+)]{
+These procedures wrap calls to @scheme[make-evaluator] and
+@scheme[make-module-evaluator], respectively, with
+@scheme[call-with-trusted-sandbox-configuration] (introduced in PLT 4.1.3.6).
+In older versions of PLT Scheme, they simulate the trusted configuration as
+closely as possible.
+}
+
+@deftogether[(
+@defproc[(make-scribble-evaluator
+          [language (or/c module-path?
+                          (list/c 'special symbol?)
+                          (cons/c 'begin list?))]
+          [input-program any/c] ...
+          [#:requires requires (listof (or/c module-path? path?))]
+          [#:allow-read allow (listof or/c module-path? path?)])
+         (any/c . -> . any)]
+@defproc[(make-scribble-module-evaluator
+          [module-decl (or/c syntax? pair?)]
+          [#:language lang (or/c #f module-path?)]
+          [#:allow-read allow (listof (or/c module-path? path?))])
+         (any/c . -> . any)]
+)]{
+These procedures wrap calls to @scheme[make-trusted-evaluator] and
+@scheme[make-trusted-module-evaluator], respectively, with parameterizations
+setting @scheme[sandbox-output] and @scheme[sandbox-error-output] to
+@scheme['string].
+}
+
+@defproc[(make-sandbox-namespace-specs [make-ns (-> namespace?)]
+                                       [path module-path?] ...)
+         (cons/c (-> namespace?) (listof module-path?))]{
+
+This function produces a value for the parameter
+@scheme[sandbox-namespace-specs] such that new sandbox evaluators start with a
+namespace constructed by @scheme[make-ns] and share a set of instances of the
+modules referred to by the given @scheme[path]s.
+
+}

collects/unstable/cce/reference/scribble.scrbl

@@ -0,0 +1,77 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          scribble/bnf
+          "../scribble.ss"
+          (for-label scheme/base scribble/manual unstable/cce/scribble))
+
+@title[#:tag "cce-scribble"]{Scribble Documentation}
+
+@defmodule[unstable/cce/scribble]
+
+This module provides tools for Scribble documentation; specifically, of
+@|PLaneT| packages.  In addition to the bindings described below, this module
+provides @scheme[this-package-version-symbol] from
+@schememodname[unstable/cce/planet], @scheme[this-package-in] from
+@schememodname[unstable/cce/require-provide], and
+@scheme[make-scribble-evaluator] and @scheme[make-scribble-module-evaluator]
+from @schememodname[unstable/cce/sandbox].
+
+@defform*[[
+(defmodule/this-package)
+(defmodule/this-package #:use-sources [src-path ...] [src ...])
+(defmodule/this-package path)
+(defmodule/this-package path #:use-sources [src-path ...] [src ...])
+]]{
+
+This Scribble form corresponds to @scheme[defmodule] within a planet package.
+The displayed module path is a @scheme[planet] module path to the current planet
+package, possibly with a @nonterm{path} (from the grammar of @scheme[planet]
+module specs) into the package.  If the @scheme[#:use-sources] option is
+present, each @scheme[src-path] is similarly treated as a path into the current
+planet package, while each @scheme[src] is treated normally.  Both sets of paths
+are concatenated and passed to the normal @scheme[defmodule].
+
+}
+
+@defform*[[
+(defmodule*/no-declare/this-package [src-path ...] [src ...])
+]]{
+
+This Scribble form corresponds to @scheme[defmodule*/no-declare] within a planet
+package.  The displayed module paths are @scheme[planet] module paths to the
+current planet package, possibly with @nonterm{path}s (from the grammar of
+@scheme[planet] module specs) into the package.  Each @scheme[src-path] is
+similarly treated as a path into the current planet package, while each
+@scheme[src] is treated normally.  Both sets of paths are concatenated and
+passed to the normal @scheme[defmodule*/no-declare].
+
+}
+
+@defform*[[
+(schememodname/this-package)
+(schememodname/this-package path)
+]]{
+
+This Scribble form corresponds to @scheme[schememodname] much like
+@scheme[defmodule/this-package] above corresponds to @scheme[defmodule].  The
+@scheme[path], if present, is treated as a @nonterm{path} (from the grammar of
+@scheme[planet] module specs) into the current planet package, and converted
+into a @scheme[planet] module spec.
+
+}
+
+@defform*[[
+(declare-exporting/this-package [mod-path ...] [mod ...])
+(declare-exporting/this-package [mod-path ...] [mod ...]
+                                #:use-sources [src-path ...] [src ...])
+]]{
+
+This Scribble form corresponds to @scheme[declare-exporting] much like
+@scheme[defmodule/this-package] above corresponds to @scheme[defmodule].  Each
+@scheme[mod-path] and @scheme[src-path] is treated as a @nonterm{path} (from the
+grammar of @scheme[planet] module specs) into the current package.  They are
+concatenated with the lists of @scheme[mod]s and @scheme[src]s, respectively,
+and passed to the normal @scheme[declare-exporting].
+
+}

collects/unstable/cce/reference/set.scrbl

@@ -0,0 +1,414 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/set))
+
+@title[#:style 'quiet #:tag "cce-set"]{Sets}
+
+@defmodule[unstable/cce/set]
+
+This module provides tools for representing finite sets.
+
+@section{Set Constructors}
+
+@defproc[(set [#:mutable? mutable? boolean? weak?]
+              [#:weak? weak? boolean? #f]
+              [#:compare compare (or/c 'eq 'eqv 'equal) 'equal]
+              [x any/c] ...)
+         set?]{
+
+Produces a hash table-based set using the hash table properties described by
+any keyword arguments, and the given values as elements of the set.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set 1 2 3)
+(set #:mutable? #t 1 2 3)
+(set #:weak? #t 1 2 3)
+(set #:compare 'eqv 1 2 3)
+]
+
+}
+
+@defproc[(empty-set [#:mutable? mutable? boolean? weak?]
+                    [#:weak? weak? boolean? #f]
+                    [#:compare compare (or/c 'eq 'eqv 'equal) 'equal])
+         set?]{
+
+Produces an empty hash table-based set using the hash table properties described
+by any keyword arguments.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(empty-set)
+(empty-set #:mutable? #t)
+(empty-set #:weak? #t)
+(empty-set #:compare 'eqv)
+]
+
+}
+
+@defproc[(list->set [#:mutable? mutable? boolean? weak?]
+                    [#:weak? weak? boolean? #f]
+                    [#:compare compare (or/c 'eq 'eqv 'equal) 'equal]
+                    [lst list?])
+         set?]{
+
+Produces a hash table-based set using the hash table properties described by
+any keyword arguments, with the elements of the given list as the elements of
+the set.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(list->set '(1 2 3))
+(list->set #:mutable? #t '(1 2 3))
+(list->set #:weak? #t '(1 2 3))
+(list->set #:compare 'eqv '(1 2 3))
+]
+
+}
+
+@defproc[(custom-set [#:compare compare (-> any/c any/c any/c)]
+                     [#:hash hash (-> any/c exact-integer?) (lambda (x) 0)]
+                     [#:hash2 hash2 (-> any/c exact-integer?) (lambda (x) 0)]
+                     [#:mutable? mutable? boolean? weak?]
+                     [#:weak? weak? boolean? #f]
+                     [elem any/c] ...)
+         set?]{
+
+Produces a custom hash table-based set using the given equality predicate
+@scheme[equiv?] and optional hash functions @scheme[hash-primary] and
+@scheme[hash-secondary].  If no hash functions are given, they default to a
+degenerate hash function, resulting in an effectively list-based set.  The set
+is populated with the given @scheme[elem] values.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(define singularity
+  (custom-set 'one 'two 'three
+              #:mutable? #t
+              #:compare (lambda (a b) #t)))
+(set->list singularity)
+(set-insert! singularity 'four)
+(set->list singularity)
+(set-remove! singularity 'zero)
+(set->list singularity)
+]
+
+}
+
+@section{Set Accessors}
+
+@defproc[(set-contains? [s set?] [x any/c]) boolean?]{
+
+Reports whether @scheme[s] contains @scheme[x].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-contains? (set 1 2 3) 1)
+(set-contains? (set 1 2 3) 4)
+]
+
+}
+
+@defproc[(set-empty? [s set?]) boolean?]{
+
+Reports whether a set is empty.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-empty? '())
+(set-empty? '((1 . one)))
+]
+
+}
+
+@defproc[(set-count [s set?]) exact-nonnegative-integer?]{
+
+Reports the number of elements in @scheme[s].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-count (set))
+(set-count (set 1 2 3))
+]
+
+}
+
+@defproc[(set=? [a set?] [b set?]) boolean?]{
+
+Reports whether two sets contain the same elements.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set=? (set 1) (set 1 2 3))
+(set=? (set 1 2 3) (set 1))
+(set=? (set 1 2 3) (set 1 2 3))
+]
+
+}
+
+@defproc[(subset? [a set?] [b set?]) boolean?]{
+
+Reports whether @scheme[b] contains all of the elements of @scheme[a].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(subset? (set 1) (set 1 2 3))
+(subset? (set 1 2 3) (set 1))
+(subset? (set 1 2 3) (set 1 2 3))
+]
+
+}
+
+@defproc[(proper-subset? [a set?] [b set?]) boolean?]{
+
+Reports whether @scheme[b] contains all of the elements of @scheme[a], and at
+least one element not in @scheme[a].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(proper-subset? (set 1) (set 1 2 3))
+(proper-subset? (set 1 2 3) (set 1))
+(proper-subset? (set 1 2 3) (set 1 2 3))
+]
+
+}
+
+@defproc[(set->list [s set?]) list?]{
+
+Produces a list containing the elements of @scheme[s].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set->list (set 1 2 3))
+]
+
+}
+
+@defproc[(in-set [s set?]) sequence?]{
+
+Produces a sequence iterating over the elements of the set.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(for/list ([x (in-set (set 1 2 3))]) x)
+]
+
+}
+
+@section{Set Updaters}
+
+@defproc[(set-insert [s set?] [x any/c]) set?]{
+
+Produces a new version of @scheme[s] containing @scheme[x].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-insert (set 1 2 3) 4)
+(set-insert (set 1 2 3) 1)
+]
+
+}
+
+@defproc[(set-remove [s set?] [x any/c]) set?]{
+
+Produces a new version of @scheme[s] that does not contain @scheme[x].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-remove (set 1 2 3) 1)
+(set-remove (set 1 2 3) 4)
+]
+
+}
+
+@defproc[(set-insert! [s set?] [x any/c]) void?]{
+
+Mutates @scheme[s] to contain @scheme[x].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(define s (set #:mutable? #t 1 2 3))
+s
+(set-insert! s 4)
+s
+(set-insert! s 1)
+s
+]
+
+}
+
+@defproc[(set-remove! [s set?] [x any/c]) void?]{
+
+Mutates @scheme[x] so as not to contain @scheme[x].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(define s (set #:mutable? #t 1 2 3))
+s
+(set-remove! s 1)
+s
+(set-remove! s 4)
+s
+]
+
+}
+
+@defproc[(set-union [s0 (and/c set? set-can-insert?)] [s set?] ...) set?]{
+
+Produces a new version of @scheme[s0] containing all the elements in each
+@scheme[s].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-union (set 1 2) (set 1 3) (set 2 3))
+]
+
+}
+
+@defproc[(set-intersection [s0 (and/c set? set-can-remove?)] [s set?] ...)
+         set?]{
+
+Produces a new version of @scheme[s0] containing only those elements found in
+every @scheme[s].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-intersection (set 1 2 3) (set 1 2) (set 2 3))
+]
+
+}
+
+@defproc[(set-difference [s0 (and/c set? set-can-remove?)] [s set?] ...) set?]{
+
+Produces a new version of @scheme[s0] containing only those elements not found
+in any @scheme[s].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-difference (set 1 2 3) (set 1) (set 3))
+]
+
+}
+
+@defproc[(set-exclusive-or [s0 (and/c set? set-can-insert? set-can-remove?)]
+                           [s set?] ...)
+         set?]{
+
+Produces a new version of @scheme[s0] containing only those elements found in
+@scheme[s0] and each @scheme[s] an odd number of times.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set-exclusive-or (set 1) (set 1 2) (set 1 2 3))
+]
+
+}
+
+@section{Set Predicates}
+
+@defproc[(set? [x any/c]) boolean?]{
+
+Recognizes sets.  A @deftech{set} is either a @tech[#:doc '(lib
+"scribblings/reference/reference.scrbl")]{dictionary} or a structure with the
+@scheme[prop:set] property.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(set? '(1 2))
+(set? '((1 . one) (2 . two)))
+]
+
+}
+
+@deftogether[(
+@defproc[(set-can-insert? [s set?]) boolean?]
+@defproc[(set-can-remove? [s set?]) boolean?]
+@defproc[(set-can-insert!? [s set?]) boolean?]
+@defproc[(set-can-remove!? [s set?]) boolean?]
+)]{
+
+Report whether @scheme[s] supports @scheme[set-insert], @scheme[set-remove],
+@scheme[set-insert!], or @scheme[set-remove!], respectively.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(define functional-set (set 1 2 3))
+(set-can-insert? functional-set)
+(set-can-remove? functional-set)
+(set-can-insert!? functional-set)
+(set-can-remove!? functional-set)
+(define imperative-set (set #:mutable? #t 1 2 3))
+(set-can-insert? imperative-set)
+(set-can-remove? imperative-set)
+(set-can-insert!? imperative-set)
+(set-can-remove!? imperative-set)
+]
+
+}
+
+@section{Structures as Sets}
+
+@defthing[prop:set struct-type-property?]{
+
+Property for structurs as @tech{sets}.  Its value must be a vector of 7
+elements, as follows:
+
+@itemlist[
+
+@item{a binary function implementing @scheme[set-contains?],}
+
+@item{a binary function implementing @scheme[set-insert!], or @scheme[#f] if not
+supported,}
+
+@item{a binary function implementing @scheme[set-insert], or @scheme[#f] if not
+supported,}
+
+@item{a binary function implementing @scheme[set-remove!], or @scheme[#f] if not
+supported,}
+
+@item{a binary function implementing @scheme[set-remove], or @scheme[#f] if
+not supported,}
+
+@item{a unary function implementing @scheme[set-count],}
+
+@item{and a unary function implementing @scheme[in-set].}
+
+]
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/set)
+(define (never-contains? set elem) #f)
+(define (never-insert! set elem) (error 'set-insert! "always empty!"))
+(define (never-insert set elem) (error 'set-insert "always empty!"))
+(define (never-remove! set elem) (void))
+(define (never-remove set elem) set)
+(define (always-zero set) 0)
+(define (no-elements set) null)
+
+(define-struct always-empty []
+  #:transparent
+  #:property prop:set
+  (vector never-contains?
+          never-insert!
+          never-insert
+          never-remove!
+          never-remove
+          always-zero
+          no-elements))
+
+(set? (make-always-empty))
+(set-contains? (make-always-empty) 1)
+(set-insert! (make-always-empty) 2)
+(set-insert (make-always-empty) 3)
+(set-remove (make-always-empty) 4)
+(set-remove! (make-always-empty) 5)
+(set-count (make-always-empty))
+(for ([x (in-set (make-always-empty))])
+  (printf "~s\n" x))
+]
+
+}

collects/unstable/cce/reference/slideshow.scrbl

@@ -0,0 +1,314 @@
+#lang scribble/doc
+@(require scribble/manual
+          "../scribble.ss"
+          (for-label slideshow
+                     unstable/cce/contract
+                     unstable/cce/slideshow))
+
+@title[#:style 'quiet #:tag "cce-slideshow"]{Slideshow Presentations}
+
+@defmodule[unstable/cce/slideshow]
+
+@section{Text Formatting}
+
+@defform[(with-size size expr)]{
+
+Sets @scheme[current-font-size] to @scheme[size] while running @scheme[expr].
+
+}
+
+@defform[(with-scale scale expr)]{
+
+Multiplies @scheme[current-font-size] by @scheme[scale] while running
+@scheme[expr].
+
+}
+
+@deftogether[(
+@defform[(big text)]
+@defform[(small text)]
+)]{
+
+Scale @scheme[current-font-size] by @scheme[3/2] or @scheme[2/3], respectively,
+while running @scheme[text].
+
+}
+
+@defform[(with-font font expr)]{
+
+Sets @scheme[current-main-font] to @scheme[font] while running @scheme[expr].
+
+}
+
+@defform[(with-style style expr)]{
+
+Adds @scheme[style] to @scheme[current-main-font] (via @scheme[cons]) while
+running @scheme[expr].
+
+}
+
+@deftogether[(
+@defform[(bold text)]
+@defform[(italic text)]
+@defform[(subscript text)]
+@defform[(superscript text)]
+@defform[(caps text)]
+)]{
+
+Adds the attributes for bold, italic, superscript, subscript, or small caps
+text, respectively, to @scheme[current-main-font] while running @scheme[text].
+
+}
+
+@section{Pict Colors}
+
+@defproc[(color [c color/c] [p pict?]) pict?]{
+
+Applies color @scheme[c] to picture @scheme[p].  Equivalent to @scheme[(colorize
+p c)].
+
+}
+
+@deftogether[(
+@defproc[(red [pict pict?]) pict?]
+@defproc[(orange [pict pict?]) pict?]
+@defproc[(yellow [pict pict?]) pict?]
+@defproc[(green [pict pict?]) pict?]
+@defproc[(blue [pict pict?]) pict?]
+@defproc[(purple [pict pict?]) pict?]
+@defproc[(black [pict pict?]) pict?]
+@defproc[(brown [pict pict?]) pict?]
+@defproc[(gray [pict pict?]) pict?]
+@defproc[(white [pict pict?]) pict?]
+@defproc[(cyan [pict pict?]) pict?]
+@defproc[(magenta [pict pict?]) pict?]
+)]{
+
+These functions apply appropriate colors to picture @scheme[p].
+
+}
+
+@deftogether[(
+@defproc[(light [color color/c]) color/c]
+@defproc[(dark [color color/c]) color/c]
+)]{
+
+These functions produce ligher or darker versions of a color.
+
+}
+
+@defthing[color/c flat-contract?]{
+
+This contract recognizes color strings, @scheme[color%] instances, and RGB color
+lists.
+
+}
+
+@section{Pict Manipulation}
+
+@defproc[(fill [pict pict?] [width (or/c real? #f)] [height (or/c real? #f)])
+         pict?]{
+
+Extends @scheme[pict]'s bounding box to a minimum @scheme[width] and/or
+@scheme[height], placing the original picture in the middle of the space.
+
+}
+
+@subsection{Conditional Manipulations}
+
+These pict transformers all take boolean arguments that determine whether to
+transform the pict or leave it unchanged.  These transformations can be useful
+for staged slides, as the resulting pict always has the same size and shape, and
+its contents always appear at the same position, but changing the boolean
+argument between slides can control when the transformation occurs.
+
+@deftogether[(
+@defproc[(show [pict pict?] [show? truth/c #t]) pict?]
+@defproc[(hide [pict pict?] [hide? truth/c #t]) pict?]
+)]{
+
+These functions conditionally show or hide an image, essentially choosing
+between @scheme[pict] and @scheme[(ghost pict)].  The only difference between
+the two is the default behavior and the opposite meaning of the @scheme[show?]
+and @scheme[hide?] booleans.  Both functions are provided for mnemonic purposes.
+
+}
+
+@defproc[(strike [pict pict?] [strike? truth/c #t]) pict?]{
+
+Displays a strikethrough image by putting a line through the middle of
+@scheme[pict] if @scheme[strike?] is true; produces @scheme[pict] unchanged
+otherwise.
+
+}
+
+@defproc[(shade [pict pict?]
+                [shade? truth/c #t]
+                [#:ratio ratio (real-in 0 1) 1/2])
+         pict?]{
+
+Shades @scheme[pict] to show with @scheme[ratio] of its normal opacity; if
+@scheme[ratio] is @scheme[1] or @scheme[shade?] is @scheme[#f], shows
+@scheme[pict] unchanged.
+
+}
+
+@subsection{Conditional Combinations}
+
+These pict control flow operators decide which pict of several to use.  All
+branches are evaluated; the resulting pict is a combination of the pict chosen
+by normal conditional flow with @scheme[ghost] applied to all the other picts.
+The result is a picture large enough to accomodate each alternative, but showing
+only the chosen one.  This is useful for staged slides, as the pict chosen may
+change with each slide but its size and position will not.
+
+@defform/subs[(pict-if maybe-combine test-expr then-expr else-expr)
+              ([maybe-combine code:blank (code:line #:combine combine-expr)])]{
+
+Chooses either @scheme[then-expr] or @scheme[else-expr] based on
+@scheme[test-expr], similarly to @scheme[if].  Combines the chosen, visible
+image with the other, invisible image using @scheme[combine-expr], defaulting to
+@scheme[pict-combine].
+
+}
+
+@defform/subs[(pict-cond maybe-combine [test-expr pict-expr] ...)
+              ([maybe-combine code:blank (code:line #:combine combine-expr)])]{
+
+Chooses a @scheme[pict-expr] based on the first successful @scheme[test-expr],
+similarly to @scheme[cond].  Combines the chosen, visible image with the other,
+invisible images using @scheme[combine-expr], defaulting to
+@scheme[pict-combine].
+
+}
+
+@defform/subs[(pict-case test-expr maybe-combine [literals pict-expr] ...)
+              ([maybe-combine code:blank (code:line #:combine combine-expr)])]{
+
+Chooses a @scheme[pict-expr] based on @scheme[test-expr] and each list of
+@scheme[literals], similarly to @scheme[case].  Combines the chosen, visible
+image with the other, invisible images using @scheme[combine-expr], defaulting
+to @scheme[pict-combine].
+
+}
+
+@defform/subs[(pict-match test-expr maybe-combine [pattern pict-expr] ...)
+              ([maybe-combine code:blank (code:line #:combine combine-expr)])]{
+
+Chooses a @scheme[pict-expr] based on @scheme[test-expr] and each
+@scheme[pattern], similarly to @scheme[match].  Combines the chosen, visible
+image with the other, invisible images using @scheme[combine-expr], defaulting
+to @scheme[pict-combine].
+
+}
+
+@defform[#:id pict-combine pict-combine]{
+
+This syntax parameter determines the default pict combining form used by the
+above macros.  It defaults to @scheme[lbl-superimpose].
+
+}
+
+@defform[(with-pict-combine combine-id body ...)]{
+
+Sets @scheme[pict-combine] to refer to @scheme[combine-id] within each of the
+@scheme[body] terms, which are spliced into the containing context.
+
+}
+
+@section{Staged Slides}
+
+@defform[(staged [name ...] body ...)]{
+
+Executes the @scheme[body] terms once for each stage @scheme[name].  The terms
+may include expressions and mutually recursive definitions.  Within the body,
+each @scheme[name] is bound to a number from @scheme[1] to the number of stages
+in order.  Furthermore, during execution @scheme[stage] is bound to the number
+of the current stage and @scheme[stage-name] is bound to a symbol representing
+the @scheme[name] of the current stage.  By comparing @scheme[stage] to the
+numeric value of each @scheme[name], or @scheme[stage-name] to quoted symbols of
+the form @scheme['name], the user may compute based on the progression of the
+stages.
+
+}
+
+@deftogether[(
+@defform[#:id stage stage]
+@defform[#:id stage-name stage-name]
+)]{
+
+These keywords are bound during the execution of @scheme[staged] and should not
+be used otherwise.
+
+}
+
+@defform[(slide/staged [name ...] arg ...)]{
+
+Creates a staged slide.  Equivalent to @scheme[(staged [name ...] (slide arg
+...))].
+
+Within a staged slide, the boolean arguments to @scheme[hide], @scheme[show],
+@scheme[strike], and @scheme[shade] can be used to determine in which stages to
+perform a transformation.  The macros @scheme[pict-if], @scheme[pict-cond],
+@scheme[pict-case], and @scheme[pict-match] may also be used to create images
+which change naturally between stages.
+
+}
+
+@section{Tables}
+
+@defproc[(tabular [row (listof (or/c string? pict?))] ...
+                  [#:gap gap natural-number/c gap-size]
+                  [#:hgap hgap natural-number/c gap]
+                  [#:vgap vgap natural-number/c gap]
+                  [#:align align (->* [] [] #:rest (listof pict?) pict?) lbl-superimpose]
+                  [#:halign halign (->* [] [] #:rest (listof pict?) pict?) align]
+                  [#:valign valign (->* [] [] #:rest (listof pict?) pict?) align])
+         pict?]{
+
+Constructs a table containing the given @scheme[row]s, all of which must be of
+the same length.  Applies @scheme[t] to each string in a @scheme[row] to
+construct a pict.  The @scheme[hgap], @scheme[vgap], @scheme[halign], and
+@scheme[valign] are used to determine the horizontal and vertical gaps and
+alignments as in @scheme[table] (except that every row and column is uniform).
+
+}
+
+@section{Multiple Columns}
+
+@defform[(two-columns one two)]{
+
+Constructs a two-column pict using @scheme[one] and @scheme[two] as the two
+columns.  Sets @scheme[current-para-width] appropriately in each column.
+
+}
+
+@defproc[(mini-slide [pict pict?] ...) pict?]{
+
+Appends each @scheme[pict] vertically with space between them, similarly to the
+@scheme[slide] function.
+
+}
+
+@defproc[(columns [pict pict?] ...) pict?]{
+
+Combines each @scheme[pict] horizontally, aligned at the top, with space in
+between.
+
+}
+
+@defform[(column width body ...)]{
+
+Sets @scheme[current-para-width] to @scheme[width] during execution of the
+@scheme[body] expressions.
+
+}
+
+@defproc[(column-size [n exact-positive-integer?]
+                      [r real? (/ n )])
+         real?]{
+
+Computes the width of one column out of @scheme[n] that takes up a ratio of
+@scheme[r] of the available space (according to @scheme[current-para-width]).
+
+}

collects/unstable/cce/reference/syntax.scrbl

@@ -0,0 +1,387 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/syntax))
+
+@title[#:style 'quiet #:tag "cce-syntax"]{Syntax Objects}
+
+@defmodule[unstable/cce/syntax]
+
+This module provides tools for macro transformers.
+
+@section{Contracts}
+
+@defproc[(syntax-datum/c [datum/c any/c]) flat-contract?]{
+
+Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->datum stx)]
+satisfies @scheme[datum/c].
+
+}
+
+@defproc[(syntax-listof/c [elem/c any/c]) flat-contract?]{
+
+Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->list stx)]
+satisfies @scheme[(listof elem/c)].
+
+}
+
+@defproc[(syntax-list/c [elem/c any/c] ...) flat-contract?]{
+
+Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->list stx)]
+satisfies @scheme[(list/c elem/c ...)].
+
+}
+
+@section{Syntax Lists}
+
+@defform[(syntax-list template ...)]{
+
+This form constructs a list of syntax objects based on the given templates.  It
+is equivalent to @scheme[(syntax->list (syntax (template ...)))].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(with-syntax ([(x ...) (syntax (1 2 3))]) (syntax-list x ...))
+]
+
+}
+
+@defproc[(syntax-map [f (-> syntax? A)] [stx syntax?]) (listof A)]{
+
+Performs @scheme[(map f (syntax->list stx))].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(syntax-map syntax-e #'(a (b c) d))
+]
+
+}
+
+@section{Syntax Conversions}
+
+@defproc[(to-syntax [datum any/c]
+                    [#:stx stx (or/c false/c syntax?) #f]
+                    [#:src src src/c stx]
+                    [#:ctxt ctxt (or/c false/c syntax?) stx]
+                    [#:prop prop (or/c false/c syntax?) stx]
+                    [#:cert cert (or/c false/c syntax?) stx])
+         syntax?]{
+
+A wrapper for @scheme[datum->syntax] with keyword arguments.
+
+The "master" keyword @scheme[#:stx] sets all attributes from a single syntax
+object, defaulting to @scheme[#f] for unadorned syntax objects.
+
+The individual keywords @scheme[#:src], @scheme[#:ctxt], @scheme[#:prop], and
+@scheme[#:cert] override @scheme[#:stx] for individual syntax object
+attributes.  They control source src information, lexical context
+information, syntax object properties, and syntax certificates, respectively.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(define blank-stx (to-syntax 'car))
+blank-stx
+(syntax-e blank-stx)
+(free-identifier=? blank-stx #'car)
+(define full-stx (to-syntax 'car #:stx #'here))
+full-stx
+(syntax-e full-stx)
+(free-identifier=? full-stx #'car)
+(define partial-stx (to-syntax 'car #:ctxt #'here))
+partial-stx
+(syntax-e partial-stx)
+(free-identifier=? partial-stx #'car)
+]
+
+}
+
+@defproc[(to-datum [x any/c]) (not/c syntax?)]{
+
+A wrapper for @scheme[syntax->datum].  Produces @scheme[(syntax->datum x)] if
+@scheme[x] is a syntax object and @scheme[x] otherwise.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(to-datum #'(a b c))
+(to-datum (list #'a #'b #'c))
+]
+
+}
+
+@section{Source Locations [Deprecated]}
+
+@subsection{Source Location Representations}
+
+@defthing[src/c flat-contract?]{
+
+This contract recognizes various representations of source locations, including
+@scheme[srcloc] structures and those accepted by @scheme[datum->syntax]: syntax
+objects, source location lists, source location vectors, and @scheme[#f].
+
+}
+
+@deftogether[(
+@defproc[(src->srcloc [loc src/c] ...) srcloc?]
+@defproc[(src->syntax [loc src/c] ...) syntax?]
+@defproc[(src->list [loc src/c] ...)
+         (list/c any/c
+                 (or/c exact-positive-integer? #f)
+                 (or/c exact-nonnegative-integer? #f)
+                 (or/c exact-nonnegative-integer? #f)
+                 (or/c exact-positive-integer? #f))]
+@defproc[(src->vector [loc src/c] ...)
+         (vector/c any/c
+                   (or/c exact-positive-integer? #f)
+                   (or/c exact-nonnegative-integer? #f)
+                   (or/c exact-nonnegative-integer? #f)
+                   (or/c exact-positive-integer? #f))]
+)]{
+
+These functions combine multiple source locations and convert them to a specific
+format.  If all provided source locations come from the same source, the result
+is a source location from the same source that spans all the lines, columns, and
+positions included in the originals.  If no source locations are provided, or
+locations from different sources are provided, the result is a source location
+with no information (@scheme[#f] for source, line, column, position, and span).
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(src->srcloc (datum->syntax #f null (list 'source 2 3 4 5)))
+(src->syntax (make-srcloc 'source 2 3 4 5))
+(src->list (list 'source 2 3 4 5) (vector 'source 6 7 8 9))
+(src->vector)
+]
+
+}
+
+@defproc[(src-known? [loc src/c]) boolean?]{
+
+Reports whether @scheme[loc] has any non-@scheme[#f] fields.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(src-known? (list #f #f #f #f #f))
+(src-known? (list 'source #f #f #f #f))
+(src-known? (list 'source 1 2 3 4))
+]
+
+}
+
+@subsection{Syntax Object Source Locations}
+
+@deftogether[(
+@defproc[(syntax-source-directory [stx syntax?]) (or/c path? #f)]
+@defproc[(syntax-source-file-name [stx syntax?]) (or/c path? #f)]
+)]{
+
+These produce the directory and file name, respectively, of the path with which
+@scheme[stx] is associated, or @scheme[#f] if @scheme[stx] is not associated
+with a path.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(define loc
+  (list (build-path "/tmp" "dir" "somewhere.ss")
+        #f #f #f #f))
+(define stx1 (datum->syntax #f 'somewhere loc))
+(syntax-source-directory stx1)
+(syntax-source-file-name stx1)
+(define stx2 (datum->syntax #f 'nowhere #f))
+(syntax-source-directory stx2)
+(syntax-source-directory stx2)
+]
+
+}
+
+@deftogether[(
+@defproc[(syntax-source-planet-package [stx syntax?])
+         (or/c (list/c string?
+                       string?
+                       exact-nonnegative-integer?
+                       exact-nonnegative-integer?)
+                #f)]
+@defproc[(syntax-source-planet-package-owner [stx syntax?]) (or/c string? #f)]
+@defproc[(syntax-source-planet-package-name [stx syntax?]) (or/c string? #f)]
+@defproc[(syntax-source-planet-package-major [stx syntax?])
+         (or/c exact-nonnegative-integer? #f)]
+@defproc[(syntax-source-planet-package-minor [stx syntax?])
+         (or/c exact-nonnegative-integer? #f)]
+@defproc[(syntax-source-planet-package-symbol
+          [stx syntax?]
+          [text (or/c text? #f) #f])
+         (or/c symbol? #f)]
+)]{
+
+These functions extract the planet package with which @scheme[stx] is
+associated, if any, based on its source location information and the currently
+installed set of planet packages.  They produce, respectively, the planet
+package s-expression, its owner, name, major version number, minor version
+number, or a symbol corresponding to a @scheme[planet] module path.  They each
+produce @scheme[#f] if @scheme[stx] is not associated with a planet package.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(define loc
+  (list (build-path (current-directory) "file.ss")
+        #f #f #f #f))
+(define stx (datum->syntax #f 'stx loc))
+(syntax-source-planet-package stx)
+(syntax-source-planet-package-owner stx)
+(syntax-source-planet-package-name stx)
+(syntax-source-planet-package-major stx)
+(syntax-source-planet-package-minor stx)
+(syntax-source-planet-package-symbol stx)
+(syntax-source-planet-package-symbol stx "there")
+]
+
+}
+
+@defproc[(make-planet-path [stx syntax?] [id (or/c identifier? #f)]) syntax?]{
+
+Constructs a syntax object representing a require spec for the planet package
+from which @scheme[stx] arises, with suffix @scheme[id] (if any).
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(define loc
+  (list (build-path (current-directory) "file.ss")
+        #f #f #f #f))
+(define stx (datum->syntax #f 'stx loc))
+(make-planet-path stx #f)
+(make-planet-path stx #'there)
+]
+
+}
+
+@section{Macro Transformers}
+
+@defproc[(redirect-transformer [id identifier?]) (-> syntax? syntax?)]{
+
+Constructs a function that behaves like a rename transformer; it does not
+cooperate with @scheme[syntax-local-value] like a rename transformer does, but
+unlike a rename transformer it may be used as a function to transform a syntax
+object referring to one identifier into a syntax object referring to another.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+((redirect-transformer #'x) #'a)
+((redirect-transformer #'y) #'(a b c))
+]
+
+}
+
+@defproc[(head-expand [stx syntax?] [stop-list (listof identifier?)]) syntax?]{
+
+This function performs head expansion on @scheme[stx].  In other words, it uses
+@scheme[local-expand] to expand @scheme[stx] until its head identifier is a core
+form (a member of @scheme[(full-kernel-form-identifier-list)]) or a member of
+@scheme[stop-list], or until it can not be expanded further (e.g. due to error).
+
+It is equivalent to @scheme[(local-expand stx (syntax-local-context) (append
+stop-ids (full-kernel-form-identifier-list) #f))].
+
+}
+
+@defproc[(full-kernel-form-identifier-list) (listof identifier?)]{
+
+This function produces the full list of identifiers that may be found in fully
+expanded code produced by @scheme[expand], @scheme[local-expand], and related
+functions.  It is similar to @scheme[kernel-form-identifier-list], except that
+in prior versions of PLT Scheme that excluded module top-level forms from the
+list, this function includes them.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(full-kernel-form-identifier-list)
+]
+
+}
+
+@defproc[(trampoline-transformer
+          [f (-> (-> syntax? void?) (-> syntax? syntax?) syntax? syntax?)])
+         (-> syntax? syntax?)]{
+
+Produces a transformer that can emit multiple results during macro expansion, to
+be spliced together via @scheme[begin].  This can be useful for compound
+expansion that relies on transformer definitions, as well as on expansion state
+that is difficult to marshall.
+
+Specifically, @scheme[f] is invoked with three arguments.  The first is the
+function used to emit intermediate results (other than the last one).  The
+second applies the @tech[#:doc '(lib
+"scribblings/reference/reference.scrbl")]{syntax mark} used for the entire
+expansion; @scheme[syntax-local-introduce] will not be reliable during this
+process.  The third is the syntax object to expand.
+
+@defexamples[
+#:eval (evaluator '(for-syntax unstable/cce/syntax))
+(define-syntax magic-begin
+  (trampoline-transformer
+   (lambda (emit intro stx)
+     (syntax-case stx ()
+       [(_ term ...)
+        (let loop ([terms (syntax->list #'(term ...))])
+          (cond
+           [(null? terms) #'(begin)]
+           [(null? (cdr terms)) (car terms)]
+           [else
+            (printf "Presto: ~s!\n"
+                    (syntax->datum (car terms)))
+            (emit (car terms))
+            (loop (cdr terms))]))]))))
+(magic-begin
+ (define x 1)
+ (define y 2)
+ (+ x y))
+]
+
+}
+
+@defproc[(quote-transformer [x any/c]) syntax?]{
+
+Produces a syntax object representing an expression that reconstructs @scheme[x]
+when executed, including faithfully reconstructing any syntax objects contained
+in @scheme[x].  Note that @scheme[quote] normally converts syntax objects to
+non-syntax data, and @scheme[quote-syntax] does the opposite.
+
+@defexamples[
+#:eval (evaluator '(for-syntax unstable/cce/syntax))
+(define-for-syntax x (list 1 #'(2 3) 4))
+(define-syntax (the-many-faces-of-x stx)
+  (with-syntax ([x x] [qx (quote-transformer x)])
+   #'(list (quote x)
+           (quote-syntax x)
+           qx)))
+(the-many-faces-of-x)
+]
+
+}
+
+@section{Syntax Errors}
+
+@defthing[current-syntax (parameter/c (or/c syntax? false/c))]{
+A parameter that may be used to store the current syntax object being
+transformed.  It is not used by the expander; you have to assign to it yourself.
+This parameter is used by @scheme[syntax-error], below.  It defaults to
+@scheme[#f].
+}
+
+@defproc[(syntax-error [stx syntax?] [fmt string?] [arg any/c] ...) none/c]{
+Raises a syntax error based on the locations of @scheme[(current-syntax)] and
+@scheme[stx], with @scheme[(format fmt arg ...)] as its message.
+@defexamples[
+#:eval (evaluator 'unstable/cce/syntax)
+(define stx #'(a b c))
+(parameterize ([current-syntax #f])
+  (syntax-error stx "~s location" 'general))
+(parameterize ([current-syntax stx])
+  (syntax-error (car (syntax-e stx)) "~s location" 'specific))
+]
+}
+
+@section{Pattern Bindings}
+
+This package re-exports @scheme[with-syntax*] from
+@schememodname[unstable/syntax].

collects/unstable/cce/reference/text.scrbl

@@ -0,0 +1,170 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/text))
+
+@title[#:style 'quiet #:tag "cce-text"]{Text Representations}
+
+@defmodule[unstable/cce/text]
+
+This module provides tools for manipulating and converting textual data.
+
+@section{Contracts and Predicates}
+
+@deftogether[(
+@defthing[text/c flat-contract?]{}
+@defproc[(text? [v any/c]) boolean?]{}
+)]{
+
+This contract and predicate recognize text values: strings, byte strings,
+symbols, and keywords, as well as syntax objects containing them.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/text)
+(text? "text")
+(text? #"text")
+(text? 'text)
+(text? '#:text)
+(text? #'"text")
+(text? #'#"text")
+(text? #'text)
+(text? #'#:text)
+(text? '(not text))
+]
+
+}
+
+@deftogether[(
+@defproc[(string-literal? [v any/c]) boolean?]{}
+@defproc[(bytes-literal? [v any/c]) boolean?]{}
+@defproc[(keyword-literal? [v any/c]) boolean?]{}
+)]{
+
+These predicates recognize specific text types stored in syntax objects.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/text)
+(string-literal? #'"literal")
+(string-literal? "not literal")
+(bytes-literal? #'#"literal")
+(bytes-literal? #"not literal")
+(keyword-literal? #'#:literal)
+(keyword-literal? '#:not-literal)
+]
+
+}
+
+@section{Text Conversions and Concatenation}
+
+@deftogether[(
+@defproc[(text->string [#:before before text/c ""]
+                       [#:between between text/c ""]
+                       [#:after after text/c ""]
+                       [text text/c] ...) string?]{}
+@defproc[(text->bytes [#:before before text/c ""]
+                      [#:between between text/c ""]
+                      [#:after after text/c ""]
+                      [text text/c] ...) bytes?]{}
+@defproc[(text->symbol [#:before before text/c ""]
+                       [#:between between text/c ""]
+                       [#:after after text/c ""]
+                       [text text/c] ...) symbol?]{}
+@defproc[(text->keyword [#:before before text/c ""]
+                        [#:between between text/c ""]
+                        [#:after after text/c ""]
+                        [text text/c] ...) keyword?]{}
+)]{
+
+These functions convert text values to specific types.  They concatenate each
+@scheme[text] argument, adding @scheme[before] and @scheme[after] to the front
+and back of the result and @scheme[between] between each argument.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/text)
+(text->string #"concat" #'enate)
+(text->bytes #:between "-" 'concat #'#:enate)
+(text->symbol #:before "(" #:after ")" '#:concat #'"enate")
+(text->keyword #:before #'< #:between #'- #:after #'> "concat" #'#"enate")
+]
+
+}
+
+@deftogether[(
+@defproc[(text->string-literal [#:before before text/c ""]
+                               [#:between between text/c ""]
+                               [#:after after text/c ""]
+                               [#:stx stx (or/c syntax? false/c) #f]
+                               [text text/c] ...)
+         string-literal?]{}
+@defproc[(text->bytes-literal [#:before before text/c ""]
+                              [#:between between text/c ""]
+                              [#:after after text/c ""]
+                              [#:stx stx (or/c syntax? false/c) #f]
+                              [text text/c] ...)
+         bytes-literal?]{}
+@defproc[(text->identifier [#:before before text/c ""]
+                           [#:between between text/c ""]
+                           [#:after after text/c ""]
+                           [#:stx stx (or/c syntax? false/c) #f]
+                           [text text/c] ...)
+         identifier?]{}
+@defproc[(text->keyword-literal [#:before before text/c ""]
+                                [#:between between text/c ""]
+                                [#:after after text/c ""]
+                                [#:stx stx (or/c syntax? false/c) #f]
+                                [text text/c] ...)
+         keyword-literal?]{}
+)]{
+
+These functions convert text values to specific syntax object types, deriving
+syntax object properties from the @scheme[stx] argument.  They concatenate each
+@scheme[text] argument, adding @scheme[before] and @scheme[after] to the front
+and back of the result and @scheme[between] between each argument.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/text)
+(text->string-literal #"concat" #'enate)
+(text->bytes-literal #:between "-" 'concat #'#:enate)
+(text->identifier #:before "(" #:after ")"
+                   #:stx #'props
+                  '#:concat #'"enate")
+(text->keyword-literal #:before #'< #:between #'- #:after #'>
+                       #:stx #'props
+                       "concat" #'#"enate")
+]
+
+}
+
+@section{Text Comparisons}
+
+@deftogether[(
+@defproc[(text=? [one text/c] [two text/c]) boolean?]
+@defproc[(text<? [one text/c] [two text/c]) boolean?]
+@defproc[(text<=? [one text/c] [two text/c]) boolean?]
+@defproc[(text>? [one text/c] [two text/c]) boolean?]
+@defproc[(text>=? [one text/c] [two text/c]) boolean?]
+)]{
+
+These predicates compare the character content of two text values.  They are
+equivalent to:
+
+@schemeblock[
+(text=? one two) = (string=? (text->string one) (text->string two))
+(text<? one two) = (string<? (text->string one) (text->string two))
+(text<=? one two) = (string<=? (text->string one) (text->string two))
+(text>? one two) = (string>? (text->string one) (text->string two))
+(text>=? one two) = (string>=? (text->string one) (text->string two))
+]
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/text)
+(text=? #"x" #'y)
+(text<? #"x" #'y)
+(text<=? #"x" #'y)
+(text>? #"x" #'y)
+(text>=? #"x" #'y)
+]
+
+}

collects/unstable/cce/reference/values.scrbl

@@ -0,0 +1,86 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme unstable/cce/values))
+
+@title[#:style 'quiet #:tag "cce-values"]{Multiple Values}
+
+@defmodule[unstable/cce/values]
+
+This module provides tools for manipulating functions and expressions that
+produce multiple values.
+
+@defform[(values->list expr)]{
+
+Produces a list of the values returned by @scheme[expr].
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/values)
+(values->list (values 1 2 3))
+]
+
+}
+
+@defproc[(map2 [f (-> A ... (values B C))] [lst (listof A)] ...)
+         (values (listof B) (listof C))]{
+
+Produces a pair of lists of the respective values of @scheme[f] applied to the
+elements in @scheme[lst ...] sequentially.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/values)
+(map2 (lambda (x) (values (+ x 1) (- x 1))) (list 1 2 3))
+]
+
+}
+
+@defproc[(map/values [n natural-number/c]
+                     [f (-> A ... (values B_1 ... B_n))]
+                     [lst (listof A)]
+                     ...)
+         (values (listof B_1) ... (listof B_n))]{
+
+Produces lists of the respective values of @scheme[f] applied to the elements in
+@scheme[lst ...] sequentially.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/values)
+(map/values
+ 3
+ (lambda (x)
+   (values (+ x 1) x (- x 1)))
+ (list 1 2 3))
+]
+
+}
+
+@deftogether[(
+@defproc[(foldr/values [f (-> A ... B ... (values B ...))]
+                       [vs (list/c B ...)]
+                       [lst (listof A)]
+                       ...)
+         (values B ...)]
+@defproc[(foldl/values [f (-> A ... B ... (values B ...))]
+                       [vs (list/c B ...)]
+                       [lst (listof A)]
+                       ...)
+         (values B ...)]
+)]{
+
+These functions combine the values in the lists @scheme[lst ...] using the
+multiple-valued function @scheme[f]; @scheme[foldr/values] traverses the lists
+right to left and @scheme[foldl/values] traverses left to right.
+
+@defexamples[
+#:eval (evaluator 'unstable/cce/values)
+(define (add/cons a b c d)
+  (values (+ a c) (cons b d)))
+(foldr/values add/cons (list 0 null)
+              (list 1 2 3 4) (list 5 6 7 8))
+(foldl/values add/cons (list 0 null)
+              (list 1 2 3 4) (list 5 6 7 8))
+]
+
+}

collects/unstable/cce/reference/web.scrbl

@@ -0,0 +1,58 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          "../scribble.ss"
+          "eval.ss")
+@(require (for-label scheme xml unstable/cce/web))
+
+@title[#:style 'quiet #:tag "cce-web"]{XML and CSS}
+
+@defmodule[unstable/cce/web]
+
+This module provides tools for programmatic creation of static web pages.  It is
+based on the XML collection; see documentation for @scheme[xexpr?].
+
+@deftogether[(
+@defthing[css/c flat-contract?]
+@defproc[(css? [v any/c]) boolean?]
+)]{
+This contract and predicate pair recognizes CSS-expressions, which are
+described by the following grammar:
+
+@schemegrammar*[
+#:literals (cons list)
+[css (list style ...)]
+[style-def (cons selector (list property ...))]
+[property (list name value)]
+[selector text]
+[name text]
+[value text]
+]
+
+Here, @scheme[text] is any of the datatypes described in @secref["cce-text"].
+}
+
+@defthing[xexpr/c flat-contract?]{
+This flat contract corresponds to @scheme[xexpr?].  It is reprovided from
+@schememodname[xml].  In versions of PLT Scheme before the implementation of
+@scheme[xexpr/c], this module provides its own definition.
+}
+
+@deftogether[(
+@defproc[(write-css [css css/c] [out output-port? (current-output-port)])
+         void?]
+@defproc[(write-xexpr [css css/c] [out output-port? (current-output-port)])
+         void?]
+)]{
+These functions write CSS-expressions and
+X-expressions, respectively, to output ports, by their
+canonical text representations.
+}
+
+@deftogether[(
+@defproc[(create-stylesheet [file path-string?] [css css/c]) void?]
+@defproc[(create-webpage [file path-string?] [xexpr xexpr/c]) void?]
+)]{
+These functions write style sheets (represented as CSS-expressions) or
+webpages (represented as X-expressions) to files.
+}

collects/unstable/cce/regexp.ss

@@ -0,0 +1,59 @@
+#lang scheme/base
+
+(require scheme/list scheme/contract)
+
+;; regexp-or : String ... -> String
+;; Produces the regexp disjunction of several regexp-strings.
+(define (regexp-or . strings)
+  (apply string-append (add-between strings "|")))
+
+;; regexp-maybe : String ... -> String
+;; Matches the sequence of regexps, or nothing.
+(define (regexp-maybe . strings)
+  (format "(?:~a)?" (apply regexp-sequence strings)))
+
+;; regexp-star : String ... -> String
+;; Matches zero or more occurrences of the sequence of regexps.
+(define (regexp-star . strings)
+  (format "(?:~a)*" (apply regexp-sequence strings)))
+
+;; regexp-plus : String ... -> String
+;; Matches one or more occurrences of the sequence of regexps.
+(define (regexp-plus . strings)
+  (format "(?:~a)+" (apply regexp-sequence strings)))
+
+;; regexp-save : String ... -> String
+;; Matches and records the matched text of the sequence of regexps.
+(define (regexp-save . strings)
+  (format "(~a)" (apply regexp-sequence strings)))
+
+(define (regexp-group string)
+  (format "(?:~a)" string))
+
+;; regexp-sequence
+;; : String ... [#:start String #:end String #:between String] -> String
+(define (regexp-sequence #:start [start ""]
+                         #:end [end ""]
+                         #:between [between ""]
+                         . strings)
+  (apply string-append
+         (append (list start)
+                 (add-between (map regexp-group strings) between)
+                 (list end))))
+
+;; regexp-multi : String ... -> String
+;; Match a sequence of regexps in multi-line mode.
+(define (regexp-multi . strings)
+  (format "(?m:~a)" (apply regexp-sequence strings)))
+
+(provide/contract
+ [regexp-sequence
+  (->* [] [#:start string? #:end string? #:between string?]
+       #:rest (listof string?)
+       string?)]
+ [regexp-or (->* [string?] [] #:rest (listof string?) string?)]
+ [regexp-maybe (->* [string?] [] #:rest (listof string?) string?)]
+ [regexp-star (->* [string?] [] #:rest (listof string?) string?)]
+ [regexp-plus (->* [string?] [] #:rest (listof string?) string?)]
+ [regexp-save (->* [string?] [] #:rest (listof string?) string?)]
+ [regexp-multi (->* [string?] [] #:rest (listof string?) string?)])

collects/unstable/cce/require-provide.ss

@@ -0,0 +1,160 @@
+#lang scheme
+
+(require (for-syntax scheme/match
+                     scheme/require-transform
+                     scheme/provide-transform
+                     syntax/parse
+                     "syntax.ss")
+         "define.ss")
+
+(define-syntax (define-planet-package stx)
+  (syntax-parse stx
+    [(_ name:id pkg:id)
+     (syntax/loc stx
+       (define-syntax name
+         (make-require-transformer
+          (lambda (stx*)
+            (syntax-parse stx*
+              [(_) (expand-import (datum->syntax stx* (list #'planet #'pkg)))]
+              [(_ file:id)
+               (let* ([prefix (symbol->string (syntax-e #'pkg))]
+                      [suffix (symbol->string (syntax-e #'file))]
+                      [sym (string->symbol (string-append prefix "/" suffix))]
+                      [spec (datum->syntax stx* (list #'planet sym))])
+                 (expand-import spec))])))))]))
+
+(define-syntax (define-collection stx)
+  (syntax-parse stx
+    [(_ name:id collect:id)
+     #'(define-syntax name
+         (make-require-transformer
+          (lambda (stx*)
+            (syntax-parse stx*
+              [(_) (expand-import (datum->syntax stx* (syntax-e #'collect)))]
+              [(_ file:id)
+               (let* ([prefix (symbol->string (syntax-e #'collect))]
+                      [suffix (symbol->string (syntax-e #'file))]
+                      [sym (string->symbol (string-append prefix "/" suffix))]
+                      [spec (datum->syntax stx* sym)])
+                 (expand-import spec))]))))]))
+
+(define-syntax this-package-in
+  (make-require-transformer
+   (lambda (stx)
+     (syntax-parse stx
+       [(_ file:id)
+        (expand-import (make-planet-path stx #'file))]))))
+
+(define-syntax this-package-out
+  (make-provide-transformer
+   (lambda (stx modes)
+     (syntax-parse stx
+       [(_ file:id)
+        (expand-export
+         (datum->syntax
+          stx
+          (list #'all-from-out (make-planet-path stx #'file)))
+         modes)]))))
+
+(define-for-syntax (import->export i)
+  (make-export (import-local-id i)
+               (syntax-e (import-local-id i))
+               (import-mode i)
+               #f
+               (import-orig-stx i)))
+
+(define-syntax box-require
+  (make-require-transformer
+   (lambda (stx)
+     (syntax-parse stx
+       [(_ ibox spec:expr)
+        #:declare ibox (static box? "mutable box for expanded import specs")
+        (let-values ([(imports sources) (expand-import #'spec)])
+          (set-box! (syntax-local-value #'ibox) imports)
+          (values imports sources))]))))
+
+(define-syntax box-provide
+  (make-provide-transformer
+   (lambda (stx modes)
+     (syntax-parse stx
+       [(_ ibox)
+        #:declare ibox (static box? "mutable box for expanded import specs")
+        (map import->export (unbox (syntax-local-value #'ibox)))]))))
+
+(define-syntax-rule (require/provide spec ...)
+  (begin
+    (define-syntax imports (box #f))
+    (require (box-require imports (combine-in spec ...)))
+    (provide (box-provide imports))))
+
+(define-syntax (quote-require stx)
+  (syntax-parse stx
+    [(_ spec:expr ...)
+     (let*-values ([(imports sources)
+                    (expand-import (syntax/loc stx (combine-in spec ...)))])
+       (with-syntax ([(name ...) (map import-local-id imports)])
+         (syntax/loc stx '(name ...))))]))
+
+;; rename-import : Import Identifier -> Import
+;; Creates a new import that binds the given identifier, but otherwise acts as
+;; the original import.
+(define-for-syntax (rename-import i id)
+  (struct-copy import i [local-id id]))
+
+;; import->raw-require-spec : Import -> Syntax
+;; Constructs a raw-require-spec (suitable for #%require) that should have the
+;; same behavior as a require-spec that produces the given import.
+(define-for-syntax (import->raw-require-spec i)
+  (match i
+    [(struct import [local-id
+                     src-sym
+                     src-mod-path
+                     mode
+                     req-mode
+                     orig-mode
+                     orig-stx])
+     (datum->syntax
+      orig-stx
+      (list #'just-meta
+            req-mode
+            (list #'for-meta
+                  mode
+                  (list #'rename
+                        src-mod-path
+                        (syntax-local-introduce local-id)
+                        src-sym)))
+      orig-stx)]))
+
+;; (do-local-require rename spec ...)
+;; Lifts (require spec ...) to the (module) top level, and makes the imported
+;; bindings available in the current context via a renaming macro.
+(define-syntax (do-local-require stx)
+  (syntax-parse stx
+    [(_ rename:id spec:expr ...)
+     (let*-values ([(imports sources)
+                    (expand-import
+                     (datum->syntax
+                      stx
+                      (list* #'only-meta-in 0 (syntax->list #'(spec ...)))
+                      stx))]
+                   [(names) (map import-local-id imports)]
+                   [(reqd-names) 
+                    (let ([ctx (syntax-local-get-shadower (datum->syntax #f (gensym)))])
+                      (map (lambda (n) (datum->syntax ctx (syntax-e n) n)) names))]
+                   [(renamed-imports) (map rename-import imports reqd-names)]
+                   [(raw-specs) (map import->raw-require-spec renamed-imports)]
+                   [(lifts) (map syntax-local-lift-require raw-specs reqd-names)])
+       (with-syntax ([(name ...) names]
+                     [(lifted ...) lifts])
+         (syntax/loc stx (rename [name lifted] ...))))]))
+
+(define-syntax-rule (local-require spec ...)
+  (do-local-require define-renamings spec ...))
+
+(provide require/provide
+         do-local-require
+         local-require
+         quote-require
+         define-planet-package
+         define-collection
+         this-package-in)

collects/unstable/cce/sandbox.ss

@@ -0,0 +1,67 @@
+#lang scheme
+
+(require scheme/sandbox
+         "define.ss")
+
+(provide make-trusted-evaluator
+         make-trusted-module-evaluator
+         make-scribble-evaluator
+         make-scribble-module-evaluator
+         make-sandbox-namespace-specs)
+
+;; Needed for legacy versions of scheme/sandbox
+(define-if-unbound (call-with-trusted-sandbox-configuration thunk)
+  (parameterize ([sandbox-propagate-breaks    #t]
+                 [sandbox-override-collection-paths '()]
+                 [sandbox-security-guard      (current-security-guard)]
+                 [sandbox-make-inspector      current-inspector]
+                 [sandbox-make-logger         current-logger]
+                 [sandbox-eval-limits         #f])
+    (thunk)))
+
+(define make-trusted-evaluator
+  (make-keyword-procedure
+   (lambda (keys vals . args)
+     (call-with-trusted-sandbox-configuration
+      (lambda ()
+        (keyword-apply make-evaluator keys vals args))))))
+
+(define make-trusted-module-evaluator
+  (make-keyword-procedure
+   (lambda (keys vals . args)
+     (call-with-trusted-sandbox-configuration
+      (lambda ()
+        (keyword-apply make-module-evaluator keys vals args))))))
+
+(define make-scribble-evaluator
+  (make-keyword-procedure
+   (lambda (keys vals . args)
+     (parameterize ([sandbox-output 'string]
+                    [sandbox-error-output 'string])
+       (keyword-apply make-trusted-evaluator keys vals args)))))
+
+(define make-scribble-module-evaluator
+  (make-keyword-procedure
+   (lambda (keys vals . args)
+     (parameterize ([sandbox-output 'string]
+                    [sandbox-error-output 'string])
+       (keyword-apply make-trusted-module-evaluator keys vals args)))))
+
+(define (make-sandbox-namespace-specs make-ns . paths)
+
+  (define parent
+    (delay
+      (let* ([ns (make-ns)])
+        (parameterize ([current-namespace ns])
+          (for ([path (in-list paths)])
+            (dynamic-require path #f)))
+        ns)))
+
+  (define (make-child)
+    (let* ([ns (make-ns)])
+      (parameterize ([current-namespace ns])
+        (for ([path (in-list paths)])
+          (namespace-attach-module (force parent) path)))
+      ns))
+
+  (list make-child))

collects/unstable/cce/scribble.ss

@@ -0,0 +1,72 @@
+#lang scheme/base
+
+(require scribble/manual "sandbox.ss" "planet.ss"
+         (for-syntax scheme/base "syntax.ss"))
+
+(define-for-syntax (make-planet-paths stx ids)
+  (map (lambda (id) (make-planet-path stx id)) (syntax->list ids)))
+
+(define-syntax (defmodule/this-package stx)
+
+  (define (make-defmodule opt-name locals others)
+    (quasisyntax/loc stx
+      (defmodule
+        #,(make-planet-path stx opt-name)
+        #:use-sources
+        [#,@(make-planet-paths stx locals) #,@others])))
+
+  (syntax-case stx ()
+    [(_) (make-defmodule #f #'() #'())]
+    [(_ name) (make-defmodule #'name #'() #'())]
+    [(_ #:use-sources [local ...] [other ...])
+     (make-defmodule #f #'(local ...) #'(other ...))]
+    [(_ name #:use-sources [local ...] [other ...])
+     (make-defmodule #'name #'(local ...) #'(other ...))]))
+
+(define-syntax (defmodule*/no-declare/this-package stx)
+
+  (define (make-defmodule*/no-declare local-mods other-mods)
+    (quasisyntax/loc stx
+      (defmodule*/no-declare
+        [#,@(make-planet-paths stx local-mods) #,@other-mods])))
+
+  (syntax-case stx ()
+    [(_ [local-mod ...] [other-mod ...])
+     (make-defmodule*/no-declare #'(local-mod ...) #'(other-mod ...))]))
+
+(define-syntax (declare-exporting/this-package stx)
+
+  (define (make-declare-exporting local-mods other-mods local-srcs other-srcs)
+    (quasisyntax/loc stx
+      (declare-exporting
+       #,@(make-planet-paths stx local-mods) #,@other-mods
+       #:use-sources
+       [#,@(make-planet-paths stx local-srcs) #,@other-srcs])))
+
+  (syntax-case stx ()
+    [(_ [local-mod ...] [other-mod ...])
+     (make-declare-exporting #'(local-mod ...) #'(other-mod ...) #'() #'())]
+    [(_ [local-mod ...] [other-mod ...]
+        #:use-sources
+        [local-src ...] [other-src ...])
+     (make-declare-exporting #'(local-mod ...) #'(other-mod ...)
+                             #'(local-src ...) #'(other-src ...))]))
+
+(define-syntax (schememodname/this-package stx)
+
+  (define (make-schememodname id/f)
+    (quasisyntax/loc stx
+      (schememodname #,(make-planet-path stx id/f))))
+
+  (syntax-case stx ()
+    [(_) (make-schememodname #f)]
+    [(_ path) (make-schememodname #'path)]))
+
+(provide defmodule/this-package
+         defmodule*/no-declare/this-package
+         schememodname/this-package
+         declare-exporting/this-package
+         this-package-version-symbol
+         this-package-in
+         make-scribble-evaluator
+         make-scribble-module-evaluator)

collects/unstable/cce/set.ss

@@ -0,0 +1,292 @@
+#lang scheme
+
+(require "dict.ss")
+
+;; A Set is either a Dict or a struct with the prop:set property.
+;; A SetProperty is:
+;; (Vector (-> Set Any Any)
+;;         (Or (-> Set Any Void) #f)
+;;         (Or (-> Set Any Set) #f)
+;;         (Or (-> Set Any Void) #f)
+;;         (Or (-> Set Any Set) #f)
+;;         (-> Set ExactInteger)
+;;         (-> Set Sequence))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Set Property
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; set-property-guard : Any (List ...) -> Any
+;; Protects prop:set from bad inputs.
+(define (set-property-guard prop info)
+  (check-vector 'prop:set "property" prop 7)
+  (check-vector-element 'prop:set "property" prop 0
+                        check-procedure "contains?" 2)
+  (check-vector-element 'prop:set "property" prop 1
+                        check-optional "insert!" check-procedure 2)
+  (check-vector-element 'prop:set "property" prop 2
+                        check-optional "insert" check-procedure 2)
+  (check-vector-element 'prop:set "property" prop 3
+                        check-optional "remove!" check-procedure 2)
+  (check-vector-element 'prop:set "property" prop 4
+                        check-optional "remove" check-procedure 2)
+  (check-vector-element 'prop:set "property" prop 5
+                        check-procedure "count" 1)
+  (check-vector-element 'prop:set "property" prop 6
+                        check-procedure "to-sequence" 1)
+  prop)
+
+(define-values [ prop:set set-struct? get ]
+  (make-struct-type-property 'set set-property-guard))
+
+(define (prop-contains? prop) (vector-ref prop 0))
+(define (prop-insert! prop) (vector-ref prop 1))
+(define (prop-insert prop) (vector-ref prop 2))
+(define (prop-remove! prop) (vector-ref prop 3))
+(define (prop-remove prop) (vector-ref prop 4))
+(define (prop-count prop) (vector-ref prop 5))
+(define (prop-to-sequence prop) (vector-ref prop 6))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Core Functions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (set? set)
+  (or (set-struct? set)
+      (dict? set)))
+
+(define (set-can-insert? set)
+  (if (set-struct? set)
+    (procedure? (prop-insert (get set)))
+    (dict-can-functional-set? set)))
+
+(define (set-can-remove? set)
+  (if (set-struct? set)
+    (procedure? (prop-remove (get set)))
+    (and (dict-can-functional-set? set)
+         (dict-can-remove-keys? set))))
+
+(define (set-can-insert!? set)
+  (if (set-struct? set)
+    (procedure? (prop-insert! (get set)))
+    (dict-mutable? set)))
+
+(define (set-can-remove!? set)
+  (if (set-struct? set)
+    (procedure? (prop-remove! (get set)))
+    (and (dict-mutable? set)
+         (dict-can-remove-keys? set))))
+
+(define (set-contains? set x)
+  (if (set-struct? set)
+    ((prop-contains? (get set)) set x)
+    (dict-has-key? set x)))
+
+(define (set-insert! set x)
+  (if (set-struct? set)
+    ((prop-insert! (get set)) set x)
+    (dict-set! set x null)))
+
+(define (set-insert set x)
+  (if (set-struct? set)
+    ((prop-insert (get set)) set x)
+    (dict-set set x null)))
+
+(define (set-remove! set x)
+  (if (set-struct? set)
+    ((prop-remove! (get set)) set x)
+    (dict-remove! set x)))
+
+(define (set-remove set x)
+  (if (set-struct? set)
+    ((prop-remove (get set)) set x)
+    (dict-remove set x)))
+
+(define (set-count set)
+  (if (set-struct? set)
+    ((prop-count (get set)) set)
+    (dict-count set)))
+
+(define (in-set set)
+  (if (set-struct? set)
+    ((prop-to-sequence (get set)) set)
+    (in-dict-keys set)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Derived Functions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (set->list set)
+  (for/list ([elem (in-set set)]) elem))
+
+(define (set-empty? set)
+  (= (set-count set) 0))
+
+(define (set #:weak? [weak? #f]
+             #:mutable? [mutable? weak?]
+             #:compare [compare 'equal]
+             . elements)
+  (list->set elements #:mutable? mutable? #:weak? weak? #:compare compare))
+
+(define (list->set elems
+                   #:weak? [weak? #f]
+                   #:mutable? [mutable? weak?]
+                   #:compare [compare 'equal])
+  (make-dict (for/list ([e (in-list elems)]) (cons e null))
+             #:mutable? mutable? #:weak? weak? #:compare compare))
+
+(define (empty-set #:weak? [weak? #f]
+                   #:mutable? [mutable? weak?]
+                   #:compare [compare 'equal])
+  (empty-dict #:mutable? mutable? #:weak? weak? #:compare compare))
+
+(define (custom-set #:compare compare
+                    #:hash [hash (lambda (x) 0)]
+                    #:hash2 [hash2 (lambda (x) 0)]
+                    #:weak? [weak? #f]
+                    #:mutable? [mutable? weak?]
+                    . elems)
+  (let* ([s (custom-dict compare hash hash2 #:mutable? mutable? #:weak? weak?)])
+    (if mutable?
+      (begin0 s
+        (for ([elem (in-list elems)]) (set-insert! s elem)))
+      (for/fold ([s s]) ([elem (in-list elems)])
+        (set-insert s elem)))))
+
+(define (set=? one two)
+  (and (subset? one two)
+       (subset? two one)))
+
+(define (proper-subset? one two)
+  (and (subset? one two)
+       (not (subset? two one))))
+
+(define (subset? one two)
+  (for/and ([elem (in-set one)])
+    (set-contains? two elem)))
+
+(define (set-union set . rest)
+  (for*/fold ([one set]) ([two (in-list rest)] [elem (in-set two)])
+    (set-insert one elem)))
+
+(define (set-intersection set . rest)
+  (for*/fold ([one set]) ([two (in-list rest)] [elem (in-set one)]
+                          #:when (not (set-contains? two elem)))
+    (set-remove one elem)))
+
+(define (set-difference set . rest)
+  (for*/fold ([one set]) ([two (in-list rest)] [elem (in-set one)]
+                          #:when (set-contains? two elem))
+    (set-remove one elem)))
+
+(define (set-exclusive-or set . rest)
+  (for*/fold ([one set]) ([two (in-list rest)] [elem (in-set two)])
+    (if (set-contains? one elem)
+      (set-remove one elem)
+      (set-insert one elem))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Generic Checks
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (check-vector caller desc value size)
+  (unless (vector? value)
+    (error caller "expected ~a to be a vector; got: ~e" desc value))
+  (unless (= (vector-length value) size)
+    (error caller
+           "expected ~a to have length ~a; got length ~a in: ~e"
+           desc size (vector-length value) value)))
+
+(define (check-vector-element caller desc value index check part . args)
+  (apply check
+         caller
+         (format "~a element ~a (~a)" desc index part)
+         (vector-ref value index)
+         args))
+
+(define (check-procedure caller desc value arity)
+  (unless (procedure? value)
+    (error caller "expected ~a to be a procedure; got: ~e" desc value))
+  (unless (procedure-arity-includes? value arity)
+    (error caller
+           "expected ~a to accept ~a arguments; got: ~e"
+           desc
+           arity
+           value)))
+
+(define (check-optional caller desc value check . args)
+  (when value (apply check caller desc value args)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Exports
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide/contract
+ [set? (-> any/c boolean?)]
+ [set-empty? (-> any/c boolean?)]
+ [set
+  (->* []
+       [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)]
+       #:rest list?
+       set?)]
+ [list->set
+  (->* [list?]
+       [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)]
+       set?)]
+ [empty-set
+  (->* []
+       [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)]
+       set?)]
+ [custom-set
+  (->* [#:compare (-> any/c any/c any/c)]
+       [#:hash
+        (-> any/c exact-integer?)
+        #:hash2
+        (-> any/c exact-integer?)
+        #:mutable? boolean?
+        #:weak? boolean?]
+       #:rest list?
+       set?)]
+ [set->list (-> set? list?)]
+ [set-contains? (-> set? any/c boolean?)]
+ [set-insert (-> set? any/c any/c)]
+ [set-remove (-> set? any/c set?)]
+ [set-insert! (-> set? any/c void?)]
+ [set-remove! (-> set? any/c void?)]
+ [set-can-insert? (-> set? boolean?)]
+ [set-can-remove? (-> set? boolean?)]
+ [set-can-insert!? (-> set? boolean?)]
+ [set-can-remove!? (-> set? boolean?)]
+ [set-count (-> set? exact-nonnegative-integer?)]
+ [in-set (-> set? sequence?)]
+ [set=? (-> set? set? boolean?)]
+ [subset? (-> set? set? boolean?)]
+ [proper-subset? (-> set? set? boolean?)]
+ [set-union
+  (->* [(and/c set? set-can-insert?)] []
+       #:rest (listof set?)
+       set?)]
+ [set-intersection
+  (->* [(and/c set? set-can-remove?)] []
+       #:rest (listof set?)
+       set?)]
+ [set-difference
+  (->* [(and/c set? set-can-remove?)] []
+       #:rest (listof set?)
+       set?)]
+ [set-exclusive-or
+  (->* [(and/c set? set-can-insert? set-can-remove?)] []
+       #:rest (listof set?)
+       set?)]
+ [prop:set struct-type-property?]
+ )

collects/unstable/cce/slideshow.ss

@@ -0,0 +1,307 @@
+#lang scheme
+
+(require slideshow/base slideshow/pict
+         scheme/splicing scheme/stxparam scheme/gui/base
+         "define.ss")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Font Controls
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-with-parameter with-size current-font-size)
+(define-syntax-rule (with-scale scale expr)
+  (with-size (inexact->exact (ceiling (* scale (current-font-size)))) expr))
+(define-syntax-rule (define-scale name scale)
+  (define-syntax-rule (name expr) (with-scale scale expr)))
+(define-scale big 3/2)
+(define-scale small 2/3)
+
+(define-with-parameter with-font current-main-font)
+(define-syntax-rule (with-style style expr)
+  (with-font (cons style (current-main-font)) expr))
+(define-syntax-rule (define-style name style)
+  (define-syntax-rule (name expr) (with-style style expr)))
+(define-style bold 'bold)
+(define-style italic 'italic)
+(define-style subscript 'subscript)
+(define-style superscript 'superscript)
+(define-style caps 'caps)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Picture Manipulation
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (fill pict w h)
+  (cc-superimpose
+   pict
+   (blank (or w (pict-width pict))
+          (or h (pict-height pict)))))
+
+(define (color c p) (colorize p c))
+
+(define color/c
+  (or/c string? ;; might be faster
+        ;;(and/c string? (lambda (s) (send the-color-database find-color s)))
+        (is-a?/c color%)
+        (list/c byte? byte? byte?)))
+
+(define-syntax-rule (define-colors name ...)
+  (begin (define (name pict) (color (symbol->string 'name) pict)) ...))
+
+(define-colors
+  red orange yellow green blue purple
+  black brown gray white cyan magenta)
+
+(define (light c) (scale-color 2 c))
+(define (dark c) (scale-color 1/2 c))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Slide / Paragraph Manipulation
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-with-parameter column current-para-width)
+
+(define (columns . picts)
+  (apply hc-append gap-size (map baseless picts)))
+
+(define (column-size n [r (/ n)])
+  (* r (- (current-para-width) (* (sub1 n) gap-size))))
+
+(define-syntax-rule (two-columns a b)
+  (columns (column (column-size 2) a)
+           (column (column-size 2) b)))
+
+(define (mini-slide . picts)
+  (apply vc-append gap-size picts))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Simple Tables
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define =!
+  (case-lambda
+    [(n) n]
+    [(n . ns)
+     (if (apply = n ns)
+         n
+         (error '=! "not all equal: ~a" (cons n ns)))]))
+
+(define (elem->pict elem)
+  (if (string? elem) (t elem) elem))
+
+(define (tabular #:gap [gap gap-size]
+                 #:vgap [vgap gap]
+                 #:hgap [hgap gap]
+                 #:align [align lbl-superimpose]
+                 #:halign [halign align]
+                 #:valign [valign align]
+                 . cells)
+  (let* ([rows (length cells)]
+         [cols (apply =! (map length cells))]
+         [picts (map elem->pict (append* cells))]
+         [haligns (for/list ([i (in-range 0 cols)]) halign)]
+         [valigns (for/list ([i (in-range 0 rows)]) valign)]
+         [hseps (for/list ([i (in-range 1 cols)]) hgap)]
+         [vseps (for/list ([i (in-range 1 rows)]) vgap)])
+    (table cols picts haligns valigns hseps vseps)))
+
+(define (matrixof c)
+  (and/c (listof (listof c))
+         (flat-named-contract "matrix"
+           (match-lambda
+             [(list) #t]
+             [(list _) #t]
+             [(list xs ...) (apply = (map length xs))]))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Space-smart picture selection
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax-parameter pict-combine #'ltl-superimpose)
+
+(define-syntax-rule (with-pict-combine combine body ...)
+  (splicing-syntax-parameterize
+   ([pict-combine #'combine])
+   body ...))
+
+(define-syntax (pict-if stx)
+  (syntax-case stx ()
+    [(_ #:combine combine test success failure)
+     (syntax/loc stx
+       (let* ([result test])
+         (combine (show success result)
+                  (hide failure result))))]
+    [(_ test success failure)
+     (quasisyntax/loc stx
+       (pict-if #:combine #,(syntax-parameter-value #'pict-combine)
+                test success failure))]))
+
+(define-syntax (pict-cond stx)
+  (syntax-case stx (else)
+    [(_ #:combine combine [test expr] ... [else default])
+     (with-syntax ([(pict ...) (generate-temporaries #'(expr ...))])
+       (syntax/loc stx
+         (let ([pict expr] ... [final default])
+           (combine (cond [test pict] ... [else final])
+                    (ghost pict) ... (ghost final)))))]
+    [(_ #:combine combine [test pict] ...)
+     (syntax/loc stx
+       (pict-cond #:combine combine [test pict] ... [else (blank 0 0)]))]
+    [(_ [test expr] ...)
+     (quasisyntax/loc stx
+       (pict-cond #:combine #,(syntax-parameter-value #'pict-combine)
+                  [test expr] ...))]))
+
+(define-syntax (pict-case stx)
+  (syntax-case stx (else)
+    [(_ test #:combine combine [literals expr] ... [else default])
+     (with-syntax ([(pict ...) (generate-temporaries #'(expr ...))])
+       (syntax/loc stx
+         (let ([pict expr] ... [final default])
+           (combine (case test [literals pict] ... [else final])
+                    (ghost pict) ... (ghost final)))))]
+    [(_ test #:combine combine [literals expr] ...)
+     (syntax/loc stx
+       (pict-case #:combine combine [literals expr] ... [else (blank 0 0)]))]
+    [(_ test [literals expr] ...)
+     (quasisyntax/loc stx
+       (pict-case test #:combine #,(syntax-parameter-value #'pict-combine)
+                  [literals expr] ...))]))
+
+(define-syntax (pict-match stx)
+  (syntax-case stx ()
+    [(_ test #:combine combine [pattern expr] ...)
+     (with-syntax ([(pict ...) (generate-temporaries #'(expr ...))])
+       (syntax/loc stx
+         (let ([pict expr] ...)
+           (combine (match test [pattern pict] ... [_ (blank 0 0)])
+                    (ghost pict) ...))))]
+    [(_ test [pattern expr] ...)
+     (quasisyntax/loc stx
+       (pict-match test #:combine #,(syntax-parameter-value #'pict-combine)
+                   [pattern expr] ...))]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Slide Staging
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-for-syntax (stage-keyword stx)
+  (raise-syntax-error #f "not in the body of a staged slide" stx))
+
+(define-syntax-parameter stage stage-keyword)
+(define-syntax-parameter stage-name stage-keyword)
+
+(define-syntax (staged stx)
+  (syntax-case stx ()
+    [(_ [name ...] body ...)
+     (let* ([ids (syntax->list #'(name ...))])
+
+       (for ([id (in-list ids)] #:when (not (identifier? id)))
+         (raise-syntax-error #f "expected an identifier" stx id))
+
+       (with-syntax ([(num ...)
+                      (for/list ([i (in-naturals 1)] [id (in-list ids)])
+                        (datum->syntax #'here i id))])
+
+         (syntax/loc stx
+           (let* ([name num] ...)
+             (define (staged-computation number symbol)
+               (syntax-parameterize
+                   ([stage (make-rename-transformer #'number)]
+                    [stage-name (make-rename-transformer #'symbol)])
+                 (block body ...)))
+             (begin (staged-computation name 'name) ...)))))]))
+
+(define-syntax-rule (slide/stage [name ...] body ...)
+  (staged [name ...] (slide body ...)))
+
+(define-syntax-rule (before name) (< stage name))
+(define-syntax-rule (before/at name) (<= stage name))
+(define-syntax-rule (at/after name) (>= stage name))
+(define-syntax-rule (after name) (> stage name))
+(define-syntax-rule (before/after name) (not (= stage name)))
+(define-syntax-rule (at name ...) (or (= stage name) ...))
+
+(define (hide pict [hide? #t])
+  (if hide? (ghost pict) pict))
+
+(define (show pict [show? #t])
+  (if show? pict (ghost pict)))
+
+(define (shade pict [shade? #t] #:ratio [ratio 0.5])
+  (if shade? (cellophane pict ratio) pict))
+
+(define (strike pict [strike? #t])
+  (if strike?
+      (pin-over pict
+                0
+                (/ (pict-height pict) 2)
+                (pip-line (pict-width pict) 0 0))
+      pict))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Exports
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide with-size with-scale big small
+         with-font with-style bold italic subscript superscript caps)
+
+(provide/contract
+ [color/c flat-contract?]
+ [red     (-> pict? pict?)]
+ [orange  (-> pict? pict?)]
+ [yellow  (-> pict? pict?)]
+ [green   (-> pict? pict?)]
+ [blue    (-> pict? pict?)]
+ [purple  (-> pict? pict?)]
+ [black   (-> pict? pict?)]
+ [brown   (-> pict? pict?)]
+ [gray    (-> pict? pict?)]
+ [white   (-> pict? pict?)]
+ [cyan    (-> pict? pict?)]
+ [magenta (-> pict? pict?)]
+ [light (-> color/c color/c)]
+ [dark (-> color/c color/c)]
+ [color (-> color/c pict? pict?)]
+ [fill
+  (-> pict?
+      (or/c (real-in 0 +inf.0) #f)
+      (or/c (real-in 0 +inf.0) #f)
+      pict?)])
+
+(provide column columns column-size two-columns mini-slide)
+
+(provide/contract
+ [tabular (->* []
+               [#:gap natural-number/c
+                #:hgap natural-number/c
+                #:vgap natural-number/c
+                #:align (->* [] [] #:rest (listof pict?) pict?)
+                #:halign (->* [] [] #:rest (listof pict?) pict?)
+                #:valign (->* [] [] #:rest (listof pict?) pict?)]
+               #:rest (matrixof (or/c string? pict?))
+               pict?)])
+
+(provide/contract
+ [hide (->* [pict?] [any/c] pict?)]
+ [show (->* [pict?] [any/c] pict?)]
+ [strike (->* [pict?] [any/c] pict?)]
+ [shade (->* [pict?] [any/c #:ratio (real-in 0 1)] pict?)])
+(provide staged slide/stage stage stage-name
+         before at after before/at at/after except
+         pict-if pict-cond pict-case pict-match
+         pict-combine with-pict-combine)

collects/unstable/cce/syntax.ss

@@ -0,0 +1,278 @@
+#lang scheme/base
+(require scheme/path
+         scheme/match
+         scheme/contract
+         scheme/vector
+         scheme/list
+         syntax/stx
+         syntax/kerncase
+         setup/main-collects
+         planet/planet-archives
+         (for-template scheme/base)
+         (for-syntax scheme/base)
+         (for-label scheme)
+         "private/syntax-core.ss"
+         "private/define-core.ss"
+         (for-template "private/define-core.ss")
+         "contract.ss"
+         "text.ss")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  SYNTAX OBJECTS
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Syntax Locations
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (syntax-source-directory stx)
+  (match (syntax-source stx)
+    [(? path-string? source)
+     (let-values ([(base file dir?) (split-path source)])
+       (and (path? base)
+            (path->complete-path base
+                                 (or (current-load-relative-directory)
+                                     (current-directory)))))]
+    [_ #f]))
+
+(define (syntax-source-file-name stx)
+  (match (syntax-source stx)
+    [(? path-string? f)
+     (let-values ([(base file dir?) (split-path f)]) file)]
+    [_ #f]))
+
+(define (syntax-source-planet-package stx)
+  (let* ([dir (syntax-source-directory stx)])
+    (and dir (this-package-version/proc dir))))
+
+(define (syntax-source-planet-package-owner stx)
+  (let* ([pkg (syntax-source-planet-package stx)])
+    (and pkg (pd->owner pkg))))
+
+(define (syntax-source-planet-package-name stx)
+  (let* ([pkg (syntax-source-planet-package stx)])
+    (and pkg (pd->name pkg))))
+
+(define (syntax-source-planet-package-major stx)
+  (let* ([pkg (syntax-source-planet-package stx)])
+    (and pkg (pd->maj pkg))))
+
+(define (syntax-source-planet-package-minor stx)
+  (let* ([pkg (syntax-source-planet-package stx)])
+    (and pkg (pd->min pkg))))
+
+(define (syntax-source-planet-package-symbol stx [suffix #f])
+  (match (syntax-source-planet-package stx)
+    [(list owner name major minor)
+     (string->symbol
+      (format "~a/~a:~a:~a~a"
+              owner
+              (regexp-replace "\\.plt$" name "")
+              major
+              minor
+              (if suffix (text->string "/" suffix) "")))]
+    [#f #f]))
+
+(define (make-planet-path stx id/f)
+  (datum->syntax
+   stx
+   (list #'planet (syntax-source-planet-package-symbol stx id/f))
+   (or id/f stx)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Transformer patterns:
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define ((redirect-transformer id) stx)
+  (cond
+   [(identifier? stx) id]
+   [(and (stx-pair? stx) (identifier? (stx-car stx)))
+    (to-syntax (cons id (stx-cdr stx)) #:stx stx)]
+   [else
+    (syntax-error
+     stx
+     "expected an identifier (alone or in application position); cannot redirect to ~a"
+     (syntax-e id))]))
+
+(define (head-expand stx [stop-ids null])
+  (local-expand stx
+                (syntax-local-context)
+                (append stop-ids (full-kernel-form-identifier-list))
+                #f))
+
+(define-syntax-if-unbound quote-syntax/prune
+  (make-rename-transformer #'quote-syntax))
+
+(define (full-kernel-form-identifier-list)
+  (remove-duplicates
+   (list* (quote-syntax/prune #%require)
+          (quote-syntax/prune #%provide)
+          (quote-syntax/prune module)
+          (quote-syntax/prune #%plain-module-begin)
+          (kernel-form-identifier-list))
+   free-identifier=?))
+
+(define (quote-transformer datum)
+  #`(quasiquote
+     #,(let loop ([datum datum])
+         (cond
+          [(syntax? datum) #`(unquote (quote-syntax #,datum))]
+          [(pair? datum) #`#,(cons (loop (car datum)) (loop (cdr datum)))]
+          [(vector? datum) #`#,(vector-map loop datum)]
+          [(box? datum) #`#,(box (loop (unbox datum)))]
+          [(hash? datum)
+           #`#,((cond [(hash-eqv? datum) make-immutable-hasheqv]
+                      [(hash-eq? datum) make-immutable-hasheq]
+                      [else make-immutable-hash])
+                (hash-map datum (lambda (k v) (cons k (loop v)))))]
+          [(prefab-struct-key datum) =>
+           (lambda (key)
+             #`#,(apply make-prefab-struct
+                        key
+                        (for/list ([i (in-vector (struct->vector datum) 1)])
+                          (loop i))))]
+          [else #`#,datum]))))
+
+(define trampoline-prompt-tag
+  (make-continuation-prompt-tag 'trampoline))
+
+(define ((trampoline-transformer transform) stx)
+
+  (define intro (make-syntax-introducer))
+
+  (define (body)
+    (syntax-local-introduce
+     (intro
+      (transform (trampoline-evaluator intro)
+                 intro
+                 (intro (syntax-local-introduce stx))))))
+
+  (call-with-continuation-prompt body trampoline-prompt-tag))
+
+(define ((trampoline-evaluator intro) stx)
+
+  (define ((wrap continue))
+    (call-with-continuation-prompt continue trampoline-prompt-tag))
+
+  (define ((expander continue))
+    #`(begin #,(syntax-local-introduce (intro stx))
+             (#%trampoline #,(wrap continue))))
+
+  (define (body continue)
+    (abort-current-continuation trampoline-prompt-tag (expander continue)))
+
+  (call-with-composable-continuation body trampoline-prompt-tag)
+  (void))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; From planet/util:
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (this-package-version/proc srcdir)
+  (let* ([package-roots (get-all-planet-packages)]
+         [thepkg (ormap (predicate->projection (contains-dir? srcdir))
+                        package-roots)])
+    (and thepkg (archive-retval->simple-retval thepkg))))
+
+;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
+(define (predicate->projection pred) (lambda (x) (if (pred x) x #f)))
+
+;; contains-dir? : path -> pkg -> boolean
+(define ((contains-dir? srcdir) alleged-superdir-pkg)
+  (let* ([nsrcdir (normalize-path srcdir)]
+         [nsuperdir (normalize-path (car alleged-superdir-pkg))]
+         [nsrclist (explode-path nsrcdir)]
+         [nsuperlist (explode-path nsuperdir)])
+    (list-prefix? nsuperlist nsrclist)))
+
+(define (list-prefix? sup sub)
+  (let loop ([sub sub]
+             [sup sup])
+    (cond
+      [(null? sup) #t]
+      [(equal? (car sup) (car sub))
+       (loop (cdr sub) (cdr sup))]
+      [else #f])))
+
+(define (archive-retval->simple-retval p)
+  (list-refs p '(1 2 4 5)))
+
+(define-values (pd->owner pd->name pd->maj pd->min)
+  (apply values (map (lambda (n) (lambda (l) (list-ref l n))) '(0 1 2 3))))
+
+(define (list-refs p ns)
+  (map (lambda (n) (list-ref p n)) ns))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  EXPORTS
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define stx/f (or/c syntax? #f))
+
+(define nat/f (or/c nat/c #f))
+(define pos/f (or/c pos/c #f))
+
+(define src-list/c   (list/c   any/c pos/f nat/f pos/f nat/f))
+(define src-vector/c (vector/c any/c pos/f nat/f pos/f nat/f))
+
+(define src/c
+  (or/c srcloc?
+        syntax?
+        src-list/c
+        src-vector/c
+        #f))
+
+(provide/contract
+
+ [src/c flat-contract?]
+ [src-known? (-> src/c boolean?)]
+ [src->srcloc  (->* [] [] #:rest (listof src/c) srcloc?)]
+ [src->list (->* [] [] #:rest (listof src/c) src-list/c)]
+ [src->vector (->* [] [] #:rest (listof src/c) src-vector/c)]
+ [src->syntax (->* [] [] #:rest (listof src/c) syntax?)]
+
+ [syntax-datum/c (-> flat-contract? flat-contract?)]
+ [syntax-listof/c (-> flat-contract? flat-contract?)]
+ [syntax-list/c
+  (->* [] [] #:rest (listof flat-contract?) flat-contract?)]
+
+ [syntax-map (-> (-> syntax? any/c) (syntax-listof/c any/c) (listof any/c))]
+ [to-syntax
+  (->* [any/c]
+       [#:stx stx/f #:src src/c #:ctxt stx/f #:prop stx/f #:cert stx/f]
+       syntax?)]
+ [to-datum (-> any/c (not/c syntax?))]
+
+ [syntax-source-file-name (-> syntax? (or/c path? #f))]
+ [syntax-source-directory (-> syntax? (or/c path? #f))]
+ [syntax-source-planet-package
+  (-> syntax? (or/c (list/c string? string? nat/c nat/c) #f))]
+ [syntax-source-planet-package-owner (-> syntax? (or/c string? #f))]
+ [syntax-source-planet-package-name (-> syntax? (or/c string? #f))]
+ [syntax-source-planet-package-major (-> syntax? (or/c nat/c #f))]
+ [syntax-source-planet-package-minor (-> syntax? (or/c nat/c #f))]
+ [syntax-source-planet-package-symbol
+  (->* [syntax?] [(or/c text? #f)] (or/c symbol? #f))]
+ [make-planet-path (-> syntax? (or/c identifier? #f) syntax?)]
+
+ [trampoline-transformer
+  (-> (-> (-> syntax? void?) (-> syntax? syntax?) syntax? syntax?)
+      (-> syntax? syntax?))]
+ [quote-transformer (-> any/c syntax?)]
+ [redirect-transformer (-> identifier? (-> syntax? syntax?))]
+ [head-expand (->* [syntax?] [(listof identifier?)] syntax?)]
+ [full-kernel-form-identifier-list (-> (listof identifier?))]
+
+ [current-syntax (parameter/c (or/c syntax? false/c))]
+ [syntax-error (->* [syntax? string?]
+                    [#:name (or/c text? #f)]
+                    #:rest list?
+                    none/c)])
+
+(provide with-syntax* syntax-list)

collects/unstable/cce/test/checks.ss

@@ -0,0 +1,79 @@
+#lang scheme
+
+(require scheme/pretty
+         srfi/67
+         "../require-provide.ss")
+
+(require/provide schemeunit schemeunit/text-ui)
+
+(provide (all-defined-out))
+
+(define-syntax test
+  (syntax-rules ()
+    [(_ term) (test-case (pretty-format 'term) term)]
+    [(_ term ...) (test-case (pretty-format '(begin term ...)) term ...)]))
+
+(define-syntax-rule (test-ok body ...)
+  (test (check-ok body ...)))
+
+(define-syntax-rule (test-bad body ...)
+  (test (check-bad body ...)))
+
+(define-syntax-rule (with/c c e)
+  (let () (with-contract value ([value c]) (define value e)) value))
+
+(define-syntax-rule (check-ok body ...)
+  (check-not-exn (lambda () body ...)))
+
+(define-syntax-rule (check-bad body ...)
+  (check-exn exn:fail:contract? (lambda () body ...)))
+
+(define-check (check-not compare actual expected)
+  (with-check-info*
+   (list (make-check-info 'comparison compare)
+         (make-check-actual actual)
+         (make-check-expected expected))
+   (lambda ()
+     (let* ([result (compare actual expected)])
+       (when result
+         (with-check-info*
+          (list (make-check-info 'result result))
+          (lambda () (fail-check))))))))
+
+(define (check/sort actual expected
+                    #:< [<< (<? default-compare)]
+                    #:= [== equal?])
+  (with-check-info*
+   (list (make-check-name 'check/sort)
+         (make-check-info '< <<)
+         (make-check-info '= ==)
+         (make-check-info 'actual actual)
+         (make-check-info 'expected expected))
+   (lambda ()
+     (let* ([actual-sorted (sort actual <<)]
+            [actual-length (length actual-sorted)]
+            [expected-sorted (sort expected <<)]
+            [expected-length (length expected-sorted)])
+       (with-check-info*
+        (list (make-check-info 'actual-sorted actual-sorted)
+              (make-check-info 'expected-sorted expected-sorted))
+        (lambda ()
+          (unless (= actual-length expected-length)
+            (with-check-info*
+             (list (make-check-message
+                    (format "expected ~a elements, but got ~a"
+                            expected-length actual-length)))
+             (lambda () (fail-check))))
+          (let*-values
+              ([(actuals expecteds)
+                (for/lists
+                    [actuals expecteds]
+                    ([actual (in-list actual-sorted)]
+                     [expected (in-list actual-sorted)]
+                     #:when (not (== actual expected)))
+                  (values actual expected))])
+            (unless (and (null? actuals) (null? expecteds))
+              (with-check-info*
+               (list (make-check-info 'actual-failed actuals)
+                     (make-check-info 'expected-failed expecteds))
+               (lambda () (fail-check)))))))))))

collects/unstable/cce/test/test-class.ss

@@ -0,0 +1,97 @@
+#lang scheme
+
+(require "checks.ss"
+         "../class.ss")
+
+(provide class-suite)
+
+(define class-suite
+  (test-suite "class.ss"
+
+    (test-suite "Predicates and Contracts"
+
+      (test-suite "class-or-interface/c"
+        (test (check-ok (with/c class-or-interface/c object%)))
+        (test (check-ok (with/c class-or-interface/c (interface ()))))
+        (test (check-bad (with/c class-or-interface/c (new object%)))))
+
+      (test-suite "object-provides/c"
+        (test-ok (with/c (object-provides/c) (new object%)))
+        (test-ok (define c% (class object% (super-new)))
+                 (with/c (object-provides/c c%) (new c%)))
+        (test-ok (define i<%> (interface ()))
+                 (define c% (class* object% (i<%>) (super-new)))
+                 (with/c (object-provides/c i<%>) (new c%)))
+        (test-bad (define c% (class object% (super-new)))
+                  (with/c (object-provides/c c%) (new object%)))
+        (test-bad (define i<%> (interface ()))
+                  (with/c (object-provides/c i<%>) (new object%)))
+        (test-bad (with/c (object-provides/c) object%)))
+
+      (test-suite "class-provides/c"
+        (test-ok (with/c (class-provides/c) object%))
+        (test-ok (define c% (class object% (super-new)))
+                 (with/c (class-provides/c c%) c%))
+        (test-ok (define c% (class object% (super-new)))
+                 (with/c (class-provides/c object%) c%))
+        (test-ok (define i<%> (interface ()))
+                 (define c% (class* object% (i<%>) (super-new)))
+                 (with/c (class-provides/c i<%>) c%))
+        (test-bad (define c% (class object% (super-new)))
+                  (with/c (class-provides/c c%) object%))
+        (test-bad (define i<%> (interface ()))
+                  (with/c (class-provides/c i<%>) object%)))
+
+      (test-suite "mixin-provides/c"
+        (test-ok ((with/c (mixin-provides/c [] []) values) object%))
+        (test-bad (define i<%> (interface ()))
+                  ((with/c (mixin-provides/c [i<%>] []) values) object%))
+        (test-bad (define i<%> (interface ()))
+                  ((with/c (mixin-provides/c [i<%>] []) values) object%))))
+
+    (test-suite "Mixins"
+
+      (test-suite "ensure-interface"
+        (test-case "implementation unchanged"
+          (let* ([i<%> (interface ())]
+                 [c% (class* object% (i<%>) (super-new))]
+                 [mx (lambda (parent%) (class* parent% (i<%>) (super-new)))])
+            (check-eq? (ensure-interface i<%> mx c%) c%)))
+        (test-case "non-implementation subclassed"
+          (let* ([i<%> (interface ())]
+                 [c% (class object% (super-new))]
+                 [mx (lambda (parent%) (class* parent% (i<%>) (super-new)))]
+                 [result (ensure-interface i<%> mx c%)])
+            (check-pred class? result)
+            (check subclass? result c%)
+            (check implementation? result i<%>)))))
+
+    (test-suite "Messages"
+
+      (test-suite "send+"
+        (test-case "no messages"
+          (let* ([o (new object%)])
+            (check-eq? (send+ o) o)))
+        (test-case "multiple messages"
+          (let* ([c% (class object%
+                       (super-new)
+                       (init-field count)
+                       (define/public (add n) (set! count (+ count n)))
+                       (define/public (get) count))]
+                 [o (new c% [count 0])])
+            (check-eq? (send+ o [add 1] [add 2]) o)
+            (check = (send o get) 3))))
+
+      (test-suite "send-each"
+        (test-case "counter"
+          (let* ([c% (class object%
+                       (super-new)
+                       (init-field count)
+                       (define/public (add n) (set! count (+ count n)))
+                       (define/public (get) count))]
+                 [o1 (new c% [count 1])]
+                 [o2 (new c% [count 2])]
+                 [o3 (new c% [count 3])])
+            (send-each (list o1 o2 o3) add 3)
+            (check-equal? (list (send o1 get) (send o2 get) (send o3 get))
+                          (list 4 5 6))))))))

collects/unstable/cce/test/test-contract.ss

@@ -0,0 +1,83 @@
+#lang scheme
+
+(require "checks.ss"
+         "../contract.ss")
+
+(provide contract-suite)
+
+(define contract-suite
+  (test-suite "contract.ss"
+    (test-suite "Flat Contracts"
+      (test-suite "nat/c"
+        (test-ok (with/c nat/c 1))
+        (test-ok (with/c nat/c 0))
+        (test-bad (with/c nat/c -1))
+        (test-bad (with/c nat/c 'non-numeric)))
+      (test-suite "pos/c"
+        (test-ok (with/c pos/c 1))
+        (test-bad (with/c pos/c 0))
+        (test-bad (with/c pos/c -1))
+        (test-bad (with/c pos/c 'non-numeric)))
+      (test-suite "truth/c"
+        (test-ok (with/c truth/c #t))
+        (test-ok (with/c truth/c #f))
+        (test-ok (with/c truth/c '(x)))))
+    (test-suite "Higher Order Contracts"
+      (test-suite "thunk/c"
+        (test-ok ([with/c thunk/c gensym]))
+        (test-bad ([with/c thunk/c gensym] 'x))
+        (test-bad ([with/c thunk/c cons])))
+      (test-suite "unary/c"
+        (test-ok ([with/c unary/c list] 'x))
+        (test-bad ([with/c unary/c list] 'x 'y))
+        (test-bad ([with/c unary/c cons] 1)))
+      (test-suite "binary/c"
+        (test-ok ([with/c binary/c +] 1 2))
+        (test-bad ([with/c binary/c +] 1 2 3))
+        (test-bad ([with/c binary/c symbol->string] 'x 'y)))
+      (test-suite "predicate/c"
+        (test-ok ([with/c predicate/c integer?] 1))
+        (test-ok ([with/c predicate/c integer?] 1/2))
+        (test-bad ([with/c predicate/c values] 'x)))
+      (test-suite "predicate-like/c"
+        (test-ok ([with/c predicate-like/c integer?] 1))
+        (test-ok ([with/c predicate-like/c integer?] 1/2))
+        (test-ok ([with/c predicate-like/c values] 'x)))
+      (test-suite "comparison/c"
+        (test-ok ([with/c comparison/c equal?] 1 1))
+        (test-ok ([with/c comparison/c equal?] 1 2))
+        (test-bad ([with/c comparison/c list] 1 2)))
+      (test-suite "comparison-like/c"
+        (test-ok ([with/c comparison-like/c equal?] 1 1))
+        (test-ok ([with/c comparison-like/c equal?] 1 2))
+        (test-ok ([with/c comparison-like/c list] 1 2))))
+    (test-suite "Collection Contracts"
+      (test-suite "sequence/c"
+        (test-ok
+         (for ([x (with/c (sequence/c integer?) (list 1 2 3 4))])
+           (void)))
+        (test-bad
+         (for ([x (with/c (sequence/c integer?) (list 1 2 'c 4))])
+           (void)))
+        (test-bad
+         (for ([x (with/c (sequence/c integer? symbol?) (list 1 2 3 4))])
+           (void))))
+      (test-suite "dict/c"
+        (test-ok
+         (for ([(x y)
+                (in-dict
+                 (with/c (dict/c integer? symbol?)
+                         #hash([1 . a] [2 . b])))])
+           (void)))
+        (test-bad
+         (for ([(x y)
+                (in-dict
+                 (with/c (dict/c integer? symbol?)
+                         #hash([1 . a] [three . b])))])
+           (void)))
+        (test-bad
+         (for ([(x y)
+                (in-dict
+                 (with/c (dict/c integer? symbol?)
+                         #hash([1 . a] [2 . "b"])))])
+           (void)))))))

collects/unstable/cce/test/test-debug.ss

@@ -0,0 +1,24 @@
+#lang scheme
+
+(require "checks.ss"
+         "../debug.ss")
+
+(provide debug-suite)
+
+(define debug-suite
+  (test-suite "debug.ss"
+    (test-suite "dprintf"
+      (test
+       (let ()
+         (define logger (make-logger))
+         (define receiver (make-log-receiver logger 'debug))
+         (parameterize ([current-logger logger])
+           (dprintf "Danger, ~a!" "Will Robinson"))
+         (check-not-false
+          (member
+           "Danger, Will Robinson!"
+           (let loop ()
+             (match (sync/timeout 0 receiver)
+               [(vector 'debug (? string? message) _)
+                (cons message (loop))]
+               [_ null])))))))))

collects/unstable/cce/test/test-define.ss

@@ -0,0 +1,99 @@
+#lang scheme
+
+(require scheme/sandbox
+         "checks.ss"
+         "../define.ss")
+
+(provide define-suite)
+
+(define define-suite
+  (test-suite "define.ss"
+
+    (test-suite "block"
+      (test
+       (block
+        (define (f x y) (both x y))
+        (define-match-expander both
+          (syntax-rules () [(_ a b) (struct pair [a b])])
+           (syntax-rules () [(_ a b) (make-pair a b)]))
+        (define-struct pair [x y] #:transparent)
+        (check-equal? (f 1 2) (make-pair 1 2)))))
+
+    (test-suite "at-end")
+
+    (test-suite "define-if-unbound"
+      (test
+       (let ()
+         (define-if-unbound very-special-name 1)
+         (define-if-unbound very-special-name 2)
+         (check-equal? very-special-name 1)))
+      (test
+       (let ()
+         (define-if-unbound (very-special-function) 1)
+         (define-if-unbound (very-special-function) 2)
+         (check-equal? (very-special-function) 1))))
+
+    (test-suite "define-values-if-unbound"
+      (test
+       (let ()
+         (define-values-if-unbound [very-special-name] 1)
+         (define-values-if-unbound [very-special-name] 2)
+         (check-equal? very-special-name 1))))
+
+    (test-suite "define-syntax-if-unbound"
+      (test
+       (let ()
+         (define-syntax-if-unbound very-special-macro
+           (lambda (stx) #'(quote 1)))
+         (define-syntax-if-unbound very-special-macro
+           (lambda (stx) #'(quote 2)))
+         (check-equal? (very-special-macro) 1)))
+      (test
+       (let ()
+         (define-syntax-if-unbound (very-special-macro stx)
+           #'(quote 1))
+         (define-syntax-if-unbound (very-special-macro stx)
+           #'(quote 2))
+         (check-equal? (very-special-macro) 1))))
+
+    (test-suite "define-syntaxes-if-unbound"
+      (test
+       (let ()
+         (define-syntaxes-if-unbound [very-special-macro]
+           (lambda (stx) #'(quote 1)))
+         (define-syntaxes-if-unbound [very-special-macro]
+           (lambda (stx) #'(quote 2)))
+         (check-equal? (very-special-macro) 1))))
+
+    (test-suite "define-renamings"
+      (test
+       (let ()
+         (define-renamings [with define] [fun lambda])
+         (with f (fun (x) (add1 x)))
+         (check-equal? (f 7) 8))))
+
+    (test-suite "declare-names"
+      (test
+       (let ()
+         (declare-names x y z)
+         (define-values [x y z] (values 1 2 3))
+         (check-equal? x 1)
+         (check-equal? y 2)
+         (check-equal? z 3))))
+
+    (test-suite "define-with-parameter"
+      (test
+       (let ()
+         (define p (make-parameter 0))
+         (define-with-parameter with-p p)
+         (with-p 7 (check-equal? (p) 7)))))
+
+    (test-suite "define-single-definition"
+      (test
+       (let ()
+         (define-single-definition with define-values)
+         (with x 0)
+         (check-equal? x 0))))
+
+    (test-suite "in-phase1")
+    (test-suite "in-phase1/pass2")))

collects/unstable/cce/test/test-dict.ss

@@ -0,0 +1,110 @@
+#lang scheme
+
+(require "checks.ss"
+         "../dict.ss")
+
+(provide dict-suite)
+
+(define (dict=? a b)
+  (and (subdict? a b)
+       (subdict? b a)))
+
+(define (subdict? a b)
+  (for/and ([(k v) (in-dict a)])
+    (and (dict-has-key? b k)
+         (equal? (dict-ref b k) v))))
+
+(define (check/dict a b) (check dict=? a b))
+
+(define dict-suite
+  (test-suite "dict.ss"
+    (test-suite "Constructors"
+      (test-suite "empty-dict"
+        (test (check/dict (empty-dict) '()))
+        (test (check/dict (empty-dict #:mutable? #t) '()))
+        (test (check/dict (empty-dict #:weak? #t) '()))
+        (test (check/dict (empty-dict #:compare 'eqv) '())))
+      (test-suite "make-dict"
+        (test (check/dict (make-dict '([1 . a] [2 . b])) '([1 . a] [2 . b])))
+        (test (check/dict (make-dict '([1 . a] [2 . b]) #:mutable? #t)
+                          '([1 . a] [2 . b])))
+        (test (check/dict (make-dict '([1 . a] [2 . b]) #:weak? #t)
+                          '([1 . a] [2 . b])))
+        (test (check/dict (make-dict '([1 . a] [2 . b]) #:compare 'eqv)
+                          '([1 . a] [2 . b]))))
+      (test-suite "custom-dict"
+        (test (let* ([table (custom-dict = add1 sub1 #:mutable? #t)])
+                (dict-set! table 1 'a)
+                (dict-set! table 2 'b)
+                (check/dict table '([1 . a] [2 . b]))))))
+    (test-suite "Lookup"
+      (test-suite "dict-ref!"
+        (test-ok (define d (make-hash))
+                 (check-equal? (dict-ref! d 1 'one) 'one)
+                 (check-equal? (dict-ref! d 1 'uno) 'one)
+                 (check-equal? (dict-ref! d 2 (lambda () 'two)) 'two)
+                 (check-equal? (dict-ref! d 2 (lambda () 'dos)) 'two))
+        (test-bad (dict-ref! '([1 . one] [2 . two]) 1 'uno)))
+      (test-suite "dict-ref/check"
+        (test-ok (check-equal? (dict-ref/check '([1 . one] [2 . two]) 1) 'one))
+        (test-bad (dict-ref/check '([1 . one] [2 . two]) 3)))
+      (test-suite "dict-ref/identity"
+        (test-ok (check-equal? (dict-ref/identity '([1 . one] [2 . two]) 1)
+                               'one))
+        (test-ok (check-equal? (dict-ref/identity '([1 . one] [2 . two]) 3) 3)))
+      (test-suite "dict-ref/default"
+        (test-ok (check-equal? (dict-ref/default '([1 . one] [2 . two]) 1 '?)
+                               'one))
+        (test-ok (check-equal? (dict-ref/default '([1 . one] [2 . two]) 3 '?)
+                               '?)))
+      (test-suite "dict-ref/failure"
+        (test-ok (define x 7)
+                 (define (f) (set! x (+ x 1)) x)
+                 (check-equal? (dict-ref/failure '([1 . one] [2 . two]) 1 f)
+                               'one)
+                 (check-equal? x 7)
+                 (check-equal? (dict-ref/failure '([1 . one] [2 . two]) 3 f) 8)
+                 (check-equal? x 8))))
+    (test-suite "Accessors"
+      (test-suite "dict-empty?"
+        (test (check-true (dict-empty? '())))
+        (test (check-false (dict-empty? '([1 . a] [2 . b])))))
+      (test-suite "dict-has-key?"
+        (test-ok (check-equal? (dict-has-key? '([1 . one] [2 . two]) 1) #t))
+        (test-ok (check-equal? (dict-has-key? '([1 . one] [2 . two]) 3) #f)))
+      (test-suite "dict-domain"
+        (test-ok (check-equal? (dict-domain '([1 . one] [2 . two])) '(1 2))))
+      (test-suite "dict-range"
+        (test-ok (check-equal? (dict-range '([1 . one] [2 . two]))
+                               '(one two)))))
+    (test-suite "Combination"
+      (test-suite "dict-union"
+        (test-ok (dict-union '([1 . one] [2 . two]) '([3 . three] [4 . four]))
+                 '([4 . four] [3 . three] [1 . one] [2 . two])))
+      (test-suite "dict-union!"
+        (test-ok (define d (make-hash))
+                 (dict-union! d '([1 . one] [2 . two]))
+                 (dict-union! d '([3 . three] [4 . four]))
+                 (check-equal?
+                  (hash-copy #hash([1 . one] [2 . two] [3 . three] [4 . four]))
+                  d))))
+    (test-suite "Property"
+      (test-suite "wrapped-dict-property"
+        (test
+         (let ()
+           (define (unwrap-table d) (table-dict d))
+           (define (wrap-table d) (make-table d))
+           (define (wrapped? d) (table? d))
+           (define-struct table [dict]
+             #:transparent
+             #:property prop:dict
+             (wrapped-dict-property
+              #:unwrap unwrap-table
+              #:wrap wrap-table
+              #:predicate wrapped?))
+           (check-true (dict? (make-table '([1 . a] [2 . b]))))
+           (check/dict (make-table '([1 . a] [2 . b])) '([1 . a] [2 . b]))
+           (check-equal? (dict-ref (make-table '([1 . a] [2 . b])) 1) 'a)
+           (let* ([s (dict-set (make-table '([1 . a] [2 . b])) 3 'c)])
+             (check-true (table? s))
+             (check/dict s '([1 . a] [2 . b] [3 . c])))))))))

collects/unstable/cce/test/test-exn.ss

@@ -0,0 +1,15 @@
+#lang scheme
+
+(require "checks.ss"
+         "../exn.ss")
+
+(provide exn-suite)
+
+(define exn-suite
+  (test-suite "exn.ss"
+    (test-suite "try"
+      (test-ok (try (+ 1 2)))
+      (test-bad (try (+ 'a 'b)))
+      (test-ok (try (+ 'a 'b) (+ 3 4)))
+      (test-ok (try (+ 1 2) (+ 'a 'b)))
+      (test-bad (try (+ 'a 'b) (+ 'c 'd))))))

collects/unstable/cce/test/test-function.ss

@@ -0,0 +1,157 @@
+#lang scheme
+
+(require "checks.ss"
+         "../function.ss")
+
+(provide function-suite)
+
+(define list/kw (make-keyword-procedure list))
+
+(define function-suite
+  (test-suite "function.ss"
+
+    (test-suite "Simple Functions"
+
+      (test-suite "identity"
+        (test-case "unique symbol"
+          (let* ([sym (gensym)])
+            (check-eq? (identity sym) sym))))
+
+      (test-suite "const"
+        (test-case "unique symbol"
+          (let* ([sym (gensym)])
+            (check-eq? ((const sym) 'x #:y 'z) sym))))
+
+      (test-suite "thunk"
+        (test-case "unique symbol"
+          (let* ([count 0]
+                 [f (thunk (set! count (+ count 1)) count)])
+            (check = count 0)
+            (check = (f) 1)
+            (check = count 1)))))
+
+    (test-suite "Higher Order Predicates"
+
+      (test-suite "negate"
+        (test-case "integer?"
+          (check-false ((negate integer?) 5)))
+        (test-case "not integer?"
+          (check-true ((negate integer?) 1/5)))
+        (test-case "non-boolean"
+          (check-false ((negate symbol->string) 'sym)))
+        (test-case "binary"
+          (check-false ((negate +) 1 2 3))))
+
+      (test-suite "conjoin"
+        (test-case "no functions"
+          (check-true ((conjoin) 'x #:y 'z)))
+        (test-case "true"
+          (check-true ((conjoin integer? exact?) 1)))
+        (test-case "false"
+          (check-false ((conjoin integer? exact?) 1.0)))
+        (test-case "false"
+          (check-false ((conjoin integer? exact?) 0.5))))
+
+      (test-suite "disjoin"
+        (test-case "no functions"
+          (check-false ((disjoin) 'x #:y 'z)))
+        (test-case "true"
+          (check-true ((disjoin integer? exact?) 1)))
+        (test-case "true"
+          (check-true ((disjoin integer? exact?) 1/2)))
+        (test-case "false"
+          (check-false ((disjoin integer? exact?) 0.5)))))
+
+    (test-suite "Currying and (Partial) Application"
+
+      (test-suite "call"
+        (test-case "string-append"
+          (check-equal? (call string-append "a" "b" "c") "abc")))
+
+      (test-suite "papply"
+        (test-case "list"
+          (check-equal? ((papply list 1 2) 3 4) (list 1 2 3 4)))
+        (test-case "sort"
+          (check-equal?
+           ((papply sort '((1 a) (4 d) (2 b) (3 c)) #:cache-keys? #f)
+            < #:key car)
+           '((1 a) (2 b) (3 c) (4 d)))))
+
+      (test-suite "papplyr"
+        (test-case "list"
+          (check-equal? ((papplyr list 1 2) 3 4) (list 3 4 1 2)))
+        (test-case "sort"
+          (check-equal?
+           ((papplyr sort < #:key car)
+            '((1 a) (4 d) (2 b) (3 c)) #:cache-keys? #f)
+           '((1 a) (2 b) (3 c) (4 d)))))
+
+      (test-suite "curryn"
+        (test-case "1"
+          (check-equal? (curryn 0 list/kw 1) '(() () 1)))
+        (test-case "1 / 2"
+          (check-equal? ((curryn 1 list/kw 1) 2) '(() () 1 2)))
+        (test-case "1 / 2 / 3"
+          (check-equal? (((curryn 2 list/kw 1) 2) 3) '(() () 1 2 3)))
+        (test-case "1 a"
+          (check-equal? (curryn 0 list/kw 1 #:a "a")
+                        '((#:a) ("a") 1)))
+        (test-case "1 a / 2 b"
+          (check-equal? ((curryn 1 list/kw 1 #:a "a") 2 #:b "b")
+                        '((#:a #:b) ("a" "b") 1 2)))
+        (test-case "1 a / 2 b / 3 c"
+          (check-equal? (((curryn 2 list/kw 1 #:a "a") 2 #:b "b") 3 #:c "c")
+                        '((#:a #:b #:c) ("a" "b" "c") 1 2 3))))
+
+      (test-suite "currynr"
+        (test-case "1"
+          (check-equal? (currynr 0 list/kw 1) '(() () 1)))
+        (test-case "1 / 2"
+          (check-equal? ((currynr 1 list/kw 1) 2) '(() () 2 1)))
+        (test-case "1 / 2 / 3"
+          (check-equal? (((currynr 2 list/kw 1) 2) 3) '(() () 3 2 1)))
+        (test-case "1 a"
+          (check-equal? (currynr 0 list/kw 1 #:a "a")
+                        '((#:a) ("a") 1)))
+        (test-case "1 a / 2 b"
+          (check-equal? ((currynr 1 list/kw 1 #:a "a") 2 #:b "b")
+                        '((#:a #:b) ("a" "b") 2 1)))
+        (test-case "1 a / 2 b / 3 c"
+          (check-equal? (((currynr 2 list/kw 1 #:a "a") 2 #:b "b") 3 #:c "c")
+                        '((#:a #:b #:c) ("a" "b" "c") 3 2 1)))))
+
+    (test-suite "Eta Expansion"
+      (test-suite "eta"
+        (test-ok (define f (eta g))
+                 (define g add1)
+                 (check-equal? (f 1) 2)))
+      (test-suite "eta*"
+        (test-ok (define f (eta* g x))
+                 (define g add1)
+                 (check-equal? (f 1) 2))
+        (test-bad (define f (eta* g x))
+                  (define g list)
+                  (f 1 2))))
+
+    (test-suite "Parameter Arguments"
+
+      (test-suite "lambda/parameter"
+        (test-case "provided"
+          (let* ([p (make-parameter 0)])
+            (check = ((lambda/parameter ([x #:param p]) x) 1) 1)))
+        (test-case "not provided"
+          (let* ([p (make-parameter 0)])
+            (check = ((lambda/parameter ([x #:param p]) x)) 0)))
+        (test-case "argument order / provided"
+          (let* ([p (make-parameter 3)])
+            (check-equal? ((lambda/parameter (x [y 2] [z #:param p])
+                                             (list x y z))
+                           4 5 6)
+                          (list 4 5 6))))
+        (test-case "argument order / not provided"
+          (let* ([p (make-parameter 3)])
+            (check-equal? ((lambda/parameter (x [y 2] [z #:param p])
+                                             (list x y z))
+                           1)
+                          (list 1 2 3))))))))
+

collects/unstable/cce/test/test-hash.ss

@@ -0,0 +1,74 @@
+#lang scheme
+
+(require "checks.ss"
+         "../hash.ss")
+
+(provide hash-suite)
+
+(define hash-suite
+  (test-suite "hash.ss"
+    (test-suite "hash"
+      (test (check-equal? (hash [1 'a] [2 'b])
+                          #hash([1 . a] [2 . b])))
+      (test (check-equal? (hash #:eq [1 'a] [2 'b])
+                          #hasheq([1 . a] [2 . b])))
+      (test (check-equal? (hash #:eqv [1 'a] [2 'b])
+                          #hasheqv([1 . a] [2 . b])))
+      (test (check-equal? (hash #:equal [1 'a] [2 'b])
+                          #hash([1 . a] [2 . b]))))
+    (test-suite "hash!"
+      (test (check-equal? (hash! [1 'a] [2 'b])
+                          (hash-copy #hash([1 . a] [2 . b]))))
+      (test (check-equal? (hash! #:eq [1 'a] [2 'b])
+                          (hash-copy #hasheq([1 . a] [2 . b]))))
+      (test (check-equal? (hash! #:eqv #:weak [1 'a] [2 'b])
+                          (make-weak-hasheqv '([1 . a] [2 . b]))))
+      (test (check-equal? (hash! #:weak #:equal [1 'a] [2 'b])
+                          (make-weak-hash '([1 . a] [2 . b])))))
+    (test-suite "hash-equal?"
+      (test (check-true (hash-equal? #hash())))
+      (test (check-false (hash-equal? #hasheq())))
+      (test (check-false (hash-equal? #hasheqv()))))
+    (test-suite "hash-ref/check"
+      (test-ok (check-equal? (hash-ref/check #hash([1 . one] [2 . two]) 1)
+                             'one))
+      (test-bad (hash-ref/check #hash([1 . one] [2 . two]) 3)))
+    (test-suite "hash-ref/identity"
+      (test-ok (check-equal? (hash-ref/identity #hash([1 . one] [2 . two]) 1)
+                             'one))
+      (test-ok (check-equal? (hash-ref/identity #hash([1 . one] [2 . two]) 3)
+                             3)))
+    (test-suite "hash-ref/default"
+      (test-ok (check-equal? (hash-ref/default #hash([1 . one] [2 . two]) 1 '?)
+                             'one))
+      (test-ok (check-equal? (hash-ref/default #hash([1 . one] [2 . two]) 3 '?)
+                             '?)))
+    (test-suite "hash-ref/failure"
+      (test-ok (define x 7)
+               (define (f) (set! x (+ x 1)) x)
+               (check-equal? (hash-ref/failure #hash([1 . one] [2 . two]) 1 f)
+                             'one)
+               (check-equal? x 7)
+               (check-equal? (hash-ref/failure #hash([1 . one] [2 . two]) 3 f)
+                             8)
+               (check-equal? x 8)))
+    (test-suite "hash-has-key?"
+      (test-ok (check-equal? (hash-has-key? #hash([1 . one] [2 . two]) 1) #t))
+      (test-ok (check-equal? (hash-has-key? #hash([1 . one] [2 . two]) 3) #f)))
+    (test-suite "hash-domain"
+      (test-ok (check-equal? (hash-domain #hash([1 . one] [2 . two])) '(1 2))))
+    (test-suite "hash-range"
+      (test-ok (check-equal? (hash-range #hash([1 . one] [2 . two]))
+                             '(one two))))
+    (test-suite "hash-union"
+      (test-ok (hash-union #hash([1 . one] [2 . two])
+                           #hash([3 . three] [4 . four]))
+               #hash([4 . four] [3 . three] [1 . one] [2 . two])))
+    (test-suite "hash-union!"
+      (test-ok (define h (make-hash))
+               (hash-union! h #hash([1 . one] [2 . two]))
+               (hash-union! h #hash([3 . three] [4 . four]))
+               (check-equal? (hash-copy
+                              #hash([1 . one] [2 . two] [3 . three] [4 . four]))
+                             h)))))
+

collects/unstable/cce/test/test-main.ss

@@ -0,0 +1,48 @@
+#lang scheme
+
+(require "checks.ss"
+         "test-class.ss"
+         "test-contract.ss"
+         "test-debug.ss"
+         "test-define.ss"
+         "test-dict.ss"
+         "test-exn.ss"
+         "test-function.ss"
+         "test-hash.ss"
+         "test-match.ss"
+         "test-planet.ss"
+         "test-port.ss"
+         "test-queue.ss"
+         "test-regexp.ss"
+         "test-require-provide.ss"
+         "test-sandbox.ss"
+         "test-scribble.ss"
+         "test-set.ss"
+         "test-syntax.ss"
+         "test-text.ss"
+         "test-values.ss"
+         "test-web.ss")
+
+(run-tests
+ (test-suite "scheme.plt"
+   class-suite
+   contract-suite
+   debug-suite
+   define-suite
+   dict-suite
+   exn-suite
+   function-suite
+   hash-suite
+   match-suite
+   planet-suite
+   port-suite
+   queue-suite
+   regexp-suite
+   require-provide-suite
+   sandbox-suite
+   scribble-suite
+   set-suite
+   syntax-suite
+   text-suite
+   values-suite
+   web-suite))

collects/unstable/cce/test/test-match.ss

@@ -0,0 +1,45 @@
+#lang scheme
+
+(require "checks.ss"
+         "../match.ss")
+
+(provide match-suite)
+
+(define match-suite
+  (test-suite "match.ss"
+    (test-suite "match?"
+      (test
+       (check-true (match? (list 1 2 3)
+                     (list a b c)
+                     (vector x y z))))
+      (test
+       (check-true (match? (vector 1 2 3)
+                     (list a b c)
+                     (vector x y z))))
+      (test
+       (check-false (match? (+ 1 2 3)
+                      (list a b c)
+                      (vector x y z)))))
+    (test-suite "define-struct-pattern"
+      (test
+       (let ()
+         (define-struct pair [a b] #:transparent)
+         (define-struct-pattern both pair)
+         (check-equal?
+          (match (make-pair 1 2)
+            [(both a b) (list a b)])
+          (list 1 2)))))
+    (test-suite "as"
+      (test
+       (match (list 1 2 3)
+         [(as ([a 0]) (list b c d)) (list a b c d)])
+       (list 0 1 2 3)))
+    (test-suite "$"
+      (test
+       (let ()
+         (define-struct pair [a b] #:transparent)
+         (check-equal? ($ pair 1 2) (make-pair 1 2))
+         (check-equal?
+          (match ($ pair 1 2)
+            [($ pair a b) (list a b)])
+          (list 1 2)))))))

collects/unstable/cce/test/test-planet.ss

@@ -0,0 +1,11 @@
+#lang scheme
+
+(require "checks.ss"
+         "../planet.ss"
+         planet/util)
+
+(provide planet-suite)
+
+(define planet-suite
+  (test-suite "planet.ss"
+    (test-suite "this-package-version-symbol")))

collects/unstable/cce/test/test-port.ss

@@ -0,0 +1,52 @@
+#lang scheme
+
+(require "checks.ss"
+         "../port.ss")
+
+(provide port-suite)
+
+(define port-suite
+  (test-suite "port.ss"
+    (test-suite "eprintf"
+      (test
+       (parameterize ([current-error-port (open-output-string)])
+         (eprintf "Danger, ~a!" "Will Robinson")
+         (check-equal? (get-output-string (current-error-port))
+                       "Danger, Will Robinson!"))))
+    (test-suite "read-all"
+      (test-ok (check-equal? (read-all read (open-input-string "1 2 3"))
+                             (list 1 2 3)))
+      (test-ok (check-equal?
+                (parameterize ([current-input-port
+                                (open-input-string "1 2 3")])
+                  (read-all))
+                (list 1 2 3))))
+    (test-suite "read-all-syntax"
+      (test-ok (check-equal?
+                (syntax->datum
+                 (read-all-syntax read-syntax (open-input-string "1 2 3")))
+                (list 1 2 3)))
+      (test-ok (check-equal?
+                (syntax->datum
+                 (parameterize ([current-input-port
+                                 (open-input-string "1 2 3")])
+                   (read-all-syntax)))
+                 (list 1 2 3))))
+    
+    (test-suite "port->srcloc"
+      (test-ok (define port (open-input-string "\n x "))
+               (port-count-lines! port)
+               (check-equal? (port->srcloc port)
+                             (make-srcloc 'string 1 0 1 0))
+               (read port)
+               (check-equal? (port->srcloc port 'here 1)
+                             (make-srcloc 'here 2 2 4 1))))
+
+    (test-suite "read-available-bytes"
+      (test-ok (define-values [in out] (make-pipe))
+               (check-equal? (read-available-bytes in) #"")
+               (write-byte (char->integer #\c) out)
+               (check-equal? (read-available-bytes in) #"c")
+               (close-output-port out)
+               (check-equal? (read-available-bytes in) eof)))))
+

collects/unstable/cce/test/test-queue.ss

@@ -0,0 +1,56 @@
+#lang scheme
+
+(require "checks.ss"
+         "../queue.ss")
+
+(provide queue-suite)
+
+(define queue-suite
+  (test-suite "queue.ss"
+    (test-suite "queue-empty?"
+      (test-case "make-queue"
+        (check-true (queue-empty? (make-queue))))
+      (test-case "enqueue! once"
+        (let* ([q (make-queue)])
+          (enqueue! q 1)
+          (check-false (queue-empty? q))))
+      (test-case "enqueue! once / dequeue! once"
+        (let* ([q (make-queue)])
+          (enqueue! q 1)
+          (dequeue! q)
+          (check-true (queue-empty? q))))
+      (test-case "enqueue! twice"
+        (let* ([q (make-queue)])
+          (enqueue! q 1)
+          (enqueue! q 2)
+          (check-false (queue-empty? q))))
+      (test-case "enqueue! twice / dequeue! once"
+        (let* ([q (make-queue)])
+          (enqueue! q 1)
+          (enqueue! q 2)
+          (dequeue! q)
+          (check-false (queue-empty? q))))
+      (test-case "enqueue! twice / dequeue! twice"
+        (let* ([q (make-queue)])
+          (enqueue! q 1)
+          (enqueue! q 2)
+          (dequeue! q)
+          (dequeue! q)
+          (check-true (queue-empty? q)))))
+    (test-suite "dequeue!"
+      (test-case "make-queue"
+        (check-exn exn:fail:contract? (lambda () (dequeue! (make-queue)))))
+      (test-case "enqueue! once"
+        (let* ([q (make-queue)])
+          (enqueue! q 1)
+          (check-equal? (dequeue! q) 1)
+          (check-exn exn:fail:contract?
+                     (lambda () (dequeue! q)))))
+      (test-case "enqueue! twice"
+        (let* ([q (make-queue)])
+          (enqueue! q 1)
+          (enqueue! q 2)
+          (check-equal? (dequeue! q) 1)
+          (check-equal? (dequeue! q) 2)
+          (check-exn exn:fail:contract?
+                     (lambda () (dequeue! q))))))))

collects/unstable/cce/test/test-regexp.ss

@@ -0,0 +1,50 @@
+#lang scheme
+
+(require "checks.ss" "../regexp.ss")
+
+(provide regexp-suite)
+
+(define-syntax (regexp-test stx)
+  (syntax-case stx ()
+    [(_ pattern string result)
+     (syntax/loc stx
+       (test-suite (format "(regexp-match ~s ~s) = ~s" 'pattern 'string 'result)
+         (test-case "regexp"
+           (check-equal? (regexp-match (regexp pattern) string) result))
+         (test-case "pregexp"
+           (check-equal? (regexp-match (pregexp pattern) string) result))))]))
+
+(define regexp-suite
+ (test-suite "regexp.ss"
+   (test-suite "regexp-sequence"
+     (regexp-test (regexp-sequence) "a cat" (list ""))
+     (regexp-test (regexp-sequence "cat") "a cat" (list "cat"))
+     (regexp-test (regexp-sequence "hot" "dog") "a hotdog" (list "hotdog"))
+     (regexp-test (regexp-sequence "cat" "dog") "a cat" #f)
+     (regexp-test (regexp-sequence "cat" "dog") "a dog" #f)
+     (regexp-test (regexp-sequence "a" "b|c") "c" #f))
+   (test-suite "regexp-or"
+     (regexp-test (regexp-or "cat") "a cat" (list "cat"))
+     (regexp-test (regexp-or "cat" "dog") "a cat" (list "cat"))
+     (regexp-test (regexp-or "cat" "dog") "a dog" (list "dog")))
+   (test-suite "regexp-maybe"
+     (regexp-test (regexp-maybe "cat") "a dog" (list ""))
+     (regexp-test (regexp-maybe "cat") "catnap" (list "cat"))
+     (regexp-test (regexp-maybe "hot" "dog") "hotdog!" (list "hotdog"))
+     (regexp-test (regexp-maybe "hot" "dog") "a dog" (list "")))
+   (test-suite "regexp-star"
+     (regexp-test (regexp-star "a") "" (list ""))
+     (regexp-test (regexp-star "a") "aaa" (list "aaa"))
+     (regexp-test (regexp-star "ab") "abab" (list "abab"))
+     (regexp-test (regexp-star "a" "b") "abab" (list "abab"))
+     (regexp-test (regexp-star "a" "b") "aaaa" (list "")))
+   (test-suite "regexp-plus"
+     (regexp-test (regexp-plus "a") "" #f)
+     (regexp-test (regexp-plus "a") "aaa" (list "aaa"))
+     (regexp-test (regexp-plus "ab") "abab" (list "abab"))
+     (regexp-test (regexp-plus "a" "b") "abab" (list "abab"))
+     (regexp-test (regexp-plus "a" "b") "aaaa" #f))
+   (test-suite "regexp-multi"
+     (regexp-test (regexp-multi "^cat$") "ant\nbat\ncat\ndog" (list "cat")))
+   (test-suite "regexp-save"
+     (regexp-test (regexp-save "cat") "a cat" (list "cat" "cat")))))

collects/unstable/cce/test/test-require-provide.ss

@@ -0,0 +1,9 @@
+#lang scheme
+
+(require "checks.ss"
+         "../require-provide.ss")
+
+(provide require-provide-suite)
+
+(define require-provide-suite
+  (test-suite "require-provide.ss"))

collects/unstable/cce/test/test-sandbox.ss

@@ -0,0 +1,9 @@
+#lang scheme
+
+(require "checks.ss"
+         "../sandbox.ss")
+
+(provide sandbox-suite)
+
+(define sandbox-suite
+  (test-suite "sandbox.ss"))

collects/unstable/cce/test/test-scribble.ss

@@ -0,0 +1,10 @@
+#lang scheme
+
+(require "checks.ss"
+         "../scribble.ss")
+
+(provide scribble-suite)
+
+(define scribble-suite
+  (test-suite "scribble.ss"))
+

collects/unstable/cce/test/test-set.ss

@@ -0,0 +1,169 @@
+#lang scheme
+
+(require "checks.ss"
+         "../set.ss")
+
+(provide set-suite)
+
+(define (check/set a-set a-list #:= [== equal?])
+  (check/sort (set->list a-set) a-list #:= ==))
+
+(define-syntax-rule (test/set arg ...)
+  (test (check/set arg ...)))
+
+(define set-suite
+  (test-suite "set.ss"
+    (test-suite "Constructors"
+      (test-suite "set"
+        (test/set (set 1 2 3) (list 1 2 3))
+        (test/set (set 3 2 1) (list 1 2 3))
+        (test/set (set 3 1 2 #:mutable? #t) (list 1 2 3))
+        (test/set (set 3 1 2 #:weak? #t) (list 1 2 3))
+        (test/set (set 3 1 2 #:compare 'eqv) (list 1 2 3))
+        (test/set (set 3 1 2 #:compare 'eq) (list 1 2 3)))
+      (test-suite "empty-set"
+        (test/set (empty-set) (list))
+        (test/set (empty-set #:mutable? #t) (list))
+        (test/set (empty-set #:weak? #t) (list))
+        (test/set (empty-set #:compare 'eqv) (list))
+        (test/set (empty-set #:compare 'eq) (list)))
+      (test-suite "list->set"
+        (test/set (list->set (list 1 2 3)) (list 1 2 3))
+        (test/set (list->set (list 3 2 1)) (list 1 2 3))
+        (test/set (list->set (list 3 1 2) #:mutable? #t) (list 1 2 3))
+        (test/set (list->set (list 3 1 2) #:weak? #t) (list 1 2 3))
+        (test/set (list->set (list 3 1 2) #:compare 'eqv) (list 1 2 3))
+        (test/set (list->set (list 3 1 2) #:compare 'eq) (list 1 2 3)))
+      (test-suite "custom-set"
+        (test/set (custom-set #:compare string-ci=? "A" "a" "B" "b")
+                  (list "A" "B")
+                  #:= string-ci=?)
+        (test/set (custom-set #:compare string-ci=?
+                              #:hash string-length
+                              "A" "a" "B" "b")
+                  (list "A" "B")
+                  #:= string-ci=?)
+        (test/set (custom-set #:compare string-ci=?
+                              #:hash string-length
+                              #:mutable? #t
+                              "A" "a" "B" "b")
+                  (list "A" "B")
+                  #:= string-ci=?)))
+    (test-suite "Accessors"
+      (test-suite "set-contains?"
+        (test (check-true (set-contains? (set 1 2 3) 1)))
+        (test (check-false (set-contains? (set 1 2 3) 4))))
+      (test-suite "set-empty?"
+        (test (check-true (set-empty? (set))))
+        (test (check-false (set-empty? (set 1 2 3)))))
+      (test-suite "set-count"
+        (test (check = (set-count (set)) 0))
+        (test (check = (set-count (set 1 2 3)) 3)))
+      (test-suite "set=?"
+        (test (check-false (set=? (set 1) (set 1 2 3))))
+        (test (check-false (set=? (set 1 2 3) (set 1))))
+        (test (check-true (set=? (set 1 2 3) (set 1 2 3)))))
+      (test-suite "subset?"
+        (test (check-true (subset? (set 1) (set 1 2 3))))
+        (test (check-false (subset? (set 1 2 3) (set 1))))
+        (test (check-true (subset? (set 1 2 3) (set 1 2 3)))))
+      (test-suite "proper-subset?"
+        (test (check-true (proper-subset? (set 1) (set 1 2 3))))
+        (test (check-false (proper-subset? (set 1 2 3) (set 1))))
+        (test (check-false (proper-subset? (set 1 2 3) (set 1 2 3)))))
+      (test-suite "set->list"
+        (test (check/sort (set->list (set 1 2 3)) (list 1 2 3))))
+      (test-suite "in-set"
+        (test (check/sort (for/list ([x (in-set (set 1 2 3))]) x)
+                          (list 1 2 3)))))
+    (test-suite "Updaters"
+      (test-suite "set-insert"
+        (test/set (set-insert (set 1 2 3) 4) (list 1 2 3 4))
+        (test/set (set-insert (set 1 2 3) 1) (list 1 2 3)))
+      (test-suite "set-remove"
+        (test/set (set-remove (set 1 2 3) 1) (list 2 3))
+        (test/set (set-remove (set 1 2 3) 4) (list 1 2 3)))
+      (test-suite "set-insert!"
+        (test (let* ([s (set 1 2 3 #:mutable? #t)])
+                (set-insert! s 4)
+                (check/set s (list 1 2 3 4))))
+        (test (let* ([s (set 1 2 3 #:mutable? #t)])
+                (set-insert! s 1)
+                (check/set s (list 1 2 3)))))
+      (test-suite "set-remove!"
+        (test (let* ([s (set 1 2 3 #:mutable? #t)])
+                (set-remove! s 1)
+                (check/set s (list 2 3))))
+        (test (let* ([s (set 1 2 3 #:mutable? #t)])
+                (set-remove! s 4)
+                (check/set s (list 1 2 3)))))
+      (test-suite "set-union"
+        (test/set (set-union (set 1 2) (set 1 3) (set 2 3)) (list 1 2 3))
+        (test/set (set-union (set) (set 1 2) (set 3 4)) (list 1 2 3 4))
+        (test/set (set-union (set 1 2) (set) (set 3 4)) (list 1 2 3 4))
+        (test/set (set-union (set 1 2) (set 3 4) (set)) (list 1 2 3 4)))
+      (test-suite "set-intersection"
+        (test/set (set-intersection (set 1 2 3) (set 1 2) (set 2 3)) (list 2))
+        (test/set (set-intersection (set 1 2) (set 1 2 3) (set 2 3)) (list 2))
+        (test/set (set-intersection (set 1 2) (set 2 3) (set 1 2 3)) (list 2))
+        (test/set (set-intersection (set 1 2) (set 2 3) (set 1 3)) (list)))
+      (test-suite "set-difference"
+        (test/set (set-difference (set 1 2 3) (set 1) (set 3)) (list 2))
+        (test/set (set-difference (set 1 2 3 4) (set 5) (set 6)) (list 1 2 3 4))
+        (test/set (set-difference (set 1 2 3) (set 1 2) (set 2 3)) (list)))
+      (test-suite "set-exclusive-or"
+        (test/set (set-exclusive-or (set 1) (set 1 2) (set 1 2 3)) (list 1 3))
+        (test/set (set-exclusive-or (set 1) (set 2) (set 3)) (list 1 2 3))
+        (test/set (set-exclusive-or (set 1 2) (set 2 3) (set 1 3)) (list))))
+    (test-suite "Predicates"
+      (test-suite "set?"
+        (test (check-false (set? '(1 2))))
+        (test (check-true (set? '((1 . one) (2 . two)))))
+        (test (check-true (set? (set 1 2 3)))))
+      (test-suite "set-can-insert?"
+        (test (check-true (set-can-insert? (set 1 2 3))))
+        (test (check-false (set-can-insert? (set 1 2 3 #:mutable? #t)))))
+      (test-suite "set-can-remove?"
+        (test (check-true (set-can-remove? (set 1 2 3))))
+        (test (check-false (set-can-remove? (set 1 2 3 #:mutable? #t)))))
+      (test-suite "set-can-insert!?"
+        (test (check-false (set-can-insert!? (set 1 2 3))))
+        (test (check-true (set-can-insert!? (set 1 2 3 #:mutable? #t)))))
+      (test-suite "set-can-remove!?"
+        (test (check-false (set-can-remove!? (set 1 2 3))))
+        (test (check-true (set-can-remove!? (set 1 2 3 #:mutable? #t))))))
+    (test-suite "Property"
+      (test-suite "prop:set"
+        (test
+         (let ()
+           (define (never-contains? set elem) #f)
+           (define (never-remove! set elem) (void))
+           (define (never-remove set elem) set)
+           (define (always-zero set) 0)
+           (define (no-elements set) null)
+
+           (define-struct always-empty []
+             #:transparent
+             #:property prop:set
+             (vector never-contains?
+                     #f
+                     #f
+                     never-remove!
+                     never-remove
+                     always-zero
+                     no-elements))
+
+           (check-true (set? (make-always-empty)))
+           (check/set (make-always-empty) (list))
+           (check-false (set-contains? (make-always-empty) 1))
+           (check-bad (set-insert! (make-always-empty) 2))
+           (check-bad (set-insert (make-always-empty) 3))
+           (check/set (let* ([s (make-always-empty)])
+                        (set-remove! s 4)
+                        s)
+                      (list))
+           (check/set (set-remove (make-always-empty) 5) (list))
+           (check-true (set-empty? (make-always-empty)))
+           (check-equal? (set->list (make-always-empty)) (list))))))))
+
+

collects/unstable/cce/test/test-syntax.ss

@@ -0,0 +1,256 @@
+#lang scheme
+
+(require mzlib/etc
+         planet/util
+         "checks.ss"
+         "../syntax.ss")
+
+(provide syntax-suite)
+
+(define here
+  (datum->syntax
+   #f
+   'here
+   (list (build-path (this-expression-source-directory)
+                     (this-expression-file-name))
+         1 1 1 1)))
+
+(define syntax-suite
+  (test-suite "syntax.ss"
+
+    (test-suite "Contracts"
+
+      (test-suite "syntax-datum/c"
+        (test-ok (with/c (syntax-datum/c (listof (listof natural-number/c)))
+                         #'((0 1 2) () (3 4) (5))))
+        (test-bad (with/c (syntax-datum/c (listof (listof natural-number/c)))
+                          #'((x y z))))
+        (test-bad (with/c (syntax-datum/c string?) "xyz")))
+
+      (test-suite "syntax-listof/c"
+        (test-ok (with/c (syntax-listof/c identifier?) #'(a b c)))
+        (test-bad (with/c (syntax-listof/c identifier?) #'(1 2 3)))
+        (test-bad (with/c (syntax-listof/c identifier?) #'(a b . c)))
+        (test-bad (with/c (syntax-listof/c identifier?) (list #'a #'b #'c))))
+
+      (test-suite "syntax-list/c"
+        (test-ok (with/c (syntax-list/c identifier? (syntax/c string?))
+                         #'(a "b")))
+        (test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
+                          #'(a "b" #:c)))
+        (test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
+                          #'(a b)))
+        (test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
+                          #'(a "b" . c)))
+        (test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
+                          '(#'a #'"b")))))
+
+    (test-suite "Source Location Representations"
+
+      (test-suite "src/c"
+        (test-ok (with/c src/c #f))
+        (test-ok (with/c src/c (make-srcloc 'source 1 0 1 0)))
+        (test-ok (with/c src/c #'here))
+        (test-ok (with/c src/c (list 'source 1 0 1 0)))
+        (test-bad (with/c src/c (list 'source 1 0 0 1)))
+        (test-bad (with/c src/c (list 'source 0 0 0 0)))
+        (test-ok (with/c src/c (vector 'source 1 0 1 0)))
+        (test-bad (with/c src/c (vector 'source 1 0 0 1)))
+        (test-bad (with/c src/c (vector 'source 0 0 0 0)))
+        (test-bad (with/c src/c 'symbol)))
+
+      (test-suite "src->srcloc"
+        (test-ok (check-equal? (src->srcloc #f) (make-srcloc #f #f #f #f #f)))
+        (test-ok (check-equal? (src->srcloc (make-srcloc 'source 1 0 1 0))
+                               (make-srcloc 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->srcloc (datum->syntax #f 'here #f))
+                               ;; Note known bug w/ syntax-span:
+                               (make-srcloc #f #f #f #f 0)))
+        (test-ok (check-equal? (src->srcloc (list 'source 1 0 1 0))
+                               (make-srcloc 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->srcloc (vector 'source 1 0 1 0))
+                               (make-srcloc 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->srcloc) (make-srcloc #f #f #f #f #f)))
+        (test-ok (check-equal? (src->srcloc (make-srcloc 'one 1 0 1 0)
+                                            (make-srcloc 'two 1 0 1 0))
+                               (make-srcloc #f #f #f #f #f)))
+        (test-ok (check-equal? (src->srcloc (make-srcloc 'source 1 0 1 0)
+                                            (make-srcloc 'source 2 1 2 1))
+                               (make-srcloc 'source 1 0 1 2))))
+
+      (test-suite "src->list"
+        (test-ok (check-equal? (src->list #f) (list #f #f #f #f #f)))
+        (test-ok (check-equal? (src->list (make-srcloc 'source 1 0 1 0))
+                               (list 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->list (datum->syntax #f 'here #f))
+                               ;; Note known bug w/ syntax-span:
+                               (list #f #f #f #f 0)))
+        (test-ok (check-equal? (src->list (list 'source 1 0 1 0))
+                               (list 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->list (vector 'source 1 0 1 0))
+                               (list 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->list) (list #f #f #f #f #f)))
+        (test-ok (check-equal? (src->list (make-srcloc 'one 1 0 1 0)
+                                          (make-srcloc 'two 1 0 1 0))
+                               (list #f #f #f #f #f)))
+        (test-ok (check-equal? (src->list (make-srcloc 'source 1 0 1 0)
+                                          (make-srcloc 'source 2 1 2 1))
+                               (list 'source 1 0 1 2))))
+
+      (test-suite "src->vector"
+        (test-ok (check-equal? (src->vector #f) (vector #f #f #f #f #f)))
+        (test-ok (check-equal? (src->vector (make-srcloc 'source 1 0 1 0))
+                               (vector 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->vector (datum->syntax #f 'here #f))
+                               ;; Note known bug w/ syntax-span:
+                               (vector #f #f #f #f 0)))
+        (test-ok (check-equal? (src->vector (list 'source 1 0 1 0))
+                               (vector 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->vector (vector 'source 1 0 1 0))
+                               (vector 'source 1 0 1 0)))
+        (test-ok (check-equal? (src->vector) (vector #f #f #f #f #f)))
+        (test-ok (check-equal? (src->vector (make-srcloc 'one 1 0 1 0)
+                                            (make-srcloc 'two 1 0 1 0))
+                               (vector #f #f #f #f #f)))
+        (test-ok (check-equal? (src->vector (make-srcloc 'source 1 0 1 0)
+                                            (make-srcloc 'source 2 1 2 1))
+                               (vector 'source 1 0 1 2))))
+
+      (test-suite "src->syntax"
+        (test-ok (check-pred syntax? (src->syntax #f)))
+        (test-ok (check-pred syntax?
+                             (src->syntax (make-srcloc 'source 1 0 1 0))))
+        (test-ok (check-pred syntax? (src->syntax (datum->syntax #f 'here #f))))
+        (test-ok (check-pred syntax? (src->syntax (list 'source 1 0 1 0))))
+        (test-ok (check-pred syntax? (src->syntax (vector 'source 1 0 1 0))))
+        (test-ok (check-pred syntax? (src->syntax)))
+        (test-ok (check-pred syntax? (src->syntax (make-srcloc 'one 1 0 1 0)
+                                                  (make-srcloc 'two 1 0 1 0))))
+        (test-ok (check-pred syntax?
+                             (src->syntax (make-srcloc 'source 1 0 1 0)
+                                          (make-srcloc 'source 2 1 2 1)))))
+
+      (test-suite "src-known?"
+        (test-ok (check-false (src-known? (list #f #f #f #f #f))))
+        (test-ok (check-true (src-known? (vector 'source #f #f #f #f))))
+        (test-ok (check-true (src-known? (datum->syntax #f 'x
+                                                        (list 'a 1 2 3 4)))))))
+
+    (test-suite "Syntax Lists"
+
+      (test-suite "syntax-list"
+        (test
+         (check-equal?
+          (with-syntax ([([x ...] ...) #'([1 2] [3] [4 5 6])])
+            (map syntax->datum (syntax-list x ... ...)))
+          (list 1 2 3 4 5 6))))
+
+      (test-suite "syntax-map"
+        (test-case "identifiers to symbols"
+          (check-equal? (syntax-map syntax-e #'(a b c)) '(a b c)))))
+
+    (test-suite "Syntax Conversions"
+
+      (test-suite "to-syntax"
+        (test-case "symbol + context = identifier"
+          (check bound-identifier=?
+                 (to-syntax #:stx #'context 'id)
+                 #'id)))
+
+      (test-suite "to-datum"
+        (test-case "syntax"
+          (check-equal? (to-datum #'((a b) () (c)))
+                        '((a b) () (c))))
+        (test-case "non-syntax"
+          (check-equal? (to-datum '((a b) () (c)))
+                        '((a b) () (c))))
+        (test-case "nested syntax"
+          (let* ([stx-ab #'(a b)]
+                 [stx-null #'()]
+                 [stx-c #'(c)])
+            (check-equal? (to-datum (list stx-ab stx-null stx-c))
+                          (list stx-ab stx-null stx-c))))))
+
+    (test-suite "Syntax Source Locations"
+
+      (test-suite "syntax-source-file-name"
+        (test-case "here"
+          (check-equal? (syntax-source-file-name here)
+                        (this-expression-file-name)))
+        (test-case "fail"
+          (check-equal? (syntax-source-file-name (datum->syntax #f 'fail))
+                        #f)))
+
+      (test-suite "syntax-source-directory"
+        (test-case "here"
+          (check-equal? (syntax-source-directory here)
+                        (this-expression-source-directory)))
+        (test-case "fail"
+          (check-equal? (syntax-source-directory (datum->syntax #f 'fail))
+                        #f)))
+
+      (test-suite "syntax-source-planet-package"
+        (test-case "fail"
+          (check-equal? (syntax-source-planet-package (datum->syntax #f 'fail))
+                        #f)))
+
+      (test-suite "syntax-source-planet-package-owner"
+        (test-case "fail"
+          (check-equal? (syntax-source-planet-package-owner
+                         (datum->syntax #f 'fail))
+                        #f)))
+
+      (test-suite "syntax-source-planet-package-name"
+        (test-case "fail"
+          (check-equal? (syntax-source-planet-package-name
+                         (datum->syntax #f 'fail))
+                        #f)))
+
+      (test-suite "syntax-source-planet-package-major"
+        (test-case "fail"
+          (check-equal? (syntax-source-planet-package-major
+                         (datum->syntax #f 'fail))
+                        #f)))
+
+      (test-suite "syntax-source-planet-package-minor"
+        (test-case "fail"
+          (check-equal? (syntax-source-planet-package-minor
+                         (datum->syntax #f 'fail))
+                        #f)))
+
+      (test-suite "syntax-source-planet-package-symbol"
+        (test-case "fail"
+          (check-equal? (syntax-source-planet-package-minor
+                         (datum->syntax #f 'fail))
+                        #f)))
+
+      (test-suite "make-planet-path"))
+
+    (test-suite "Transformers"
+
+      (test-suite "redirect-transformer"
+        (test (check-equal?
+               (syntax->datum ((redirect-transformer #'x) #'y))
+               'x))
+        (test (check-equal?
+               (syntax->datum ((redirect-transformer #'x) #'(y z)))
+               '(x z))))
+
+      (test-suite "full-kernel-form-identifier-list"
+        (test (check-pred list? (full-kernel-form-identifier-list)))
+        (test (for ([id (in-list (full-kernel-form-identifier-list))])
+                (check-pred identifier? id))))
+
+      (test-suite "head-expand")
+
+      (test-suite "trampoline-transformer")
+
+      (test-suite "quote-transformer"))
+
+    (test-suite "Pattern Bindings"
+
+      (test-suite "with-syntax*"
+        (test-case "identifier"
+          (check bound-identifier=?
+                 (with-syntax* ([a #'id] [b #'a]) #'b)
+                 #'id))))))

collects/unstable/cce/test/test-text.ss

@@ -0,0 +1,136 @@
+#lang scheme
+
+(require "checks.ss"
+         "../text.ss")
+
+(provide text-suite)
+
+(define text-suite
+  (test-suite "text.ss"
+    (test-suite "text/c"
+      (test-ok (with/c text/c "text"))
+      (test-ok (with/c text/c #"text"))
+      (test-ok (with/c text/c 'text))
+      (test-ok (with/c text/c '#:text))
+      (test-ok (with/c text/c #'"text"))
+      (test-ok (with/c text/c #'#"text"))
+      (test-ok (with/c text/c #'text))
+      (test-ok (with/c text/c #'#:text))
+      (test-bad (with/c text/c '(not text))))
+    (test-suite "text?"
+      (test-case "accept string"
+        (check-pred text? "text"))
+      (test-case "accept byte string"
+        (check-pred text? #"text"))
+      (test-case "accept symbol"
+        (check-pred text? 'text))
+      (test-case "accept keyword"
+        (check-pred text? '#:text))
+      (test-case "accept string literal"
+        (check-pred text? #'"text"))
+      (test-case "accept byte string literal"
+        (check-pred text? #'#"text"))
+      (test-case "accept identifier"
+        (check-pred text? #'text))
+      (test-case "accept keyword literal"
+        (check-pred text? #'#:text))
+      (test-case "reject non-text"
+        (check-false (text? '(not text)))))
+    (test-suite "string-literal?"
+      (test-case "accept" (check-true (string-literal? #'"string")))
+      (test-case "reject" (check-false (string-literal? "string"))))
+    (test-suite "keyword-literal?"
+      (test-case "accept" (check-true (keyword-literal? #'#:keyword)))
+      (test-case "reject" (check-false (keyword-literal? '#:keyword))))
+    (test-suite "bytes-literal?"
+      (test-case "accept" (check-true (bytes-literal? #'#"bytes")))
+      (test-case "reject" (check-false (bytes-literal? #"bytes"))))
+    (test-suite "text=?"
+      (test-case "string = string"
+        (check text=? "abc" (string-copy "abc")))
+      (test-case "string != string"
+        (check-not text=? "abc" (string-copy "cba")))
+      (test-case "string = identifier"
+        (check text=? "car" #'car))
+      (test-case "string != identifier"
+        (check-not text=? "car" #'cdr))
+      (test-case "identifier = identifier, different bindings"
+        (check text=? #'car (datum->syntax #f 'car)))
+      (test-case "identifier != identifier, no bindings"
+        (check-not text=? #'UNBOUND (datum->syntax #f 'ALSO-UNBOUND))))
+    (test-suite "text<?"
+      (test-case "string < string"
+        (check text<? "abc" "def"))
+      (test-case "string !< string"
+        (check-not text<? "abc" "abc"))
+      (test-case "string < identifier"
+        (check text<? "abc" #'def))
+      (test-case "string !< identifier"
+        (check-not text<? "abc" #'abc)))
+    (test-suite "text<=?"
+      (test-case "string <= string"
+        (check text<=? "abc" "abc"))
+      (test-case "string !<= string"
+        (check-not text<=? "def" "abc"))
+      (test-case "string <= identifier"
+        (check text<=? "abc" #'abc))
+      (test-case "string !<= identifier"
+        (check-not text<=? "def" #'abc)))
+    (test-suite "text>?"
+      (test-case "string > string"
+        (check text>? "def" "abc"))
+      (test-case "string !> string"
+        (check-not text>? "abc" "abc"))
+      (test-case "string > identifier"
+        (check text>? "def" #'abc))
+      (test-case "string !> identifier"
+        (check-not text>? "abc" #'abc)))
+    (test-suite "text>=?"
+      (test-case "string >= string"
+        (check text>=? "abc" "abc"))
+      (test-case "string !>= string"
+        (check-not text>=? "abc" "def"))
+      (test-case "string >= identifier"
+        (check text>=? "abc" #'abc))
+      (test-case "string !>= identifier"
+        (check-not text>=? "abc" #'def)))
+    (test-suite "text->string"
+      (test-case "single" (check-equal? (text->string 'abc) "abc"))
+      (test-case "multiple" (check-equal? (text->string 'a "b" #'c) "abc")))
+    (test-suite "text->symbol"
+      (test-case "single" (check-equal? (text->symbol "abc") 'abc))
+      (test-case "multiple" (check-equal? (text->symbol 'a "b" #'c) 'abc)))
+    (test-suite "text->keyword"
+      (test-case "single" (check-equal? (text->keyword #'abc) '#:abc))
+      (test-case "multiple" (check-equal? (text->keyword 'a "b" #'c) '#:abc)))
+    (test-suite "text->bytes"
+      (test-case "single" (check-equal? (text->bytes "abc") #"abc"))
+      (test-case "multiple" (check-equal? (text->bytes 'a "b" #'c) #"abc")))
+    (test-suite "text->identifier"
+      (test-case "single, no context"
+        (check-equal? (syntax-e (text->identifier "abc")) 'abc))
+      (test-case "multiple w/ context"
+        (check bound-identifier=?
+               (text->identifier #:stx #'here 'a "b" #'c)
+               #'abc)))
+    (test-suite "text->string-literal"
+      (test-case "single"
+        (check-equal? (syntax-e (text->string-literal '#:abc)) "abc"))
+      (test-case "multiple"
+        (check-equal?
+         (syntax-e (text->string-literal #:stx #'here 'a "b" #'c))
+         "abc")))
+    (test-suite "text->keyword-literal"
+      (test-case "single"
+        (check-equal? (syntax-e (text->keyword-literal #"abc")) '#:abc))
+      (test-case "multiple"
+        (check-equal?
+         (syntax-e (text->keyword-literal #:stx #'here 'a "b" #'c))
+         '#:abc)))
+    (test-suite "text->bytes-literal"
+      (test-case "single"
+        (check-equal? (syntax-e (text->bytes-literal 'abc)) #"abc"))
+      (test-case "multiple"
+        (check-equal?
+         (syntax-e (text->bytes-literal #:stx #'here 'a "b" #'c))
+         #"abc")))))

collects/unstable/cce/test/test-values.ss

@@ -0,0 +1,63 @@
+#lang scheme
+
+(require "checks.ss"
+         "../values.ss")
+
+(provide values-suite)
+
+(define values-suite
+  (test-suite "values.ss"
+    (test-suite "map2"
+      (test-case "numerator and denominator"
+        (let*-values ([(ns ds)
+                       (map2
+                        (lambda (r)
+                          (values (numerator r) (denominator r)))
+                        (list 1/2 3/4 5/6))])
+          (check-equal? (list ns ds) (list '(1 3 5) '(2 4 6))))))
+    (test-suite "map/values"
+      (test-case "complex numerator and denominator"
+        (let*-values ([(rns rds ins ids)
+                       (map/values
+                        4
+                        (lambda (c)
+                          (values (numerator (real-part c))
+                                  (denominator (real-part c))
+                                  (numerator (imag-part c))
+                                  (denominator (imag-part c))))
+                        (list 1/2+3/4i 5/6+7/8i))])
+          (check-equal? (list rns rds ins ids)
+                        (list '(1 5) '(2 6) '(3 7) '(4 8)))))
+      (test-case "multiple lists"
+        (let*-values ([(as bs cs)
+                       (map/values 3 values '(1 2 3) '(4 5 6) '(7 8 9))])
+          (check-equal? as '(1 2 3))
+          (check-equal? bs '(4 5 6))
+          (check-equal? cs '(7 8 9)))))
+    (test-suite "foldl/values"
+      (test-case "sum, product, and last"
+        (let*-values ([(sum prod last)
+                       (foldl/values
+                        (lambda (next sum prod last)
+                          (values (+ next sum)
+                                  (* next prod)
+                                  next))
+                        (list 0 1 #f)
+                        (list 1 2 3 4))])
+          (check-equal? (list sum prod last)
+                        (list 10 24 4)))))
+    (test-suite "foldr/values"
+      (test-case "sum, product, and last"
+        (let*-values ([(sum prod last)
+                       (foldr/values
+                        (lambda (next sum prod last)
+                          (values (+ next sum)
+                                  (* next prod)
+                                  next))
+                        (list 0 1 #f)
+                        (list 1 2 3 4))])
+          (check-equal? (list sum prod last)
+                        (list 10 24 1)))))
+    (test-suite "values->list"
+      (test-case "1 2 3 4"
+        (check-equal? (values->list (values 1 2 3 4)) (list 1 2 3 4))))))

collects/unstable/cce/test/test-web.ss

@@ -0,0 +1,22 @@
+#lang scheme
+
+(require "checks.ss"
+         "../web.ss")
+
+(provide web-suite)
+
+(define web-suite
+  (test-suite "web.ss"
+    (test-suite "css?"
+      (test-true "CSS" (css? '((foo (a b) (c d)) (bar (w x) (y z)))))
+      (test-false "not CSS" (css? '(a b c d))))
+    (test-suite "css/c"
+      (test-ok "CSS" (with/c css/c '((foo (a b) (c d)) (bar (w x) (y z)))))
+      (test-bad "not CSS" (with/c css/c '(a b c d))))
+    (test-suite "xexpr/c"
+      (test-ok "XExpr" (with/c xexpr/c '(a ([href "url"]) "somewhere")))
+      (test-bad "not XExpr" (with/c xexpr/c '(a ("href" url) . "nowhere"))))
+    (test-suite "write-css")
+    (test-suite "write-xexpr")
+    (test-suite "create-stylesheet")
+    (test-suite "create-webpage")))

collects/unstable/cce/text.ss

@@ -0,0 +1,129 @@
+#lang scheme/base
+
+(require scheme/list scheme/match scheme/contract)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  TEXT DATATYPE
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (literal? pred? v)
+  (and (syntax? v) (pred? (syntax-e v))))
+
+(define (string-literal? v) (literal? string? v))
+(define (bytes-literal? v) (literal? bytes? v))
+(define (keyword-literal? v) (literal? keyword? v))
+
+(define (text? v)
+  (or (symbol? v)
+      (string? v)
+      (keyword? v)
+      (bytes? v)
+      (and (syntax? v) (text? (syntax-e v)))))
+
+(define (text=? a b)
+  (string=? (to-string a) (to-string b)))
+
+(define (text>? a b)
+  (string>? (to-string a) (to-string b)))
+
+(define (text>=? a b)
+  (string>=? (to-string a) (to-string b)))
+
+(define (text<? a b)
+  (string<? (to-string a) (to-string b)))
+
+(define (text<=? a b)
+  (string<=? (to-string a) (to-string b)))
+
+(define (to-string t)
+  (cond
+   [(string? t) t]
+   [(symbol? t) (symbol->string t)]
+   [(keyword? t) (keyword->string t)]
+   [(bytes? t) (bytes->string/utf-8 t)]
+   [(syntax? t) (to-string (syntax-e t))]))
+
+(define (combine-strings before between after strs)
+  (apply
+   string-append
+   before
+   (let loop ([strs strs])
+     (match strs
+       [(list) (list after)]
+       [(list str) (list str after)]
+       [(cons str strs) (list* str between (loop strs))]))))
+
+(define ((to-text convert)
+         #:before [before ""]
+         #:between [between ""]
+         #:after [after ""]
+         . ts)
+  (convert (combine-strings (to-string before)
+                            (to-string between)
+                            (to-string after)
+                            (map to-string ts))))
+
+(define text->string (to-text values))
+(define text->symbol (to-text string->symbol))
+(define text->keyword (to-text string->keyword))
+(define text->bytes (to-text string->bytes/utf-8))
+
+(define ((to-literal convert)
+         #:stx [stx #f]
+         #:before [before ""]
+         #:between [between ""]
+         #:after [after ""]
+         . ts)
+  (datum->syntax
+   stx
+   (convert (combine-strings (to-string before)
+                             (to-string between)
+                             (to-string after)
+                             (map to-string ts)))
+   stx
+   stx
+   stx))
+
+(define text->string-literal (to-literal values))
+(define text->identifier (to-literal string->symbol))
+(define text->keyword-literal (to-literal string->keyword))
+(define text->bytes-literal (to-literal string->bytes/utf-8))
+
+(define text/c (flat-named-contract "text" text?))
+
+(define (convert/c result/c)
+  (->* []
+       [#:before text/c #:between text/c #:after text/c]
+       #:rest (listof text/c)
+       result/c))
+
+(define (convert-literal/c result/c)
+  (->* []
+       [#:before text/c
+        #:between text/c
+        #:after text/c
+        #:stx (or/c false/c syntax?)]
+       #:rest (listof text/c)
+       result/c))
+
+(provide/contract
+ [text/c flat-contract?]
+ [text? (-> any/c boolean?)]
+ [string-literal? (-> any/c boolean?)]
+ [keyword-literal? (-> any/c boolean?)]
+ [bytes-literal? (-> any/c boolean?)]
+ [text=? (-> text/c text/c boolean?)]
+ [text>? (-> text/c text/c boolean?)]
+ [text>=? (-> text/c text/c boolean?)]
+ [text<? (-> text/c text/c boolean?)]
+ [text<=? (-> text/c text/c boolean?)]
+ [text->string (convert/c string?)]
+ [text->symbol (convert/c symbol?)]
+ [text->keyword (convert/c keyword?)]
+ [text->bytes (convert/c bytes?)]
+ [text->identifier (convert-literal/c identifier?)]
+ [text->string-literal (convert-literal/c string-literal?)]
+ [text->keyword-literal (convert-literal/c keyword-literal?)]
+ [text->bytes-literal (convert-literal/c bytes-literal?)])

collects/unstable/cce/values.ss

@@ -0,0 +1,63 @@
+#lang scheme/base
+(require (for-syntax scheme/base))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  MULTIPLE VALUES TOOLS
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax (values->list stx)
+  (syntax-case stx ()
+    [(vl expr)
+     (syntax/loc stx
+       (call-with-values (lambda () expr) list))]))
+
+(define (map/list n f ls)
+  (cond
+   [(andmap null? ls) (build-list n (lambda (i) null))]
+   [(andmap pair? ls)
+    (let* ([vs (values->list (apply f (map car ls)))]
+           [k (length vs)])
+      (unless (= k n)
+        (error 'map/values
+               "~a produced ~a values, not ~a: ~e"
+               f k n vs))
+      (map cons vs (map/list n f (map cdr ls))))]
+   [else (error 'map/values "list lengths differ")]))
+
+(define (map/values n f . ls)
+  (apply values (map/list n f ls)))
+
+(define (map2 f . ls)
+  (apply values (map/list 2 f ls)))
+
+(define (foldr/list f vs ls)
+  (cond
+   [(andmap null? ls) vs]
+   [(andmap pair? ls)
+    (values->list
+     (apply
+      f
+      (append
+       (map car ls)
+       (foldr/list f vs (map cdr ls)))))]
+   [else (error 'foldr/values "list lengths differ")]))
+
+(define (foldr/values f vs . ls)
+  (apply values (foldr/list f vs ls)))
+
+(define (foldl/list f vs ls)
+  (cond
+   [(andmap null? ls) vs]
+   [(andmap pair? ls)
+    (foldl/list
+     f
+     (values->list (apply f (append (map car ls) vs)))
+     (map cdr ls))]
+   [else (error 'foldl/values "list lengths differ")]))
+
+(define (foldl/values f vs . ls)
+  (apply values (foldl/list f vs ls)))
+
+(provide map2 map/values foldr/values foldl/values values->list)

collects/unstable/cce/web.ss

@@ -0,0 +1,98 @@
+#lang scheme
+(require xml
+         "define.ss"
+         "function.ss"
+         "text.ss")
+
+;; css/c : FlatContract
+;; Recognizes representations of Cascading Style Sheets.
+(define css/c (listof (cons/c text/c (listof (list/c text/c text/c)))))
+
+(provide/contract
+ [css/c flat-contract?]
+ [css? (-> any/c boolean?)]
+ [write-css (->* [css/c] [output-port?] void?)])
+
+;; A Cascading Style Sheet (CSS) is a (Listof StyleDefn)
+;; A Style Definition (StyleDefn) is a (cons Selectors (Listof PropDefn))
+;; A Selectors is a Selector or a (NonEmptyListof Selector)
+;; A Selector is a Symbol or String
+;; A Property Definition (PropDefn) is a (list PropName PropVal)
+;; A Property Name (PropName) is a Symbol or String
+;; A Property Value (PropVal) is a Symbol or String
+
+;; css? : Any -> Boolean
+;; Reports whether a value is a CSS.
+(define css? (flat-contract-predicate css/c))
+
+;; write-css : CSS [OutputPort] -> Void
+;; Writes a CSS datastructure as a proper text Cascading Style Sheet.
+(define write-css
+  (lambda/parameter (css [output #:param current-output-port])
+    (for-each write-style-defn css)))
+
+;; write-style-defn : StyleDefn [OutputPort] -> Void
+;; Writes a style definition to a Cascading Style Sheet.
+(define write-style-defn
+  (lambda/parameter (style-defn [output #:param current-output-port])
+    (write-selector (car style-defn))
+    (display " {")
+    (for-each write-prop-defn (cdr style-defn))
+    (display " }\n")))
+
+;; write-text : Text [OutputPort] -> Void
+;; Writes a text field to a Cascading Style Sheet.
+(define write-text
+  (lambda/parameter (text [output #:param current-output-port])
+    (display (text->string text))))
+
+;; write-selector : Selector [OutputPort] -> Void
+;; Writes a selector to a Cascading Style Sheet.
+(define write-selector write-text)
+
+;; write-prop-defn : PropDefn [OutputPort] -> Void
+;; Writes a property definition to a Cascading Style Sheet.
+(define write-prop-defn
+  (lambda/parameter (prop-defn [output #:param current-output-port])
+    (display " ")
+    (write-prop-name (car prop-defn))
+    (display " : ")
+    (write-prop-val (cadr prop-defn))
+    (display ";")))
+
+;; write-prop-name : PropName [OutputPort] -> Void
+;; Writes a property name to a Cascading Style Sheet.
+(define write-prop-name write-text)
+
+;; write-prop-val : PropVal [OutputPort] -> Void
+;; Writes a property value to a Cascading Style Sheet.
+(define write-prop-val write-text)
+
+(define-if-unbound xexpr/c
+  (flat-named-contract "Xexpr" xexpr?))
+
+(provide xexpr/c)
+(provide/contract
+ [write-xexpr (->* [xexpr/c] [output-port?] void?)])
+
+(define write-xexpr
+  (lambda/parameter (xexpr [output #:param current-output-port])
+    (write-xml/content (xexpr->xml xexpr))))
+
+(provide/contract
+ [create-webpage (string? xexpr/c . -> . void?)]
+ [create-stylesheet (string? css/c . -> . void?)])
+
+;; create-stylesheet : String CSS -> Void
+;; Writes an individual stylesheet to a file.
+(define (create-stylesheet filename css)
+  (let* ([out-port (open-output-file filename #:exists 'replace)])
+    (write-css css out-port)
+    (close-output-port out-port)))
+
+;; create-webpage : String XExpr -> Void
+;; Writes an individual webpage to a file.
+(define (create-webpage filename xexpr)
+  (let* ([out-port (open-output-file filename #:exists 'replace)])
+    (write-xexpr xexpr out-port)
+    (close-output-port out-port)))

collects/unstable/scribblings/unstable.scrbl

@@ -98,6 +98,9 @@ Keep documentation and tests up to date.
 @include-section["debug.scrbl"]
 @include-section["byte-counting-port.scrbl"]
 
+;; This addition is temporary while integrating (planet cce/scheme:7):
+@include-section["../cce/reference/manual.scrbl"]
+
 @;{--------}
 
 @;{