[racket-dev] [plt] Push #22869: master branch updated

From: Matthias Felleisen (matthias at ccs.neu.edu)
Date: Fri Jun 24 15:51:07 EDT 2011

ARGH. This sure needs a lot of additional documentation to become usable. And please don't write "temporal contracts come with Racket" based on the 'unstable' addition. That would make me major-unhappy. 


On Jun 24, 2011, at 3:48 PM, jay at racket-lang.org wrote:

> jay has updated `master' from 5c77b19416 to 6abeab42d5.
>  http://git.racket-lang.org/plt/5c77b19416..6abeab42d5
> 
> =====[ 2 Commits ]======================================================
> 
> Directory summary:
>   6.8% collects/tests/unstable/automata/
>  39.4% collects/tests/unstable/temp-c/
>  15.6% collects/unstable/automata/scribblings/
>  25.2% collects/unstable/automata/
>   7.1% collects/unstable/temp-c/scribblings/
>   5.2% collects/unstable/temp-c/
> 
> ~~~~~~~~~~
> 
> 375d6b8 Jay McCarthy <jay at racket-lang.org> 2011-06-24 12:05
> :
> | Initial adding of temporal contract library
> :
>  M collects/meta/props |    4 ++++
>  A collects/tests/unstable/automata/dfa-test.rkt
>  A collects/tests/unstable/automata/explain.rkt
>  A collects/tests/unstable/automata/nfa-ep-test.rkt
>  A collects/tests/unstable/automata/nfa-star-test.rkt
>  A collects/tests/unstable/automata/nfa-test.rkt
>  A collects/tests/unstable/automata/re-test.rkt
>  A collects/tests/unstable/temp-c/bench-affine.rkt
>  A collects/tests/unstable/temp-c/bench.rkt
>  A collects/tests/unstable/temp-c/dr-err-help.rkt
>  A collects/tests/unstable/temp-c/dr-err.rkt
>  A collects/tests/unstable/temp-c/ex-con.rkt
>  A collects/tests/unstable/temp-c/ex-dsl.rkt
>  A collects/tests/unstable/temp-c/ex-lock.rkt
>  A collects/tests/unstable/temp-c/ex-matthias-a.rkt
>  A collects/tests/unstable/temp-c/ex-matthias-b.rkt
>  A collects/tests/unstable/temp-c/ex-matthias-ctc.rkt
>  A collects/tests/unstable/temp-c/ex-matthias.rkt
>  A collects/tests/unstable/temp-c/ex-memclass.rkt
>  A collects/tests/unstable/temp-c/ex-mem.rkt
>  A collects/tests/unstable/temp-c/ex-turn.rkt
>  A collects/tests/unstable/temp-c/future-ctc.rkt
>  A collects/tests/unstable/temp-c/id-bench.rkt
>  A collects/tests/unstable/temp-c/test-temporal-no-call-after-return2.rkt
>  A collects/tests/unstable/temp-c/test-temporal-no-call-after-return.rkt
>  A collects/tests/unstable/temp-c/ttt-bench-com.rkt
>  A collects/tests/unstable/temp-c/ttt-bench-ctc.rkt
>  A collects/tests/unstable/temp-c/ttt-bench-raw.rkt
>  A collects/tests/unstable/temp-c/ttt-bench.rkt
>  A collects/tests/unstable/temp-c/ttt-players.rkt
>  A collects/tests/unstable/temp-c/ttt.rkt
>  A collects/unstable/automata/dfa.rkt
>  A collects/unstable/automata/info.rkt
>  A collects/unstable/automata/machine.rkt
>  A collects/unstable/automata/nfa-ep.rkt
>  A collects/unstable/automata/nfa.rkt
>  A collects/unstable/automata/nfa-star.rkt
>  A collects/unstable/automata/re-compile.rkt
>  A collects/unstable/automata/re-ext.rkt
>  A collects/unstable/automata/re-help.rkt
>  A collects/unstable/automata/re.rkt
>  A collects/unstable/automata/scribblings/automata.scrbl
>  A collects/unstable/automata/scribblings/re.scrbl
>  A collects/unstable/temp-c/dsl.rkt
>  A collects/unstable/temp-c/info.rkt
>  A collects/unstable/temp-c/monitor.rkt
>  A collects/unstable/temp-c/scribblings/temp-c.scrbl
> 
> ~~~~~~~~~~
> 
> 6abeab4 Jay McCarthy <jay at racket-lang.org> 2011-06-24 13:47
> :
> | Updating require paths, making tests succeed, and fixing docs
> :
>  M collects/tests/unstable/automata/dfa-test.rkt                |    5 +-
>  M collects/tests/unstable/automata/explain.rkt                 |    7 +-
>  M collects/tests/unstable/automata/nfa-ep-test.rkt             |    5 +-
>  M collects/tests/unstable/automata/nfa-star-test.rkt           |    5 +-
>  M collects/tests/unstable/automata/nfa-test.rkt                |    5 +-
>  M collects/tests/unstable/automata/re-test.rkt                 |    7 +-
>  M collects/tests/unstable/temp-c/bench-affine.rkt              |    3 +-
>  M collects/tests/unstable/temp-c/bench.rkt                     |    6 +-
>  M collects/tests/unstable/temp-c/ex-con.rkt                    |    6 +-
>  M collects/tests/unstable/temp-c/ex-dsl.rkt                    |    3 +-
>  M collects/tests/unstable/temp-c/ex-lock.rkt                   |    2 +-
>  M collects/tests/unstable/temp-c/ex-matthias-a.rkt             |    3 +-
>  M collects/tests/unstable/temp-c/ex-matthias-b.rkt             |    9 +-
>  M collects/tests/unstable/temp-c/ex-matthias-ctc.rkt           |   17 ++--
>  M collects/tests/unstable/temp-c/ex-matthias.rkt               |   20 +++---
>  M collects/tests/unstable/temp-c/ex-memclass.rkt               |    2 +-
>  M collects/tests/unstable/temp-c/ex-mem.rkt                    |    8 +-
>  D collects/tests/unstable/temp-c/ex-turn.rkt
>  M collects/tests/unstable/temp-c/future-ctc.rkt                |    3 +-
>  M collects/tests/unstable/temp-c/id-bench.rkt                  |    3 +-
>  M collects/tests/unstable/temp-c/ttt-bench.rkt                 |    2 +-
>  M collects/tests/unstable/temp-c/ttt.rkt                       |    3 +-
>  D collects/unstable/automata/info.rkt
>  M collects/unstable/automata/scribblings/automata.scrbl        |   26 +++---
>  M collects/unstable/automata/scribblings/re.scrbl              |   20 +++---
>  M collects/unstable/scribblings/unstable.scrbl                 |    2 +
>  M collects/unstable/temp-c/dsl.rkt                             |   10 +-
>  D collects/unstable/temp-c/info.rkt
>  M collects/unstable/temp-c/scribblings/temp-c.scrbl            |   18 ++--
>  M .../unstable/temp-c/test-temporal-no-call-after-return2.rkt  |   10 ++-
>  M .../unstable/temp-c/test-temporal-no-call-after-return.rkt   |   10 ++-
> 
> =====[ Overall Diff ]===================================================
> 
> collects/meta/props
> ~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/meta/props
> +++ NEW/collects/meta/props
> @@ -1960,10 +1960,12 @@ path/s is either such a string or a list of them.
> "collects/tests/units/test-unit-contracts.rktl" drdr:command-line (racket "-f" *)
> "collects/tests/units/test-unit.rktl" drdr:command-line (racket "-f" *)
> "collects/tests/unstable" responsible (jay samth cce ryanc)
> +"collects/tests/unstable/automata" responsible (jay)
> "collects/tests/unstable/byte-counting-port.rkt" responsible (jay)
> "collects/tests/unstable/generics.rkt" responsible (jay)
> "collects/tests/unstable/list.rkt" responsible (jay)
> "collects/tests/unstable/srcloc.rktl" responsible (cce) drdr:command-line (racket "-f" *)
> +"collects/tests/unstable/temp-c" responsible (jay)
> "collects/tests/utils/gui.rkt" drdr:command-line (gracket-text "-t" *)
> "collects/tests/web-server" responsible (jay)
> "collects/tests/web-server/pr/length.rkt" drdr:command-line #f
> @@ -2004,6 +2006,7 @@ path/s is either such a string or a list of them.
> "collects/typed-scheme" responsible (samth stamourv)
> "collects/typed-scheme/optimizer" responsible (stamourv)
> "collects/unstable" responsible (jay samth cce ryanc)
> +"collects/unstable/automata" responsible (jay)
> "collects/unstable/byte-counting-port.rkt" responsible (jay)
> "collects/unstable/debug.rkt" responsible (samth)
> "collects/unstable/gui/language-level.rkt" drdr:command-line (gracket-text "-t" *)
> @@ -2024,6 +2027,7 @@ path/s is either such a string or a list of them.
> "collects/unstable/scribblings/sequence.scrbl" responsible (samth)
> "collects/unstable/scribblings/utils.rkt" responsible (samth)
> "collects/unstable/sequence.rkt" responsible (samth)
> +"collects/unstable/temp-c" responsible (jay)
> "collects/version" responsible (eli)
> "collects/version/tool.rkt" drdr:command-line (gracket-text "-t" *)
> "collects/waterworld/waterworld.rkt" drdr:command-line (mzc *)
> 
> collects/tests/unstable/automata/dfa-test.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/automata/dfa-test.rkt
> @@ -0,0 +1,23 @@
> +#lang racket/base
> +(require unstable/automata/dfa
> +         unstable/automata/machine
> +         tests/eli-tester)
> +
> +(define M
> +  (dfa s1 (s1 s3)
> +       [s1 ([0 s2]
> +            [1 s1])]
> +       [s2 ([0 s1]
> +            [1 s2])]
> +       [s3 ([0 s3]
> +            [1 s4])]
> +       [s4 ([0 s4]
> +            [1 s3])]))
> +
> +(test
> + (machine-accepts? M (list 1 0 1 0 1))
> + (machine-accepts? M (list 0 1 0 1 0)) => #f
> + (machine-accepts? M (list 1 0 1 1 0 1))
> + (machine-accepts? M (list 0 1 0 0 1 0))
> + (machine-accepts? M (list))
> + (machine-accepts? M (list 1 0)) => #f)
> \ No newline at end of file
> 
> collects/tests/unstable/automata/explain.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/automata/explain.rkt
> @@ -0,0 +1,11 @@
> +#lang racket
> +(require unstable/automata/re
> +         unstable/automata/re-ext
> +         unstable/automata/machine
> +         unstable/match
> +         tests/eli-tester)
> +
> +(define r (re (seq 1 2 3)))
> +(define r0 (r 1))
> +(machine-accepting? (r0 1))
> +(machine-explain r0)
> \ No newline at end of file
> 
> collects/tests/unstable/automata/nfa-ep-test.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/automata/nfa-ep-test.rkt
> @@ -0,0 +1,25 @@
> +#lang racket/base
> +(require unstable/automata/nfa-ep
> +         unstable/automata/machine
> +         tests/eli-tester)
> +
> +(define M
> +  (nfa/ep (s0) (s1 s3)
> +       [s0 ([epsilon (s1)]
> +            [epsilon (s3)])]
> +       [s1 ([0 (s2)]
> +            [1 (s1)])]
> +       [s2 ([0 (s1)]
> +            [1 (s2)])]
> +       [s3 ([0 (s3)]
> +            [1 (s4)])]
> +       [s4 ([0 (s4)]
> +            [1 (s3)])]))
> +
> +(test
> + (machine-accepts? M (list 1 0 1 0 1))
> + (machine-accepts? M (list 0 1 0 1 0))
> + (machine-accepts? M (list 1 0 1 1 0 1))
> + (machine-accepts? M (list 0 1 0 0 1 0))
> + (machine-accepts? M (list))
> + (machine-accepts? M (list 1 0)) => #f)
> \ No newline at end of file
> 
> collects/tests/unstable/automata/nfa-star-test.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/automata/nfa-star-test.rkt
> @@ -0,0 +1,26 @@
> +#lang racket/base
> +(require unstable/automata/nfa-star
> +         unstable/automata/machine
> +         tests/eli-tester)
> +
> +(define M
> +  (nfa*
> +   (s0)
> +   ([s1 ([0 (s2)]
> +         [1 (s1)])]
> +    [s3 ([0 (s3)]
> +         [1 (s4)])])
> +   ([s0 ([epsilon (s1)]
> +         [epsilon (s3)])]
> +    [s2 ([0 (s1)]
> +         [1 (s2)])]
> +    [s4 ([0 (s4)]
> +         [1 (s3)])])))
> +
> +(test
> + (machine-accepts? M (list 1 0 1 0 1))
> + (machine-accepts? M (list 0 1 0 1 0))
> + (machine-accepts? M (list 1 0 1 1 0 1))
> + (machine-accepts? M (list 0 1 0 0 1 0))
> + (machine-accepts? M (list))
> + (machine-accepts? M (list 1 0)) => #f)
> \ No newline at end of file
> 
> collects/tests/unstable/automata/nfa-test.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/automata/nfa-test.rkt
> @@ -0,0 +1,23 @@
> +#lang racket/base
> +(require unstable/automata/nfa
> +         unstable/automata/machine
> +         tests/eli-tester)
> +
> +(define M
> +  (nfa (s1 s3) (s1 s3)
> +       [s1 ([0 (s2)]
> +            [1 (s1)])]
> +       [s2 ([0 (s1)]
> +            [1 (s2)])]
> +       [s3 ([0 (s3)]
> +            [1 (s4)])]
> +       [s4 ([0 (s4)]
> +            [1 (s3)])]))
> +
> +(test
> + (machine-accepts? M (list 1 0 1 0 1))
> + (machine-accepts? M (list 0 1 0 1 0))
> + (machine-accepts? M (list 1 0 1 1 0 1))
> + (machine-accepts? M (list 0 1 0 0 1 0))
> + (machine-accepts? M (list))
> + (machine-accepts? M (list 1 0)) => #f)
> \ No newline at end of file
> 
> collects/tests/unstable/automata/re-test.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/automata/re-test.rkt
> @@ -0,0 +1,155 @@
> +#lang racket
> +(require unstable/automata/machine
> +         unstable/automata/re
> +         unstable/automata/re-ext
> +         unstable/match
> +         tests/eli-tester)
> +
> +(define-syntax-rule (test-re* R (succ ...) (fail ...))
> +  (let ()
> +    (define r (re R))
> +    (test #:failure-prefix (format "~s" 'R)
> +          (test
> +           (machine-accepts? r succ) ...
> +           (not (machine-accepts? r fail)) ...))))
> +(define-syntax-rule (test-re R (succ ...) (fail ...))
> +  (test (test-re* R (succ ...) (fail ...))
> +        (test-re* (complement R) (fail ...) (succ ...))))
> +
> +(test
> + (test-re epsilon
> +          [(list)]
> +          [(list 0)])
> + 
> + (test-re nullset
> +          []
> +          [(list) (list 1)])
> + 
> + (test-re "A"
> +          [(list "A")]
> +          [(list)
> +           (list "B")])
> + 
> + (test-re (complement "A")
> +          [(list)
> +           (list "B")
> +           (list "A" "A")]
> +          [(list "A")])
> + 
> + (test-re (union 0 1)
> +          [(list 1)
> +           (list 0)]
> +          [(list)
> +           (list 0 1)
> +           (list 0 1 1)])
> + 
> + (test-re (seq 0 1)
> +          [(list 0 1)]
> +          [(list)
> +           (list 0)
> +           (list 0 1 1)])
> + 
> + (test-re (star 0)
> +          [(list)
> +           (list 0)
> +           (list 0 0)]
> +          [(list 1)])
> + 
> + (test-re (opt "A")
> +          [(list)
> +           (list "A")]
> +          [(list "B")])
> + 
> + (test-re (plus "A")
> +          [(list "A")
> +           (list "A" "A")]
> +          [(list)])
> + 
> + (test-re (rep "A" 3)
> +          [(list "A" "A" "A")]
> +          [(list)
> +           (list "A")
> +           (list "A" "A")])
> + 
> + (test-re (difference (? even?) 2)
> +          [(list 4)
> +           (list 6)]
> +          [(list 3)
> +           (list 2)])
> + 
> + (test-re (intersection (? even?) 2)
> +          [(list 2)]
> +          [(list 1)
> +           (list 4)])
> + 
> + (test-re (complement (seq "A" (opt "B")))
> +          [(list "A" "B" "C")]
> +          [(list "A")
> +           (list "A" "B")])
> + 
> + (test-re (seq epsilon 1)
> +          [(list 1)]
> +          [(list 0)
> +           (list)])
> + 
> + (test-re (seq 1 epsilon)
> +          [(list 1)]
> +          [(list 0)
> +           (list)])
> + 
> + (test-re (seq epsilon
> +               (union (seq (star 1) (star (seq 0 (star 1) 0 (star 1))))
> +                      (seq (star 0) (star (seq 1 (star 0) 1 (star 0)))))
> +               epsilon)
> +          [(list 1 0 1 0 1)
> +           (list 0 1 0 1 0)
> +           (list 1 0 1 1 0 1)
> +           (list 0 1 0 0 1 0)
> +           (list)]
> +          [(list 1 0)])
> + 
> + (test-re (star (complement 1))
> +          [(list 0 2 3 4)
> +           (list)
> +           (list 2)
> +           ; This is correct, because the complement machine
> +           ; could accept '(234 5 9 1), which is not '(1)
> +           ; Then the star kicks in and it accepts '(9 0)
> +           (list 234 5 9 1 9 0)
> +           (list 1 0)
> +           (list 0 1)]
> +          [(list 1)])
> + 
> + (test-re (dseq x (== x))
> +          [(list 0 0)
> +           (list 1 1)]
> +          [(list)
> +           (list 1)
> +           (list 1 0)])
> + 
> + (test-re (seq 1 (seq 2 3))
> +          [(list 1 2 3)]
> +          [(list 1)
> +           (list 1 2)])
> + 
> + (test-re (rec x
> +            (union #f
> +                   (seq 1 ,x)))
> +          [(list #f)
> +           (list 1 #f)
> +           (list 1 1 #f)
> +           (list 1 1 1 #f)]
> +          [(list 1)
> +           (list 2)
> +           (list 1 1 2)])
> + 
> + (test-re (seq/close 1 2 3)
> +          [(list)
> +           (list 1)
> +           (list 1 2)
> +           (list 1 2 3)]
> +          [(list 2)
> +           (list 1 3)
> +           (list 2 3)
> +           (list 1 2 3 4)])
> + )
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/bench-affine.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/bench-affine.rkt
> @@ -0,0 +1,82 @@
> +#lang racket
> +
> +; The code
> +(define (raw f)
> +  (f (λ () (void))))
> +
> +(define (client seed use-affine)
> +  (random-seed seed)
> +  (use-affine
> +   (λ (f)
> +     (define used? #f)
> +     (for ([i (in-range 10000)])
> +       (sync (alarm-evt (random 100)))
> +       (unless (or used? (zero? (random 3)))
> +         (set! used? #t)
> +         (f))))))
> +
> +(define (bad-client use-affine)
> +  (use-affine
> +   (λ (f)
> +     (f)
> +     (f))))
> +
> +; The benchmarks
> +(define ctc
> +  (contract
> +   (-> (-> (-> any/c) any/c) any/c)
> +   raw 'pos 'neg))
> +
> +(define aff->
> +  (make-contract
> +   #:name 'affine
> +   #:first-order procedure?
> +   #:projection
> +   (λ (b)
> +     (λ (f)
> +       (define called? #f)
> +       (λ ()
> +         (when called?
> +           (raise-blame-error b f "called twice!"))
> +         (set! called? #t)
> +         (define x (f))
> +         x)))))
> +(define ad-hoc
> +  (contract
> +   (-> (-> aff-> any/c) any/c)
> +   raw 'pos 'neg))
> +
> +(require unstable/temp-c/dsl)
> +(define (rgx)
> +  (contract
> +   (with-monitor 
> +    (-> (-> (label 'affine (-> any/c)) any/c) any/c)
> +    (complement
> +     (seq (star _)
> +          (call 'affine)
> +          (star _)
> +          (call 'affine))))
> +   raw 'pos 'neg))
> +
> +; The runner
> +(require tests/stress)
> +(define seed (+ 1 (random (expt 2 30))))
> +(define-syntax-rule (STRESS version ...)
> +  (begin
> +    (with-handlers ([exn? (λ (x) (void))])
> +      (bad-client version)
> +      (printf "~a does not fail when it should\n" 'version))
> +    ...
> +    (with-handlers ([exn? (λ (x) 
> +                            (printf "~a fails when it should not\n" 'version))])
> +      (client seed version))
> +    ...
> +    (newline)
> +    (stress 4 
> +            [(format "~a" 'version)
> +             (client seed version)]
> +            ...)))
> +
> +(STRESS raw ctc ad-hoc (rgx))
> +
> +
> 
> collects/tests/unstable/temp-c/bench.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/bench.rkt
> @@ -0,0 +1,93 @@
> +#lang racket/load
> +
> +(module raw-sort racket
> +  (define (insert <= e l)
> +    (cond
> +      [(empty? l)
> +       (list e)]
> +      [(<= e (first l))
> +       (list* e l)]
> +      [else
> +       (list* (first l)
> +              (insert <= e (rest l)))]))
> +  (define (sort <= l)
> +    (if (empty? l)
> +        empty
> +        (insert <= (first l)
> +                (sort <= (rest l)))))
> +  (provide sort))
> +
> +(module ctc-sort racket
> +  (require 'raw-sort)
> +  (provide/contract
> +   [sort (-> (-> any/c any/c boolean?)
> +             (listof any/c)
> +             (listof any/c))]))
> +
> +(module qdsl-sort racket
> +  (require unstable/temp-c/dsl 'raw-sort unstable/match)
> +  (provide make-sort)
> +  (define (make-sort)
> +    (contract
> +     (with-monitor (label 'sort (-> (label 'order (-> any/c any/c boolean?))
> +                                    (listof any/c)
> +                                    (listof any/c)))
> +       (complement
> +        (seq (star _) 
> +             (dseq
> +              (monitor:proj 'order proj _)
> +              (seq (star _)
> +                   (monitor:return 'sort _ _ _ _ _ _ _) (star _)
> +                   (monitor:call 'order (== proj) _ _ _ _ _))))))
> +     sort 'pos 'neg)))
> +
> +(module dsl-sort racket
> +  (require unstable/temp-c/dsl 'raw-sort)
> +  (provide make-sort)
> +  (define (make-sort)
> +    (contract (with-monitor (label 'sort (-> (label 'order (-> any/c any/c boolean?))
> +                                             (listof any/c)
> +                                             (listof any/c)))
> +                (complement
> +                 (seq (star _)
> +                      (monitor:proj 'order _ _) (star _)
> +                      (monitor:return 'sort _ _ _ _ _ _ _) (star _)
> +                      (monitor:call 'order _  _ _ _ _ _))))
> +              sort
> +              'pos 'neg)))
> +
> +(module smart-sort racket
> +  (require unstable/temp-c/monitor 'raw-sort)
> +  (define returned? #f)
> +  (define (sort-monitor evt)
> +    (match evt
> +      [(monitor:proj 'order proj _)
> +       #t]
> +      [(monitor:return 'sort _ _ _ _ _ (list f _) _)
> +       (set! returned? #t)]
> +      [(monitor:call 'order proj _ _ _ _ _)
> +       (not returned?)]
> +      [_ #t]))
> +  (provide/contract
> +   [sort (monitor/c sort-monitor 'sort
> +                    (-> (monitor/c sort-monitor 'order (-> any/c any/c boolean?))
> +                        (listof any/c)
> +                        (listof any/c)))]))
> +
> +(module sort-timer racket
> +  (require (prefix-in dsl: 'dsl-sort)
> +           (prefix-in qdsl: 'qdsl-sort)
> +           (prefix-in smart: 'smart-sort)
> +           (prefix-in raw: 'raw-sort)
> +           (prefix-in ctc: 'ctc-sort)
> +           tests/stress)
> +  
> +  (define l (build-list 200 (compose random add1)))
> +  (stress 1
> +          ["raw" (raw:sort <= l)]
> +          ["ctc" (ctc:sort <= l)]
> +          ["qdsl" ((qdsl:make-sort) <= l)]
> +          ["dsl" ((dsl:make-sort) <= l)]
> +          ["smart" (smart:sort <= l)]))
> +
> +(require 'sort-timer)
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/dr-err-help.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/dr-err-help.rkt
> @@ -0,0 +1,12 @@
> +#lang racket/base
> +(require syntax/parse
> +         (for-template racket/base))
> +
> +(define-syntax-class sre 
> +  #:attributes (machine)
> +  
> +  (pattern pat:expr
> +           #:attr machine
> +           #'1))
> +
> +(provide sre)
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/dr-err.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/dr-err.rkt
> @@ -0,0 +1,15 @@
> +#lang racket/load
> +(module re racket/base
> +  (require (for-syntax syntax/parse
> +                       racket/base
> +                       "dr-err-help.rkt"))
> +  
> +  (define-syntax (re stx)
> +    (syntax-parse
> +     stx
> +     [(_ the-re:sre)
> +      (attribute the-re.machine)]))
> +  
> +  (re _))
> +
> +(require 're)
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ex-con.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-con.rkt
> @@ -0,0 +1,51 @@
> +#lang racket
> +(require unstable/temp-c/dsl
> +         tests/eli-tester)
> +
> +(define count 0)
> +(define (evil? v)
> +  (define nc (add1 count))
> +  (sleep (random))
> +  (set! count nc)
> +  #t)
> +
> +(define (test-spec spec)
> +  (define (f g) g)
> +  (define f/c (contract spec f 'pos 'neg))
> +  
> +  (define x #f)
> +  (define (body)
> +    (with-handlers ([exn? (λ (e) (set! x e))])
> +      (f/c 1)))
> +  (define t1
> +    (thread body))
> +  (define t2
> +    (thread body))
> +  
> +  (thread-wait t1)
> +  (thread-wait t2)
> +  (when x
> +    (raise x)))
> +
> +(define-syntax-rule (dupe r c K T)
> +  (begin (define r (with-monitor K T))
> +         (define c (with-monitor K #:concurrent T))))
> +
> +(dupe Race Concurrent
> +      (label 'f (number? . -> . number?))
> +      (seq (monitor:proj 'f _ _)
> +           (star (union (call 'f (? evil?))
> +                        (ret 'f _)))))
> +
> +(test
> + #:failure-prefix "Race"
> + (test
> +  (set! count 0)
> +  (test-spec Race)
> +  ; This 1 represents the presence of the race
> +  count => 1)
> + #:failure-prefix "Concurrent"
> + (test
> +  (set! count 0)
> +  (test-spec Concurrent)
> +  count => 2))
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ex-dsl.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-dsl.rkt
> @@ -0,0 +1,100 @@
> +#lang racket
> +(require unstable/temp-c/dsl
> +         tests/eli-tester)
> +
> +(define (test-spec spec f)
> +  (define i 0)
> +  (define MallocFreeImpl
> +    (cons (λ () (begin0 i (set! i (add1 i))))
> +          (λ (a) (void))))
> +  (define MallocFreeProt
> +    (contract spec MallocFreeImpl
> +              'pos 'neg))
> +  
> +  (match-define (cons malloc free) MallocFreeProt)
> +  (f malloc free))
> +
> +(define (good malloc free)
> +  (define a (malloc))
> +  (free a)
> +  (define e (malloc))
> +  (define f (malloc))
> +  (free e)
> +  (free f)
> +  (define c (malloc))
> +  (define d (malloc))
> +  (free d)
> +  (free c))
> +
> +(define (bad malloc free)
> +  (define b (malloc))
> +  (free b)
> +  (free b))
> +
> +(define addr? number?)
> +
> +(define NoFreeSpec
> +  (with-monitor 
> +      (cons/c (label 'malloc (-> addr?))
> +              (label 'free (-> addr? void?)))
> +    ; It is okay as long as you never call free
> +    (complement (seq (star _) (call 'free _) (star _)))))
> +(test (test-spec NoFreeSpec good) =error> "disallowed"
> +      (test-spec NoFreeSpec bad) =error> "disallowed")
> +
> +(define NoFreeTwiceSpec
> +  (with-monitor 
> +      (cons/c (label 'malloc (-> addr?))
> +              (label 'free (-> addr? void?)))
> +    (complement (seq (star _) (call 'free _) (star _) (call 'free _) (star _)))))
> +(test (test-spec NoFreeTwiceSpec good) =error> "disallowed"
> +      (test-spec NoFreeTwiceSpec bad) =error> "disallowed")
> +
> +(define MallocFreeBalancedSpec
> +  (with-monitor 
> +      (cons/c (label 'malloc (-> addr?))
> +              (label 'free (-> addr? void?)))
> +    (star 
> +     (seq (call 'malloc)
> +          (ret 'malloc _)
> +          (call 'free _)
> +          (ret 'free _)))))
> +(test (test-spec MallocFreeBalancedSpec good) =error> "disallowed" 
> +      (test-spec MallocFreeBalancedSpec bad) =error> "disallowed")
> +
> +(define MallocFreeSpec
> +  (with-monitor 
> +      (cons/c (label 'malloc (-> addr?))
> +              (label 'free (-> addr? void?)))
> +    (complement (seq (star _)
> +                     (call 'free _)
> +                     (star (not (ret 'malloc _)))
> +                     (call 'free _)))))
> +(test (test-spec MallocFreeSpec good) =error> "disallowed" 
> +      (test-spec MallocFreeSpec bad) =error> "disallowed")
> +
> +(define MallocFreeSpecNQ
> +  (with-monitor 
> +      (cons/c (label 'malloc (-> addr?))
> +              (label 'free (-> addr? void?)))
> +    (complement 
> +     (seq (star _)
> +          (call 'free x)
> +          (star (not (ret 'malloc x)))
> +          (call 'free x)))))
> +(test (test-spec MallocFreeSpecNQ good) =error> "disallowed" 
> +      (test-spec MallocFreeSpecNQ bad) =error> "disallowed")
> +
> +(require unstable/match)
> +(define MallocFreeSpecQ
> +  (with-monitor 
> +      (cons/c (label 'malloc (-> addr?))
> +              (label 'free (-> addr? void?)))
> +    (complement 
> +     (seq (star _)
> +          (dseq (call 'free addr)
> +                (seq
> +                 (star (not (ret 'malloc (== addr))))
> +                 (call 'free (== addr))))))))
> +(test (test-spec MallocFreeSpecQ good)
> +      (test-spec MallocFreeSpecQ bad) =error> "disallowed")
> 
> collects/tests/unstable/temp-c/ex-lock.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-lock.rkt
> @@ -0,0 +1,125 @@
> +#lang racket/load
> +
> +#| This file is an attempt to show a different style of monitor
> +   that doesn't record the event trace, but rather records the
> +   pertinent information.
> +|#
> +
> +(module lock racket
> +  (require unstable/temp-c/monitor)
> +  (define (use-resource f)
> +    (define (protect label g)
> +      (contract (monitor/c monitor label (-> void)) g
> +                'pos 'neg))
> +    
> +    (define locked? #f)
> +    (define returned? #f)
> +    (define (monitor evt)
> +      (match evt
> +        [(monitor:return 'user _ _ app _ _ _ _)
> +         (set! returned? #t)]
> +        [(monitor:return 'lock p  _ _ _ _ _ _)
> +         (set! locked? #t)]
> +        [(monitor:return 'unlock p _ _ _ _ _ _)
> +         (set! locked? #f)]
> +        [_
> +         (void)])
> +      (and
> +       (match evt
> +         ; Must not lock or unlock twice
> +         [(monitor:call 'lock p _ _ _ _ _)
> +          (not locked?)]
> +         [(monitor:call 'unlock p _ _ _ _ _)
> +          locked?]
> +         ; Must not use resource unless locked
> +         [(monitor:call 'use p _ _ _ _ _)
> +          locked?]
> +         ; Otherwise, okay
> +         [_
> +          #t])
> +       ; Must not use anything after return
> +       (match evt
> +         [(monitor:call 'lock p _ _ _ _ _)
> +          (not returned?)]
> +         [(monitor:call 'unlock p _ _ _ _ _)
> +          (not returned?)]
> +         [(monitor:call 'use p _ _ _ _ _)
> +          (not returned?)]
> +         ; Otherwise, okay
> +         [_
> +          #t])))
> +    
> +    ((contract (monitor/c monitor 'user any/c) f
> +               'pos 'neg)
> +     (protect 'lock (λ () (void)))
> +     (protect 'use (λ () (void)))
> +     (protect 'unlock (λ () (void)))))
> +  
> +  (provide/contract
> +   [use-resource
> +    (-> (-> (-> void) (-> void) (-> void)
> +            any/c)
> +        any/c)]))
> +
> +(module tester racket
> +  (require tests/eli-tester
> +           'lock)
> +  (test
> +   (use-resource
> +    (λ (lock use unlock)
> +      (lock) (use) (unlock)
> +      (lock) (use) (use) (unlock)))
> +   =>
> +   (void)
> +   
> +   (use-resource
> +    (λ (lock use unlock)
> +      (lock) (use) (unlock)
> +      (use-resource
> +       (λ (lock1 use1 unlock1)
> +         ; Note out of order unlocking
> +         (lock1) (lock)
> +         (use) (use1)
> +         (unlock1) (unlock)))
> +      (lock) (use) (use) (unlock)))
> +   =>
> +   (void)
> +   
> +   (use-resource
> +    (λ (lock use unlock)
> +      (use)))
> +   =error>
> +   "disallowed"
> +   
> +   (use-resource
> +    (λ (lock use unlock)
> +      (lock) (use) (unlock) (unlock)))
> +   =error>
> +   "disallowed"
> +   
> +   (use-resource
> +    (λ (lock use unlock)
> +      (lock) (lock)))
> +   =error>
> +   "disallowed"
> +   
> +   (use-resource
> +    (λ (lock use unlock)
> +      (lock) (unlock) (use)))
> +   =error>
> +   "disallowed"
> +   
> +   ((use-resource (λ (lock use unlock) lock)))
> +   =error>
> +   "disallowed"
> +   
> +   ((use-resource (λ (lock use unlock) use)))
> +   =error>
> +   "disallowed"
> +   
> +   ((use-resource (λ (lock use unlock) unlock)))
> +   =error>
> +   "disallowed"
> +   ))
> +
> +(require 'tester)
> 
> collects/tests/unstable/temp-c/ex-matthias-a.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-matthias-a.rkt
> @@ -0,0 +1,21 @@
> +#lang racket
> +(require unstable/temp-c/dsl
> +         unstable/match)
> +
> +(define memory%
> +  (class object%
> +    (super-new)
> +    (define/public (malloc) 1)
> +    (define/public (free n) (void))))
> +
> +(provide/contract
> + [memory%
> +  (with-monitor
> +      (class/c [malloc (label 'malloc (->m number?))]
> +               [free (label 'free (->m number? void))])
> +    (complement
> +     (seq (star _)
> +          (dseq (call 'free _ addr)
> +                (seq
> +                 (star (not (ret 'malloc (== addr))))
> +                 (call 'free _ (== addr)))))))])
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ex-matthias-b.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-matthias-b.rkt
> @@ -0,0 +1,10 @@
> +#lang racket
> +(require tests/eli-tester
> +         "ex-matthias-a.rkt")
> +
> +(define memory (new memory%))
> +
> +(define a (send memory malloc))
> +(test
> + (send memory free a)
> + (send memory free a) =error> #rx"disallowed call")
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ex-matthias-ctc.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-matthias-ctc.rkt
> @@ -0,0 +1,25 @@
> +#lang racket/load
> +(module a racket  
> +  (define memory%
> +    (class object%
> +      (super-new)
> +      (define/public (malloc) 1)
> +      (define/public (free n) (void))))
> +  
> +  (provide/contract
> +   [memory%
> +    (class/c [malloc (->m number?)]
> +             [free (->m number? void)])]))
> +
> +(module b racket
> +  (require 'a tests/eli-tester)
> +  
> +  (define memory (new memory%))
> +  
> +  (define a (send memory malloc))
> +  (test
> +   (send memory free a) 
> +   (send memory free "foo") =error> #rx"expected \\<number"
> +   (send memory free a)))
> +
> +(require 'b)
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ex-matthias.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-matthias.rkt
> @@ -0,0 +1,35 @@
> +#lang racket/load
> +(module a racket
> +  (require unstable/temp-c/dsl
> +           unstable/match)
> +  
> +  (define memory%
> +    (class object%
> +      (super-new)
> +      (define/public (malloc) 1)
> +      (define/public (free n) (void))))
> +  
> +  (provide/contract
> +   [memory%
> +    (with-monitor
> +        (class/c [malloc (label 'malloc (->m number?))]
> +                 [free (label 'free (->m number? void))])
> +      (complement
> +       (seq (star _)
> +            (dseq (call 'free _ addr)
> +                  (seq
> +                   (star (not (ret 'malloc (== addr))))
> +                   (call 'free _ (== addr)))))))]))
> +
> +(module b racket
> +  (require 'a tests/eli-tester)
> +  
> +  (define memory (new memory%))
> +  
> +  (define a (send memory malloc))
> +  (test
> +   (send memory free a)
> +   (send memory free a)
> +   =error> #rx"disallowed call"))
> +
> +(require 'b)
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ex-mem.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-mem.rkt
> @@ -0,0 +1,58 @@
> +#lang racket/load
> +
> +#| This file shows that we can still track some things without an "interval"
> +|#
> +
> +(module mem racket
> +  (require unstable/temp-c/monitor)
> +  
> +  (define free-list empty)
> +  (define last-addr 0)
> +  (define (malloc)
> +    (if (empty? free-list)
> +        (begin0 last-addr
> +                (set! last-addr (add1 last-addr)))
> +        (begin0 (first free-list)
> +                (set! free-list (rest free-list)))))
> +  (define (free addr)
> +    (set! free-list (cons addr free-list)))
> +  
> +  (define allocated (make-weak-hasheq))
> +  (define (mem-monitor evt)
> +    ; Only allow freeing of allocated things, disallow double frees
> +    ; and track addrs using malloc returns
> +    (match evt
> +      [(monitor:return 'malloc _ _ _ _ _ _ (list addr))
> +       (hash-set! allocated addr #t)
> +       #t]
> +      [(monitor:call 'free _ _  _ _ _ (list addr))
> +       (hash-has-key? allocated addr)]
> +      [(monitor:return 'free _ _ _ _ _ (list addr) _)
> +       (hash-remove! allocated addr)
> +       #t]
> +      [_
> +       #t]))
> +  
> +  (provide/contract
> +   [malloc (monitor/c mem-monitor 'malloc (-> number?))]
> +   [free (monitor/c mem-monitor 'free (-> number? void))]))
> +
> +(module mem-test racket
> +  (require tests/eli-tester
> +           'mem)
> +  (test
> +   (malloc)
> +   
> +   (free (malloc))
> +   
> +   (free -1) =error> "disallow"
> +   
> +   (free (malloc))
> +   
> +   (let ([a (malloc)])
> +     (free a)
> +     (free a))
> +   =error>
> +   "disallow"))
> +
> +(require 'mem-test)
> 
> collects/tests/unstable/temp-c/ex-memclass.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ex-memclass.rkt
> @@ -0,0 +1,64 @@
> +#lang racket/load
> +
> +#| This file shows that we can still track some things without an "interval"
> +|#
> +
> +(module mem racket
> +  (require unstable/temp-c/monitor)
> +  (define heap%
> +    (class object%
> +      (define free-list empty)
> +      (define last-addr 0)
> +      (define/public (malloc)
> +        (if (empty? free-list)
> +            (begin0 last-addr
> +                    (set! last-addr (add1 last-addr)))
> +            (begin0 (first free-list)
> +                    (set! free-list (rest free-list)))))
> +      (define/public (free addr)
> +        (set! free-list (cons addr free-list)))
> +      
> +      (super-new)))
> +  
> +  (define allocated (make-weak-hasheq))
> +  (define (the-monitor evt)
> +    ; Only allow freeing of allocated things, disallow double frees
> +    ; and track addrs using malloc returns
> +    (match evt
> +      [(monitor:return 'malloc _ _ _ _ _ _ (list addr))
> +       (hash-set! allocated addr #t)
> +       #t]
> +      [(monitor:call 'free _ _  _ _ _ (list _ addr))
> +       (hash-has-key? allocated addr)]
> +      [(monitor:return 'free _ _ _ _ _ (list _ addr) _)
> +       (hash-remove! allocated addr)
> +       #t]
> +      [_
> +       #t]))
> +  
> +  (provide/contract
> +   [heap% 
> +    (class/c 
> +     [malloc (monitor/c the-monitor 'malloc (->m number?))]
> +     [free (monitor/c the-monitor 'free (->m number? void))])]))
> +
> +(module mem-test racket
> +  (require tests/eli-tester
> +           'mem)
> +  (define h (new heap%))
> +  (test
> +   (send h malloc)
> +   
> +   (send h free (send h malloc))
> +   
> +   (send h free -1) =error> "disallow"
> +   
> +   (send h free (send h malloc))
> +   
> +   (let ([a (send h malloc)])
> +     (send h free a)
> +     (send h free a))
> +   =error>
> +   "disallow"))
> +
> +(require 'mem-test)
> 
> collects/tests/unstable/temp-c/future-ctc.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/future-ctc.rkt
> @@ -0,0 +1,80 @@
> +#lang racket
> +(require unstable/temp-c/dsl
> +         tests/eli-tester)
> +
> +(define manual-strange/c
> +  (make-contract
> +   #:name "amazing contract"
> +   #:first-order procedure?
> +   #:projection
> +   (λ (b)
> +     (λ (x)
> +       (λ (f)
> +         (define ready? #f)
> +         (letrec-values
> +             ([(? o) 
> +               (x 
> +                (λ (y)
> +                  (cond
> +                    [(not ready?)
> +                     (raise-blame-error b x "cannot call until return")]
> +                    [(not (? y))
> +                     (raise-blame-error b x "expected a value of ~a" ?)]
> +                    [else
> +                     (f y)])))])
> +           (set! ready? #t)
> +           (values ? o)))))))
> +
> +(define hot-strange/c
> +  (with-monitor
> +      (label 'strange
> +             (-> (label 'strategy
> +                        (-> any/c ; The monitor will make it tighter
> +                            any/c))
> +                 (values (-> any/c boolean?)
> +                         any/c)))
> +    (complement
> +     (union
> +      ; You can't call strategy until strange returns
> +      (seq (star _) (call 'strange _)
> +           (star (not (ret 'strange _ _)))
> +           (call 'strategy _))
> +      ; You can't call strategy with something that violates the predicate
> +      (seq (star _) (call 'strange _) (star _)
> +           (dseq (ret 'strange predicate? _)
> +                 (seq (star _)
> +                      (call 'strategy (not (? predicate?))))))))))
> +
> +(define (try-it-out strange/c)
> +  (define strange-fun/ctc
> +    (contract strange/c 
> +              (λ (f)
> +                (values number? f))
> +              'pos 'neg))
> +  
> +  (define bad-strange-fun/ctc
> +    (contract strange/c 
> +              (λ (f)
> +                (f 4)
> +                (values number? f))
> +              'pos 'neg))
> +  
> +  (define-values (? o) (strange-fun/ctc (λ (x) x)))
> +  (test
> +   (o 4) => 4
> +   (o "string") =error> "contract violation"
> +   
> +   (bad-strange-fun/ctc (λ (x) x)) =error> "contract violation"))
> +
> +(test
> + ; ->i doesn't work
> + (->i ([strategy (predicate?) (-> predicate? any/c)])
> +      (values [predicate? (-> any/c boolean?)]
> +              [object any/c]))
> + =error>
> + "an argument cannot depend on a result"
> + 
> + ; but the manual version does
> + (try-it-out manual-strange/c)
> + ; and so does the temporal version
> + (try-it-out hot-strange/c))
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/id-bench.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/id-bench.rkt
> @@ -0,0 +1,63 @@
> +#lang racket/base
> +(require tests/stress
> +         unstable/temp-c/dsl
> +         racket/match
> +         racket/contract)
> +
> +(define (id x) x)
> +
> +(define raw 
> +  id)
> +(define ctc 
> +  (contract (-> integer? integer?) id
> +            'pos 'neg))
> +(define monitor-ctc
> +  (contract (monitor/c (λ (x) #t) 'f
> +                       (-> integer? integer?))
> +            id 'pos 'neg))
> +(define monitor-ctc+atomic
> +  (contract (monitor/c
> +             (let ([called? #f])
> +               (match-lambda
> +                 [(? monitor:proj? x)
> +                  #t]
> +                 [(? monitor:call? x)
> +                  (begin0 (not called?)
> +                          (set! called? #t))]
> +                 [(? monitor:return? x)
> +                  (begin0 called?
> +                          (set! called? #f))]))
> +             'f
> +             (-> integer? integer?))
> +            id 'pos 'neg))
> +(define dsl-ctc
> +  (contract (with-monitor (-> integer? integer?))
> +            id 'pos 'neg))
> +(define dsl-ctc+atomic
> +  (contract (with-monitor (label 'f (-> integer? integer?))
> +              (seq (? monitor:proj?)
> +                   (star 
> +                    (seq (call 'f _)
> +                         (ret 'f _)))
> +                   ; We need this to preserve prefix-closure
> +                   (opt (call 'f _))))
> +            id 'pos 'neg))
> +
> +(define-syntax-rule (stress-it x ver ...)
> +  (let ([x* x])
> +    (printf "Running ~a iterations\n" x*)
> +    (stress 1
> +            [(symbol->string 'ver)
> +             (printf "Running ~a\n" 'ver)
> +             (for ([i (in-range x*)])
> +               (ver 1))]
> +            ...)))
> +
> +(stress-it 
> + (expt 10 4)
> + raw
> + ctc
> + monitor-ctc
> + monitor-ctc+atomic
> + dsl-ctc
> + dsl-ctc+atomic)
> 
> collects/tests/unstable/temp-c/test-temporal-no-call-after-return.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/test-temporal-no-call-after-return.rkt
> @@ -0,0 +1,98 @@
> +#lang racket/load
> +
> +#| -----------------------------------------------------------------------------
> +   testing temporal contracts: 
> +
> +   let t =  (new turn board player-tiles player-score tile-bag)
> +   let t come with two methods: bump and observe 
> +
> +        (send . take-turn t)
> +admin --------------------------------------------------------> player 
> +       TEMPORAL: don't call bump on t after this call returns 
> +
> +|#
> +(require errortrace)
> +
> +;; -----------------------------------------------------------------------------
> +;; the interface module, defines turn% and how player is called via take-turn 
> +(module player-admin-interface racket 
> +  (require unstable/temp-c/dsl
> +           unstable/match)
> +  
> +  (define turn%
> +    (class object% 
> +      (init-field value)
> +      (define/public (observe) value)
> +      (define/public (bump) (set! value (+ value 1)))
> +      (super-new)))
> +  
> +  (define player/c
> +    (with-monitor
> +        (class/c [take-turn (label 'take-turn 
> +                                   (->m 
> +                                    (object/c [observe (label 'observe (->m natural-number/c))]
> +                                              [bump (label 'bump (->m any/c))])
> +                                    any/c))])
> +      (complement
> +       (seq (star _)
> +            (dseq (monitor:return 'take-turn _ _ _ _ _ (list _ t) _)
> +                  (seq (star _)
> +                       (call 'bump (== t))))))))
> +  
> +  (provide player/c turn%))
> +
> +;; -----------------------------------------------------------------------------
> +;; the player module defines a player and slabs on the requires player contract 
> +
> +(module player racket
> +  (require 'player-admin-interface)
> +  
> +  (define player% 
> +    (class object% 
> +      (init-field name)
> +      (define turn #false)
> +      (define/public (take-turn t)
> +        (if turn 
> +            (send turn bump)
> +            (send t bump))
> +        (set! turn t))            
> +      (super-new)))
> +  
> +  (provide/contract
> +   [player% player/c]))
> +
> +;; -----------------------------------------------------------------------------
> +;; the admin module creates player, admin, and has admin call player 
> +
> +(module admin racket
> +  (require 'player-admin-interface 'player tests/eli-tester)
> +  
> +  (define admin%
> +    (class object%
> +      (init-field player)
> +      
> +      (define/public (run)
> +        (define turn1 (new turn% [value 1]))
> +        (send player take-turn turn1)
> +        (define value1 (send turn1 observe))
> +        ;; --- 
> +        (define turn2 (new turn% [value 10]))
> +        (test 
> +         (send player take-turn turn2)
> +         =error>
> +         #rx"disallowed call")
> +        ;; --- 
> +        (list 'bad-for-turn1: (not (= 2 (send turn1 observe)))
> +              'bad-for-turn2: (= 10 (send turn2 observe))))
> +      
> +      (super-new)))
> +  
> +  ;; main
> +  (define player (new player% [name "a"]))
> +  (define admin (new admin% [player player]))
> +  (displayln (send admin run)))
> +
> +;; -----------------------------------------------------------------------------
> +;; run program run 
> +
> +(require 'admin)
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/test-temporal-no-call-after-return2.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/test-temporal-no-call-after-return2.rkt
> @@ -0,0 +1,101 @@
> +#lang racket/load
> +
> +#| -----------------------------------------------------------------------------
> +   testing temporal contracts: 
> +
> +   let t =  (new turn board player-tiles player-score tile-bag)
> +   let t come with two methods: bump and observe 
> +
> +        (send . take-turn t)
> +admin --------------------------------------------------------> player 
> +       TEMPORAL: don't call bump on t after this call returns 
> +
> +|#
> +(require errortrace)
> +
> +;; -----------------------------------------------------------------------------
> +;; the interface module, defines turn% and how player is called via take-turn 
> +(module player-admin-interface racket 
> +  (require unstable/temp-c/dsl
> +           unstable/match)
> +  
> +  (define turn%
> +    (class object% 
> +      (init-field value)
> +      (define/public (observe) value)
> +      (define/public (bump) (set! value (+ value 1)))
> +      (super-new)))
> +  
> +  (define mon
> +    (re->monitor-predicate/serial
> +     (re
> +      (complement
> +       (seq (star _)
> +            (dseq (monitor:return 'take-turn _ _ _ _ _ (list _ t) _)
> +                  (seq (star _)
> +                       (call 'bump (== t)))))))))
> +  
> +  (define turn/c
> +    (object/c [observe (monitor/c mon 'observe (->m natural-number/c))]
> +              [bump (monitor/c mon 'bump (->m any/c))]))
> +  
> +  (define player/c
> +    (class/c [take-turn (monitor/c mon 'take-turn (->m turn/c any/c))]))
> +  
> +  (provide player/c turn%))
> +
> +;; -----------------------------------------------------------------------------
> +;; the player module defines a player and slabs on the requires player contract 
> +
> +(module player racket
> +  (require 'player-admin-interface)
> +  
> +  (define player% 
> +    (class object% 
> +      (init-field name)
> +      (define turn #false)
> +      (define/public (take-turn t)
> +        (if turn 
> +            (send turn bump)
> +            (send t bump))
> +        (set! turn t))            
> +      (super-new)))
> +  
> +  (provide/contract
> +   [player% player/c]))
> +
> +;; -----------------------------------------------------------------------------
> +;; the admin module creates player, admin, and has admin call player 
> +
> +(module admin racket
> +  (require 'player-admin-interface 'player tests/eli-tester)
> +  
> +  (define admin%
> +    (class object%
> +      (init-field player)
> +      
> +      (define/public (run)
> +        (define turn1 (new turn% [value 1]))
> +        (send player take-turn turn1)
> +        (define value1 (send turn1 observe))
> +        ;; --- 
> +        (define turn2 (new turn% [value 10]))
> +        (test 
> +         (send player take-turn turn2)
> +         =error>
> +         #rx"disallowed call")
> +        ;; --- 
> +        (list 'bad-for-turn1: (not (= 2 (send turn1 observe)))
> +              'bad-for-turn2: (= 10 (send turn2 observe))))
> +      
> +      (super-new)))
> +  
> +  ;; main
> +  (define player (new player% [name "a"]))
> +  (define admin (new admin% [player player]))
> +  (displayln (send admin run)))
> +
> +;; -----------------------------------------------------------------------------
> +;; run program run 
> +
> +(require 'admin)
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ttt-bench-com.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ttt-bench-com.rkt
> @@ -0,0 +1,9 @@
> +#lang racket/base
> +(provide player)
> +
> +(define ((player mark) b board-ref board-set)
> +  (for*/or ([r (in-range 3)]
> +            [c (in-range 3)])
> +    (if (board-ref b r c)
> +        #f
> +        (board-set b r c mark))))
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ttt-bench-ctc.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ttt-bench-ctc.rkt
> @@ -0,0 +1,5 @@
> +#lang racket/base
> +(require "ttt.rkt"
> +         "ttt-bench-com.rkt")
> +
> +(tic-tac-toe (player 'O) (player 'X))
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ttt-bench-raw.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ttt-bench-raw.rkt
> @@ -0,0 +1,5 @@
> +#lang racket/base
> +(require "ttt.rkt"
> +         "ttt-bench-com.rkt")
> +
> +(tic-tac-toe:raw (player 'O) (player 'X))
> \ No newline at end of file
> 
> collects/tests/unstable/temp-c/ttt-bench.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ttt-bench.rkt
> @@ -0,0 +1,29 @@
> +#lang racket/base
> +(require tests/stress
> +         racket/system
> +         racket/runtime-path)
> +
> +(define racket-pth
> +  (find-executable-path "racket"))
> +
> +(define-runtime-path ttt:raw "ttt-bench-raw.rkt")
> +(define-runtime-path ttt:ctc "ttt-bench-ctc.rkt")
> +
> +racket-pth
> +
> +(define (bench p)
> +  (system* racket-pth "-t" p))
> +
> +(define-syntax-rule (stress-it ver ...)
> +  (let ([x* 1])
> +    (printf "Running ~a iterations\n" x*)
> +    (stress 10
> +            [(symbol->string 'ver)
> +             (printf "Running ~a\n" 'ver)
> +             (for ([i (in-range x*)])
> +               (bench ver))]
> +            ...)))
> +
> +(stress-it 
> + ttt:raw
> + ttt:ctc)
> 
> collects/tests/unstable/temp-c/ttt-players.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ttt-players.rkt
> @@ -0,0 +1,71 @@
> +#lang racket/base
> +(require "ttt.rkt"
> +         tests/eli-tester)
> +
> +(define (print-board b board-ref)
> +  (for ([r (in-range 3)])
> +    (for ([c (in-range 3)])
> +      (define m (board-ref b r c))
> +      (printf "|~a|" (or m " ")))
> +    (printf "\n---------\n")))
> +
> +(define (read-number m l)
> +  (printf "~a > ~a: " m l)
> +  (read))
> +
> +(define (interactive-player mark)
> +  (λ (b board-ref board-set)
> +    (print-board b board-ref)
> +    (let loop ()
> +      (define row (read-number mark "Row"))
> +      (define col (read-number mark "Column"))
> +      (if (board-ref b row col)
> +          (begin (printf "Don't be a cheater :(\n")
> +                 (loop))
> +          (board-set b row col mark)))))
> +
> +#;(tic-tac-toe (interactive-player 'O)
> +               (interactive-player 'X))
> +
> +(define (random-player mark)
> +  (define (turn b board-ref board-set)
> +    (define r (random 3))
> +    (define c (random 3))
> +    (if (board-ref b r c)
> +        (turn b board-ref board-set)
> +        (board-set b r c mark)))
> +  turn)
> +
> +(tic-tac-toe (random-player 'O) (random-player 'X))
> +(tic-tac-toe (random-player 'O) (random-player 'X))
> +
> +(define (cheater-1 mark)
> +  (define (turn b board-ref board-set)
> +    (or
> +     (for*/or ([r (in-range 3)]
> +              [c (in-range 3)])
> +       (and (board-ref b r c)
> +            (board-set b r c mark)))
> +     (board-set b 0 0 mark)))
> +  turn)
> +
> +(test
> + (tic-tac-toe (cheater-1 'O) (random-player 'X))
> + =error> "monitor disallowed"
> + (tic-tac-toe (random-player 'O) (cheater-1 'X))
> + =error> "monitor disallowed")
> +
> +(define (cheater-2 mark)
> +  (define (turn b board-ref board-set)
> +    (board-set
> +     (board-set
> +      (board-set b 2 2 mark)
> +      0 0 mark)
> +     1 1 mark))
> +  turn)
> +
> +(test
> + (tic-tac-toe (cheater-2 'O) (random-player 'X))
> + =error> "monitor disallowed"
> + (tic-tac-toe (random-player 'O) (cheater-2 'X))
> + =error> "monitor disallowed")
> 
> collects/tests/unstable/temp-c/ttt.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/unstable/temp-c/ttt.rkt
> @@ -0,0 +1,180 @@
> +#lang racket/base
> +(require racket/contract
> +         racket/match
> +         tests/eli-tester)
> +
> +; A space is #f, 'X, or 'O
> +(define space/c 
> +  (or/c false/c 'X 'O))
> +
> +; A board is a (hasheq (hasheq space space space) x 3 )
> +(define posn/c
> +  (or/c 0 1 2))
> +(define board/c
> +  (hash/c posn/c
> +          (hash/c posn/c
> +                  space/c
> +                  #:immutable #t)
> +          #:immutable #t))
> +
> +(define empty-board
> +  (hasheq 0 (hasheq 0 #f 1 #f 2 #f)
> +          1 (hasheq 0 #f 1 #f 2 #f)
> +          2 (hasheq 0 #f 1 #f 2 #f)))
> +
> +(define winning-o-board/col
> +  (hasheq 0 (hasheq 0 'O 1 #f 2 #f)
> +          1 (hasheq 0 'O 1 #f 2 #f)
> +          2 (hasheq 0 'O 1 #f 2 #f)))
> +(define winning-x-board/row
> +  (hasheq 0 (hasheq 0 'O 1 #f 2 #f)
> +          1 (hasheq 0 'X 1 'X 2 'X)
> +          2 (hasheq 0 'O 1 #f 2 #f)))
> +(define winning-x-board/left
> +  (hasheq 0 (hasheq 0 'X 1 #f 2 #f)
> +          1 (hasheq 0 'O 1 'X 2 'X)
> +          2 (hasheq 0 'O 1 #f 2 'X)))
> +(define winning-o-board/right
> +  (hasheq 0 (hasheq 0 'X 1 #f 2 'O)
> +          1 (hasheq 0 'O 1 'O 2 'X)
> +          2 (hasheq 0 'O 1 #f 2 'X)))
> +
> +(define (board-ref b r c)
> +  (hash-ref (hash-ref b r) c))
> +
> +(test
> + (board-ref empty-board 0 0) => #f
> + (board-ref winning-o-board/right 1 2) => 'X)
> +
> +(define equal?*
> +  (match-lambda*
> +    [(list) #t]
> +    [(list e) e]
> +    [(list* e1 e2 es)
> +     (and (equal? e1 e2)
> +          (apply equal?* e2 es))]))
> +
> +(test
> + (equal?*)
> + (equal?* 1)
> + (equal?* 1 1)
> + (equal?* 1 1 1)
> + (equal?* 1 1 1 2) => #f)
> +
> +(define (winning-board? b)
> +  (or
> +   ; Cols
> +   (for/or ([c (in-range 3)])
> +     (equal?*
> +      (board-ref b 0 c)
> +      (board-ref b 1 c)
> +      (board-ref b 2 c)))
> +   ; Rows
> +   (for/or ([r (in-range 3)])
> +     (equal?*
> +      (board-ref b r 0)
> +      (board-ref b r 1)
> +      (board-ref b r 2)))
> +   ; Left diagonal
> +   (equal?* (board-ref b 0 0)
> +            (board-ref b 1 1)
> +            (board-ref b 2 2))
> +   ; Right diagonal
> +   (equal?* (board-ref b 0 2)
> +            (board-ref b 1 1)
> +            (board-ref b 2 0))))
> +
> +(test
> + (winning-board? empty-board) => #f
> + 
> + (winning-board? winning-o-board/col) => 'O
> + (winning-board? winning-x-board/row) => 'X
> + (winning-board? winning-x-board/left) => 'X
> + (winning-board? winning-o-board/right) => 'O)
> +
> +(define (board-set b r c m)
> +  #;(printf "b[~a][~a] = ~a\n" r c m)
> +  (hash-update b r (λ (r) (hash-set r c m))))
> +
> +(test
> + (board-set
> +  (board-set
> +   (board-set empty-board
> +              0 0 'O)
> +   1 0 'O)
> +  2 0 'O)
> + =>
> + winning-o-board/col)
> +
> +(define (full-board? b)
> +  (for/and ([r (in-range 3)]
> +            [c (in-range 3)])
> +    (board-ref b r c)))
> +
> +(test
> + (full-board?
> +  (for/fold ([b empty-board])
> +    ([r (in-range 3)]
> +     [c (in-range 3)])
> +    (board-set b r c 'X))))
> +
> +(define (tic-tac-toe o-player x-player)
> +  (let loop ([board empty-board]
> +             [os-turn? #t
> +                       #;(zero? (random 2))])
> +    (cond
> +      [(winning-board? board)
> +       => (λ (winner)
> +            (printf "~a wins!\n" winner))]
> +      [(full-board? board)
> +       (printf "Stalemate!\n")]
> +      [else
> +       (loop 
> +        ((if os-turn? 
> +             o-player
> +             x-player)
> +         board board-ref board-set)
> +        (not os-turn?))])))
> +
> +(require unstable/match
> +         unstable/temp-c/dsl)
> +(provide
> + (rename-out [tic-tac-toe
> +              tic-tac-toe:raw]))
> +(provide/contract
> + [tic-tac-toe
> +  (with-monitor
> +      (label 'game
> +             (-> (label 'turn
> +                        (-> board/c 
> +                            (board/c posn/c posn/c . -> . space/c)
> +                            (label 'board-set
> +                                   (board/c posn/c posn/c
> +                                            (and space/c (not/c false/c))
> +                                            . -> . board/c))
> +                            board/c))
> +                 (label 'turn
> +                        (-> board/c 
> +                            (board/c posn/c posn/c . -> . space/c)
> +                            (label 'board-set
> +                                   (board/c posn/c posn/c
> +                                            (and space/c (not/c false/c))
> +                                            . -> . board/c))
> +                            board/c))
> +                 void))
> +    (complement
> +     (union
> +      ; A board set hits something that was hit before
> +      (seq (star _)
> +           (call 'game _ _)
> +           (star _)
> +           (dseq (call 'board-set _ r c _)
> +                 (seq (star (not (ret 'game _)))
> +                      (call 'board-set _ (== r) (== c) _))))
> +      ; A player takes two turns
> +      (seq (star _)
> +           (call 'turn _ _ _)
> +           (? monitor:proj?)
> +           (call 'board-set _ _ _ _)
> +           (ret 'board-set _)
> +           (call 'board-set _ _ _ _)))))])
> 
> collects/unstable/automata/dfa.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/dfa.rkt
> @@ -0,0 +1,44 @@
> +#lang racket/base
> +
> +(require "machine.rkt"
> +         racket/local
> +         racket/match
> +         (for-syntax racket/base
> +                     syntax/parse
> +                     syntax/id-table
> +                     racket/dict
> +                     unstable/sequence))
> +
> +(define-syntax (dfa stx)
> +  (syntax-parse
> +   stx
> +   [(_ start:id
> +       (end:id ...)
> +       [state:id ([evt:expr next-state:id]
> +                  ...)]
> +       ...)
> +    
> +    (define end? (make-bound-id-table))
> +    (for ([e (in-syntax #'(end ...))])
> +      (dict-set! end? e #t))
> +    
> +    (with-syntax
> +        ([(state-constructor ...)
> +          (for/list ([st (in-syntax #'(state ...))])
> +            (if (dict-ref end? st #f)
> +                #'machine-accepting
> +                #'machine))])
> +      (syntax/loc stx
> +        (local
> +          [; state : input -> next-state
> +           (define state
> +             (state-constructor
> +              '(dfa [evt next-state]
> +                    ...)
> +              (match-lambda
> +                [evt next-state]
> +                ...)))
> +           ...]
> +          start)))]))
> +
> +(provide dfa)
> 
> collects/unstable/automata/machine.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/machine.rkt
> @@ -0,0 +1,174 @@
> +#lang racket/base
> +(require racket/contract
> +         racket/list)
> +
> +(struct machine (guts next)
> +        #:mutable
> +        #:property prop:procedure
> +        (λ (m i)
> +          ((machine-next m) i)))
> +(struct machine-accepting machine ())
> +
> +(define (machine->accepting m)
> +  (if (machine-accepting? m)
> +      m
> +      (machine-accepting 
> +       (machine-guts m) 
> +       (machine-next m))))
> +(define (machine->non-accepting m)
> +  (if (machine-accepting? m)
> +      (machine 
> +       (machine-guts m) 
> +       (machine-next m))
> +      m))
> +(define (replace-guts ng m)
> +  (define const
> +    (if (machine-accepting? m) machine-accepting machine))
> +  (const ng (machine-next m)))  
> +
> +(define (machine-complement m)
> +  (define const
> +    (if (machine-accepting? m) machine machine-accepting))
> +  (const
> +   `(complement ,m)
> +   (λ (input)
> +     (machine-complement (m input)))))
> +
> +(define (machine-union m1 m2)
> +  (cond
> +    [(eq? m1 machine-null)
> +     m2]
> +    [(eq? m2 machine-null)
> +     m1]
> +    [(eq? m1 machine-epsilon)
> +     (machine->accepting m2)]
> +    [(eq? m2 machine-epsilon)
> +     (machine->accepting m1)]
> +    [else
> +     (define const
> +       (if (or (machine-accepting? m1)
> +               (machine-accepting? m2))
> +           machine-accepting
> +           machine))
> +     (const
> +      `(union ,m1 ,m2)
> +      (λ (input)
> +        (machine-union (m1 input) (m2 input))))]))
> +
> +(define (machine-intersect m1 m2)
> +  (machine-complement
> +   (machine-union
> +    (machine-complement m1)
> +    (machine-complement m2))))
> +
> +(define (machine-seq* m1 make-m2)
> +  (cond
> +    [(eq? m1 machine-epsilon)
> +     (make-m2)]
> +    [(eq? m1 machine-null)
> +     machine-null]
> +    [else
> +     (define next
> +       (machine
> +        `(seq* ,m1 ,make-m2)
> +        (λ (input)
> +          (machine-seq* (m1 input) make-m2))))
> +     (if (machine-accepting? m1)
> +         (machine-union next (make-m2))
> +         next)]))
> +
> +(define (machine-seq m1 m2)
> +  (machine-seq* m1 (λ () m2)))
> +
> +(define (machine-star m1)
> +  (cond
> +    [(eq? m1 machine-epsilon)
> +     machine-sigma*]
> +    [(eq? m1 machine-null)
> +     machine-null]
> +    [else
> +     (machine->accepting
> +      (machine-seq* 
> +       ; Since seq* will force the RHS if m1 is accepting, this could go into
> +       ; an infinite loop. However, by removing the accepting-ness, we don't change
> +       ; the overall behavior because we ultimately make it initially accepting.
> +       (machine->non-accepting m1)
> +       (λ () (machine-star m1))))]))
> +
> +(define (machine-delay make-m)
> +  (define m
> +    (machine
> +     `(delay ,make-m)
> +     (λ (input)
> +       ; XXX We don't change its accepting-ness
> +       (define nm (make-m))
> +       (set-machine-guts! m (machine-guts nm))
> +       (set-machine-next! m (machine-next nm))
> +       (nm input))))
> +  m)
> +
> +(define (machine-accepts? m evts)
> +  (if (empty? evts)
> +      (machine-accepting? m)
> +      (machine-accepts? (m (first evts)) (rest evts))))
> +(define (machine-accepts?/prefix-closed m evts)
> +  (if (empty? evts)
> +      (machine-accepting? m)
> +      (let ([n (m (first evts))])
> +        (and (machine-accepting? n)
> +             (machine-accepts? n (rest evts))))))
> +
> +(define machine-null
> +  (machine 'null (λ (input) machine-null)))
> +(define machine-epsilon
> +  (machine-accepting 'epsilon (λ (input) machine-null)))
> +(define machine-sigma*
> +  (machine-accepting 'sigma* (λ (input) machine-sigma*)))
> +
> +(require racket/match)
> +(define (machine-explain m)
> +  (match (machine-guts m)
> +    [`(complement ,i)
> +     `(complement ,(machine-explain i))]
> +    [`(seq* ,a ,b)
> +     ; If a is epsilon, then we shouldn't show this, but we would've
> +     ; just returned b anyways.
> +     (machine-explain a)]
> +    [`(union ,a ,b)
> +     `(union ,(machine-explain a)
> +             ,(machine-explain b))]
> +    [`(delay ,i)
> +     ; If we have run it before, we'll never get this.
> +     `delay]
> +    [`null
> +     `null]
> +    [`epsilon
> +     `epsilon]
> +    [`sigma*
> +     `sigma*]
> +    [any
> +     any]))
> +
> +(define-syntax-rule (provide/contract* [id ctc] ...)
> +  (provide id ...))
> +
> +(provide machine?
> +         machine-accepting?
> +         machine
> +         machine-accepting)
> +(provide/contract*
> + [machine-explain (machine? . -> . any/c)]
> + [machine-accepts? (machine? (listof any/c) . -> . boolean?)]
> + [machine-accepts?/prefix-closed (machine? (listof any/c) . -> . boolean?)]
> + #;[struct machine ([next (any/c . -> . machine?)])]
> + #;[struct (machine-accepting machine) ([next (any/c . -> . machine?)])]
> + [machine-null machine?]
> + [machine-epsilon machine?]
> + [machine-sigma* machine?]
> + [machine-complement (machine? . -> . machine?)]
> + [machine-union (machine? machine? . -> . machine?)]
> + [machine-intersect (machine? machine? . -> . machine?)]
> + [machine-delay ((-> machine?) . -> . machine?)]
> + [machine-seq* (machine? (-> machine?) . -> . machine?)]
> + [machine-seq (machine? machine? . -> . machine?)]
> + [machine-star (machine? . -> . machine?)])
> \ No newline at end of file
> 
> collects/unstable/automata/nfa-ep.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/nfa-ep.rkt
> @@ -0,0 +1,52 @@
> +#lang racket/base
> +(require "nfa.rkt"
> +         (for-syntax syntax/parse
> +                     racket/syntax
> +                     unstable/syntax
> +                     syntax/id-table
> +                     racket/dict
> +                     racket/list
> +                     racket/base))
> +
> +(define-syntax (epsilon stx) (raise-syntax-error 'epsilon "Outside nfa/ep" stx))
> +(define-syntax (nfa/ep stx)
> +  (syntax-parse
> +   stx
> +   #:literals (epsilon)
> +   [(_ (start:id ...)
> +       (end:id ...)
> +       [state:id ([epsilon (epsilon-state:id ...)]
> +                  ...
> +                  [evt:expr (next-state:id ...)]
> +                  ...)]
> +       ...)
> +    (define state->epsilon (make-bound-id-table))
> +    (for ([stx (in-list (syntax->list #'([state epsilon-state ... ...] ...)))])
> +      (syntax-case stx ()
> +        [[state . es]
> +         (bound-id-table-set! state->epsilon #'state (syntax->list #'es))]))
> +    (define seen? (make-parameter (make-immutable-bound-id-table)))
> +    (define (state->epsilons state)
> +      (if (dict-has-key? (seen?) state)
> +          empty
> +          (parameterize ([seen? (bound-id-table-set (seen?) state #t)])
> +            (define es (bound-id-table-ref state->epsilon state empty))
> +            (list* state (append-map state->epsilons es)))))
> +    (with-syntax*
> +        ([((start* ...) ...)
> +          (syntax-map state->epsilons #'(start ...))]
> +         [((((next-state* ...) ...) ...) ...)
> +          (syntax-map (λ (ns*)
> +                        (syntax-map (λ (ns)
> +                                      (syntax-map state->epsilons ns))
> +                                    ns*))
> +                      #'(((next-state ...) ...) ...))])
> +      (syntax/loc stx
> +        (nfa (start* ... ...)
> +             (end ...)
> +             [state ([evt (next-state* ... ...)]
> +                     ...)]
> +             ...)))]))
> +
> +(provide epsilon
> +         nfa/ep)
> \ No newline at end of file
> 
> collects/unstable/automata/nfa-star.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/nfa-star.rkt
> @@ -0,0 +1,16 @@
> +#lang racket/base
> +(require "nfa-ep.rkt"
> +         (for-syntax racket/base))
> +
> +(define-syntax (nfa* stx)
> +  (syntax-case stx ()
> +   [(_ starts (accepting-rule ...) (non-accepting-rule ...))
> +    (with-syntax
> +        ([([accepting-state . _] ...) #'(accepting-rule ...)])
> +      (quasisyntax/loc stx
> +        (nfa/ep starts (accepting-state ...)
> +                accepting-rule ...
> +                non-accepting-rule ...)))]))
> +
> +(provide nfa*
> +         epsilon)
> \ No newline at end of file
> 
> collects/unstable/automata/nfa.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/nfa.rkt
> @@ -0,0 +1,88 @@
> +#lang racket/base
> +
> +(require "machine.rkt"
> +         racket/local
> +         racket/unsafe/ops
> +         racket/match
> +         racket/set
> +         racket/list
> +         (for-syntax syntax/parse
> +                     syntax/id-table
> +                     racket/syntax
> +                     unstable/syntax
> +                     racket/dict
> +                     racket/list
> +                     racket/base))
> +
> +(define-syntax (nfa stx)
> +  (syntax-parse
> +   stx
> +   [(_ (start:id ...)
> +       (end:id ...)
> +       [state:id ([evt:expr (next-state:id ...)]
> +                  ...)]
> +       ...)
> +    (define how-many (length (syntax->list #'(state ...))))
> +    
> +    (define state->num (make-bound-id-table))
> +    (for ([state (in-list (syntax->list #'(state ...)))]
> +          [i (in-range how-many)])
> +      (dict-set! state->num state i))
> +    
> +    (define (set->num sl)
> +      (for/fold ([end-set 0])
> +        ([end (in-list (syntax->list sl))])
> +        (bitwise-ior end-set
> +                     (arithmetic-shift 1 (dict-ref state->num end)))))
> +    (define end-set (set->num #'(end ...)))
> +    (define start-set (set->num #'(start ...)))
> +    
> +    (define is-fixnum? (fixnum? how-many))
> +    
> +    (with-syntax*
> +        ([(state_n ...) (build-list how-many (λ (x) x))]
> +         [end-set end-set]
> +         [start-set start-set]
> +         [((next-state_n ...) ...)
> +          (for/list ([states (in-list (syntax->list #'(((next-state ...) ...) ...)))])
> +            (syntax-map set->num states))]
> +         ; Use optimized version if there are not too many states
> +         [op= (if is-fixnum? #'unsafe-fx= #'=)]
> +         [bit-shift (if is-fixnum? #'unsafe-fxlshift #'arithmetic-shift)]
> +         [bit-ior (if is-fixnum? #'unsafe-fxior #'bitwise-ior)]
> +         [bit-and (if is-fixnum? #'unsafe-fxand #'bitwise-and)])
> +      (syntax/loc stx
> +        (local
> +          [; run : (seteq state) input -> (seteq state)
> +           (define (run current-states input)
> +             (define next 0)
> +             (define compare 1)
> +             (begin
> +               (unless (op= 0 (bit-and current-states compare))
> +                 (match input
> +                   [evt (set! next (bit-ior next next-state_n))]
> +                   ...
> +                   [_ #f]))
> +               (set! compare (bit-shift compare 1)))
> +             ...
> +             next)
> +           ; accepting? : (seteq state) -> boolean
> +           (define (accepting? states)
> +             (not (op= 0 (bit-and states end-set))))
> +           ; producer : input -> an-nfa-state
> +           ; make-an-nfa-state : (seteq state) -> an-nfa-state
> +           (define (make-an-nfa-state next)
> +             (define constructor
> +               (if (accepting? next)
> +                   machine-accepting
> +                   machine))
> +             (constructor
> +              `(nfa ,next)
> +              (λ (input)
> +                (make-an-nfa-state (run next input)))))
> +           ; initial : an-nfa-state
> +           (define initial
> +             (make-an-nfa-state start-set))]
> +          initial)))]))
> +
> +(provide nfa)
> 
> collects/unstable/automata/re-compile.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/re-compile.rkt
> @@ -0,0 +1,155 @@
> +#lang racket/base
> +(require syntax/parse
> +         racket/syntax
> +         unstable/syntax
> +         "re-help.rkt"
> +         (for-template racket/base
> +                       racket/match
> +                       "machine.rkt"
> +                       (except-in "nfa-star.rkt" epsilon)
> +                       (prefix-in nfa: "nfa-star.rkt")))
> +
> +(define-literal-set re-ops (complement seq union star epsilon nullset dseq rec unquote))
> +
> +(define-syntax-class sre 
> +  #:literal-sets (re-ops)
> +  #:description "Fully Expanded Regular Expression"
> +  ; nfa is used for res without complement or dseq
> +  ; machine is used for others
> +  ; all-machines is machines all the way down, no nfas
> +  ; best is the best thing to embed in a machine
> +  #:attributes (nfa machine all-machines best)
> +  (pattern ((~and op unquote) e:expr)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa #f
> +           #:attr machine
> +           ; XXX contract to be a machine?
> +           #`e
> +           #:attr all-machines (attribute machine)
> +           #:attr best (attribute machine))
> +  
> +  ; XXX This may not need to be built in because of unquote
> +  (pattern ((~and op rec) v:id lhs:sre)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa #f
> +           #:attr machine
> +           #`(letrec ([inner
> +                       (let-syntax ([v
> +                                     (make-set!-transformer
> +                                      (lambda (stx)
> +                                        (syntax-case stx (set!)
> +                                          ; Redirect mutation of x to y
> +                                          [(set! _ _) 
> +                                           (raise-syntax-error 'rec "Cannot mutate a rec binding" stx)]
> +                                          ; Normal use of x really gets x
> +                                          [id (identifier? #'id)  #'(machine-delay (λ () inner))])))])
> +                         #,(attribute lhs.best))])
> +               inner)
> +           #:attr all-machines (attribute machine)
> +           #:attr best (attribute machine))
> +  
> +  (pattern ((~and op complement) lhs:sre)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa #f
> +           #:attr machine
> +           #`(machine-complement #,(attribute lhs.best))
> +           #:attr all-machines 
> +           #`(machine-complement #,(attribute lhs.all-machines))
> +           #:attr best (attribute machine))
> +  
> +  (pattern ((~and op star) lhs:sre)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa 
> +           (and (attribute lhs.nfa)
> +                (with-syntax*
> +                    ([start_star (generate-temporary 'start_star)]
> +                     [(_ (starts_1 ...) ([accepting-state_1 (accepting-rule_1 ...)] ...) (non-accepting_1 ...))
> +                      (attribute lhs.nfa)])
> +                  #'(nfa* (start_star) 
> +                          ([start_star ([nfa:epsilon (starts_1 ...)])])
> +                          ([accepting-state_1 ([nfa:epsilon (start_star)] accepting-rule_1 ...)] ...
> +                           non-accepting_1 ...))))
> +           #:attr machine
> +           #`(machine-star #,(attribute lhs.best))
> +           #:attr all-machines
> +           #`(machine-star #,(attribute lhs.all-machines))
> +           #:attr best (or (attribute nfa) (attribute machine)))
> +  
> +  (pattern ((~and op seq) lhs:sre rhs:sre)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa
> +           (and (attribute lhs.nfa)
> +                (attribute rhs.nfa)
> +                (with-syntax* 
> +                    ([(_ (starts_1 ...) ([accepting-state_1 (accepting-rule_1 ...)] ...) (non-accepting_1 ...))
> +                      (attribute lhs.nfa)]
> +                     [(_ (starts_2 ...) (accepting_2 ...) (non-accepting_2 ...))
> +                      (attribute rhs.nfa)]
> +                     [([accepting-state_2 . _] ...) #'(accepting_2 ...)])
> +                  #'(nfa* (starts_1 ...)
> +                          (accepting_2 ...)
> +                          ([accepting-state_1 ([nfa:epsilon (starts_2 ...)] accepting-rule_1 ...)] ...
> +                           non-accepting_1 ...
> +                           non-accepting_2 ...))))
> +           #:attr machine
> +           #`(machine-seq #,(attribute lhs.best) #,(attribute rhs.best))
> +           #:attr all-machines
> +           #`(machine-seq #,(attribute lhs.all-machines) #,(attribute rhs.all-machines))
> +           #:attr best (or (attribute nfa) (attribute machine)))
> +  
> +  (pattern ((~and op union) lhs:sre rhs:sre)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa
> +           (and (attribute lhs.nfa)
> +                (attribute rhs.nfa)
> +                (with-syntax* 
> +                    ([(_ (starts_1 ...) (accepting_1 ...) (non-accepting_1 ...)) (attribute lhs.nfa)]
> +                     [(_ (starts_2 ...) (accepting_2 ...) (non-accepting_2 ...)) (attribute rhs.nfa)])
> +                  #'(nfa* (starts_1 ... starts_2 ...)
> +                          (accepting_1 ... accepting_2 ...)
> +                          (non-accepting_1 ... non-accepting_2 ...))))
> +           #:attr machine
> +           #`(machine-union #,(attribute lhs.best) #,(attribute rhs.best))
> +           #:attr all-machines
> +           #`(machine-union #,(attribute lhs.all-machines) #,(attribute rhs.all-machines))
> +           #:attr best (or (attribute nfa) (attribute machine)))
> +  
> +  (pattern (~and op epsilon)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa
> +           (with-syntax ([start (generate-temporary 'start)])
> +             #'(nfa* (start) ([start ()]) ()))
> +           #:attr machine
> +           #'machine-epsilon
> +           #:attr all-machines (attribute machine)
> +           #:attr best (attribute machine))
> +  
> +  (pattern (~and op nullset)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa
> +           (with-syntax ([end (generate-temporary 'end)])
> +             #'(nfa* (end) () ([end ()])))
> +           #:attr machine
> +           #'machine-null
> +           #:attr all-machines (attribute machine)
> +           #:attr best (attribute machine))
> +           
> +  (pattern ((~and op dseq) pat:expr rhs:sre)
> +           #:do [(record-disappeared-uses (list #'op))]
> +           #:attr nfa #f
> +           #:attr machine
> +           #`(machine '(dseq pat) (match-lambda [pat #,(attribute rhs.best)] [_ machine-null]))
> +           #:attr all-machines (attribute machine)
> +           #:attr best (attribute machine))
> +  
> +  (pattern pat:expr
> +           #:attr nfa
> +           (with-syntax ([start (generate-temporary #'pat)]
> +                         [end (generate-temporary 'end)])
> +             #'(nfa* (start) ([end ()]) ([start ([pat (end)])])))
> +           #:attr machine
> +           #'(machine 'pat (match-lambda [pat machine-epsilon] [_ machine-null]))
> +           #:attr all-machines (attribute machine)
> +           #:attr best (attribute machine)))
> +
> +(provide sre)
> \ No newline at end of file
> 
> collects/unstable/automata/re-ext.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/re-ext.rkt
> @@ -0,0 +1,36 @@
> +#lang racket/base
> +(require "re.rkt"
> +         (for-syntax syntax/parse
> +                     racket/base))
> +
> +(define-re-transformer seq/close
> +  (syntax-rules ()
> +    [(_)
> +     epsilon]
> +    [(_ a b ...)
> +     (opt (seq a (seq/close b ...)))]))
> +
> +(define-re-transformer opt
> +  (syntax-rules ()
> +    [(_ pat)
> +     (union epsilon pat)]))
> +(define-re-transformer plus
> +  (syntax-rules ()
> +    [(_ pat)
> +     (seq pat (star pat))]))
> +(define-re-transformer rep
> +  (syntax-parser
> +   [(_ pat k:number)
> +    (with-syntax
> +        ([(pat_i ...) (build-list (syntax->datum #'k) (λ (i) #'pat))])
> +      #'(seq pat_i ...))]))
> +(define-re-transformer difference
> +  (syntax-rules ()
> +    [(_ A B)
> +     (intersection A (complement B))]))
> +(define-re-transformer intersection
> +  (syntax-rules ()
> +    [(_ A B)
> +     (complement (union (complement A) (complement B)))]))
> +
> +(provide seq/close opt plus rep difference intersection)
> \ No newline at end of file
> 
> collects/unstable/automata/re-help.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/re-help.rkt
> @@ -0,0 +1,15 @@
> +#lang racket/base
> +(struct re-transformer (>re))
> +(provide (struct-out re-transformer))
> +
> +(require (for-syntax racket/base))
> +(define-syntax (nullset stx) (raise-syntax-error 'nullset "Outside re" stx))
> +(define-syntax (epsilon stx) (raise-syntax-error 'epsilon "Outside re" stx))
> +(define-syntax (complement stx) (raise-syntax-error 'complement "Outside re" stx))
> +(define-syntax (seq stx) (raise-syntax-error 'seq "Outside re" stx))
> +(define-syntax (union stx) (raise-syntax-error 'union "Outside re" stx))
> +(define-syntax (star stx) (raise-syntax-error 'star "Outside re" stx))
> +(define-syntax (dseq stx) (raise-syntax-error 'dseq "Outside re" stx))
> +(define-syntax (rec stx) (raise-syntax-error 'rec "Outside re" stx))
> +
> +(provide nullset epsilon complement seq union star dseq rec)
> \ No newline at end of file
> 
> collects/unstable/automata/re.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/re.rkt
> @@ -0,0 +1,76 @@
> +#lang racket/base
> +(require "machine.rkt"
> +         "re-help.rkt"
> +         racket/match
> +         (for-syntax syntax/parse
> +                     racket/syntax
> +                     unstable/syntax
> +                     racket/base
> +                     "re-help.rkt"
> +                     "re-compile.rkt"))
> +
> +(define-syntax-rule (define-re-transformer id lam)
> +  (define-syntax id (re-transformer lam)))
> +
> +(define-for-syntax (re-expand stx)
> +  (syntax-parse
> +   stx
> +   #:literals (complement seq union star epsilon nullset dseq rec unquote)
> +   [((~and op complement) lhs:expr)
> +    (quasisyntax/loc stx
> +      (op #,(re-expand #'lhs)))]
> +   [((~and op rec) v:id lhs:expr)
> +    (quasisyntax/loc stx
> +      (op v #,(re-expand #'lhs)))]
> +   [((~and op unquote) e:expr)
> +    (quasisyntax/loc stx
> +      (op e))]
> +   [((~and op star) lhs:expr)
> +    (quasisyntax/loc stx
> +      (op #,(re-expand #'lhs)))]
> +   [((~and op seq) lhs:expr)
> +    (re-expand #'lhs)]
> +   [((~and op seq) lhs:expr rhs:expr)
> +    (quasisyntax/loc stx
> +      (op #,(re-expand #'lhs) #,(re-expand #'rhs)))]
> +   [((~and op seq) lhs:expr rest:expr ...)
> +    (quasisyntax/loc stx
> +      #,(re-expand #'(op lhs (op rest ...))))]
> +   [((~and op union) lhs:expr)
> +    (re-expand #'lhs)]
> +   [((~and op union) lhs:expr rhs:expr)
> +    (quasisyntax/loc stx
> +      (op #,(re-expand #'lhs) #,(re-expand #'rhs)))]
> +   [((~and op union) lhs:expr rest:expr ...)
> +    (quasisyntax/loc stx
> +      #,(re-expand #'(op lhs (op rest ...))))]
> +   [(~and e (~var transformer (static re-transformer? "re transformer")))
> +    (record-disappeared-uses (list #'transformer))
> +    (quasisyntax/loc stx
> +      #,(re-expand ((re-transformer->re (attribute transformer.value)) #'e)))]
> +   [(~and e ((~var transformer (static re-transformer? "re transformer")) . _))
> +    (record-disappeared-uses (list #'transformer))
> +    (quasisyntax/loc stx
> +      #,(re-expand ((re-transformer->re (attribute transformer.value)) #'e)))]
> +   [((~and op dseq) pat:expr rhs:expr)
> +    (quasisyntax/loc stx
> +      (op pat #,(re-expand #'rhs)))]
> +   [_
> +    stx]))
> +
> +(define-for-syntax (re-compile stx)
> +  (syntax-parse
> +   stx
> +   [the-re:sre
> +    (attribute the-re.best)]))
> +
> +(define-syntax (re stx)
> +  (with-disappeared-uses
> +      (syntax-case stx ()
> +        [(_ the-re)
> +         (re-compile (re-expand #'the-re))])))
> +
> +(provide
> + complement seq union star epsilon nullset dseq rec unquote
> + define-re-transformer
> + re)
> \ No newline at end of file
> 
> collects/unstable/automata/scribblings/automata.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/scribblings/automata.scrbl
> @@ -0,0 +1,216 @@
> +#lang scribble/doc
> +@(require scribble/manual
> +          scribble/bnf
> +          scribble/eval
> +          (for-label racket/base
> +                     racket/contract
> +                     racket/list))
> +
> +@(define our-eval (make-base-eval))
> +
> + at title[email protected]{Automata}: Compiling State Machines}
> +
> + at author[@author+email["Jay McCarthy" "jay at racket-lang.org"]]
> +
> + at defmodule[unstable/automata]
> +
> +This package provides macros and functions for writing state machines over @racketmodname[racket/match] patterns (as opposed to concrete characters.)
> +
> + at section[#:tag "machine"]{Machines}
> +
> + at defmodule[unstable/automata/machine]
> +@(require (for-label unstable/automata/machine))
> + at interaction-eval[#:eval our-eval (require unstable/automata/machine)]
> +
> +Each of the subsequent macros compile to instances of the machines provided by this module. This is a documented feature of the modules, so these functions should be used to, for example, determine if the machine is currently accepting.
> +
> + at defstruct*[machine ([next (any/c . -> . machine?)])]{
> + An applicable structure for machines. When the structure is applied, the @racket[next] field is used as the procedure.
> +}
> +
> + at defstruct*[(machine-accepting machine) ([next (any/c . -> . machine?)])]{
> + A sub-structure of @racket[machine] that is accepting.
> +}
> +
> + at defproc[(machine-accepts? [m machine?] [i (listof any/c)])
> +         boolean?]{
> + Returns @racket[#t] if @racket[m] ends in an accepting state after consuming every element of @racket[i].
> +}
> +                  
> + at defproc[(machine-accepts?/prefix-closed [m machine?] [i (listof any/c)])
> +         boolean?]{
> + Returns @racket[#t] if @racket[m] stays in an accepting state during the consumption of every element of @racket[i].
> +}
> +                  
> + at defthing[machine-null machine?]{
> + A machine that is never accepting.
> +}
> +
> + at defthing[machine-epsilon machine?]{
> + A machine that is initially accepting and never accepting afterwards.
> +}
> +
> + at defthing[machine-sigma* machine?]{
> + A machine that is always accepting.
> +}
> +
> + at defproc[(machine-complement [m machine?])
> +         machine?]{
> + A machine that inverts the acception criteria of @racket[m].
> +}
> +
> + at defproc[(machine-star [m machine?])
> +         machine?]{
> + A machine that simulates the Kleene star of @racket[m]. @racket[m] may be invoked many times.
> +}
> +                  
> + at defproc[(machine-union [m0 machine?] [m1 machine?])
> +         machine?]{
> + A machine that simulates the union of @racket[m0] and @racket[m1].
> +}
> +                  
> + at defproc[(machine-intersect [m0 machine?] [m1 machine?])
> +         machine?]{
> + A machine that simulates the intersection of @racket[m0] and @racket[m1].
> +}
> +                  
> + at defproc[(machine-seq [m0 machine?] [m1 machine?])
> +         machine?]{
> + A machine that simulates the sequencing of @racket[m0] and @racket[m1]. @racket[m1] may be invoked many times.
> +}
> +                  
> + at defproc[(machine-seq* [m0 machine?] [make-m1 (-> machine?)])
> +         machine?]{
> + A machine that simulates the sequencing of @racket[m0] and @racket[(make-m1)].
> + @racket[(make-m1)] may be invoked many times.
> +}
> +                  
> +
> + at section[#:tag "dfa"]{Deterministic Finite Automata}
> +
> + at defmodule[unstable/automata/dfa]
> +@(require (for-label unstable/automata/dfa))
> + at interaction-eval[#:eval our-eval (require unstable/automata/dfa)]
> +
> +This module provides a macro for deterministic finite automata.
> +
> + at defform[(dfa start
> +              (end ...)
> +              [state ([evt next-state]
> +                      ...)]
> +              ...)
> +         #:contracts 
> +         ([start identifier?]
> +          [end identifier?]
> +          [state identifier?]
> +          [next-state identifier?])]{
> + A @racket[machine] that starts in state @racket[start] where each state behaves as specified in the rules. If a @racket[state] is in @racket[(end ...)], then it is constructed with @racket[machine-accepting]. @racket[next-state] need not be a state from this DFA.
> +   
> +   @defexamples[#:eval our-eval
> + (define M
> +   (dfa s1 (s1)
> +        [s1 ([0 s2]
> +             [(? even?) s1])]
> +        [s2 ([0 s1]
> +             [(? even?) s2])]))
> + (machine-accepts? M (list 2 0 4 0 2))
> + (machine-accepts? M (list 0 4 0 2 0))
> + (machine-accepts? M (list 2 0 2 2 0 8))
> + (machine-accepts? M (list 0 2 0 0 10 0))
> + (machine-accepts? M (list))
> + (machine-accepts? M (list 4 0))]
> +}
> +
> + at section[#:tag "nfa"]{Non-Deterministic Finite Automata}
> +
> + at defmodule[unstable/automata/nfa]
> +@(require (for-label unstable/automata/nfa))
> + at interaction-eval[#:eval our-eval (require unstable/automata/nfa)]
> +
> +This module provides a macro for non-deterministic finite automata.
> +
> + at defform[(nfa (start:id ...)
> +              (end:id ...)
> +              [state:id ([evt:expr (next-state:id ...)]
> +                         ...)]
> +              ...)
> +         #:contracts 
> +         ([start identifier?]
> +          [end identifier?]
> +          [state identifier?]
> +          [next-state identifier?])]{
> + A @racket[machine] that starts in state @racket[(set start ...)] where each state behaves as specified in the rules. If a state is in @racket[(end ...)], then the machine is accepting. @racket[next-state] must be a state from this NFA.
> +   
> + These machines are efficiently compiled to use the smallest possible bit-string as a set representation and unsafe numeric operations where appropriate for inspection and adjusting the sets.
> +   
> +   @defexamples[#:eval our-eval
> +(define M
> +  (nfa (s1 s3) (s1 s3)
> +       [s1 ([0 (s2)]
> +            [1 (s1)])]
> +       [s2 ([0 (s1)]
> +            [1 (s2)])]
> +       [s3 ([0 (s3)]
> +            [1 (s4)])]
> +       [s4 ([0 (s4)]
> +            [1 (s3)])]))
> +(machine-accepts? M (list 1 0 1 0 1))
> +(machine-accepts? M (list 0 1 0 1 0))
> +(machine-accepts? M (list 1 0 1 1 0 1))
> +(machine-accepts? M (list 0 1 0 0 1 0))
> +(machine-accepts? M (list))
> +(machine-accepts? M (list 1 0))]
> +}
> +
> + at section[#:tag "nfa-ep"]{Non-Deterministic Finite Automata (with epsilon transitions)}
> +
> + at defmodule[unstable/automata/nfa-ep]
> +@(require (for-label unstable/automata/nfa-ep))
> + at interaction-eval[#:eval our-eval (require unstable/automata/nfa-ep)]
> +
> +This module provides a macro for non-deterministic finite automata with epsilon transitions.
> +
> + at defidform[epsilon]{
> + A binding for use in epsilon transitions.
> +}
> +
> + at defform[#:literals (epsilon)
> +         (nfa/ep (start:id ...)
> +                 (end:id ...)
> +                 [state:id ([epsilon (epsilon-state:id ...)]
> +                            ...
> +                            [evt:expr (next-state:id ...)]
> +                            ...)]
> +                 ...)
> +         #:contracts 
> +         ([start identifier?]
> +          [end identifier?]
> +          [state identifier?]
> +          [epsilon-state identifier?]
> +          [next-state identifier?])]{
> + Extends @racket[nfa] with epsilon transitions, which must be listed first for each state. 
> +   
> +   @defexamples[#:eval our-eval
> +(define M
> +  (nfa/ep (s0) (s1 s3)
> +          [s0 ([epsilon (s1)]
> +               [epsilon (s3)])]
> +          [s1 ([0 (s2)]
> +               [1 (s1)])]
> +          [s2 ([0 (s1)]
> +               [1 (s2)])]
> +          [s3 ([0 (s3)]
> +               [1 (s4)])]
> +          [s4 ([0 (s4)]
> +               [1 (s3)])]))
> +(machine-accepts? M (list 1 0 1 0 1))
> +(machine-accepts? M (list 0 1 0 1 0))
> +(machine-accepts? M (list 1 0 1 1 0 1))
> +(machine-accepts? M (list 0 1 0 0 1 0))
> +(machine-accepts? M (list))
> +(machine-accepts? M (list 1 0))]
> +}
> +
> + at include-section["re.scrbl"]
> +
> +         
> \ No newline at end of file
> 
> collects/unstable/automata/scribblings/re.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/automata/scribblings/re.scrbl
> @@ -0,0 +1,202 @@
> +#lang scribble/doc
> +@(require scribble/manual
> +          scribble/bnf
> +          scribble/eval
> +          (for-label racket/base
> +                     racket/function
> +                     racket/contract
> +                     racket/list))
> +
> +@(define our-eval (make-base-eval))
> +
> + at title[#:tag "re"]{Regular Expressions}
> +
> + at defmodule[unstable/automata/re]
> +@(require (for-label unstable/automata/re
> +                     unstable/automata/machine))
> + at interaction-eval[#:eval our-eval (require unstable/automata/re)]
> +
> +This module provides a macro for regular expression compilation.
> +
> + at defform/subs[#:literals (complement seq union star epsilon nullset dseq rec unquote)
> +                         (re re-pat)
> +                         ([re-pat (rec id re-pat)
> +                                  (unquote expr)
> +                                  (complement re-pat)
> +                                  (seq re-pat ...)
> +                                  (union re-pat ...)
> +                                  (star re-pat)
> +                                  epsilon
> +                                  nullset
> +                                  re-transformer
> +                                  (re-transformer . datum)
> +                                  (dseq pat re-pat)
> +                                  pat])]{
> + Compiles a regular expression over match patterns to a @racket[machine].
> +                                                        
> + The interpretation of the pattern language is mostly intuitive. The pattern language may be extended
> + with @racket[define-re-transformer]. @racket[dseq] allows bindings of the @racket[match] pattern to be
> + used in the rest of the regular expression. (Thus, they are not @emph{really} regular expressions.)
> + @racket[unquote] escapes to Racket to evaluate an expression that evaluates to a regular expression (this happens
> + once, at compile time.) @racket[rec] binds a Racket identifier to a delayed version of the inner expression; even
> + if the expression is initially accepting, this delayed version is never accepting.
> + 
> + The compiler will use an NFA, provided @racket[complement] and @racket[dseq] are not used. Otherwise, 
> + many NFAs connected with the machine simulation functions from @racketmodname[unstable/automata/machine] are used.
> +}
> + 
> +@(define-syntax-rule (defidforms (id ...) . dat)
> +   (deftogether ((defidform id) ...) . dat))
> +                                        
> + at defidforms[(complement seq union star epsilon nullset dseq rec)]{
> + Bindings for use in @racket[re]. 
> +}
> +
> + at defform[(define-re-transformer id expr)]{
> + Binds @racket[id] as an regular expression transformer used by the @racket[re] macro. The expression should evaluate to a function that accepts a syntax object and returns a syntax object that uses the regular expression pattern language.
> +}
> +
> + at section[#:tag "re-ext"]{Extensions}
> +
> + at defmodule[unstable/automata/re-ext]
> +@(require (for-label unstable/automata/re-ext))
> + at interaction-eval[#:eval our-eval (require unstable/automata/re-ext)]
> +
> +This module provides a few transformers that extend the syntax of regular expression patterns.
> +
> + at defform[(opt re-pat)]{ Optionally matches @racket[re-pat]. }
> + at defform[(plus re-pat)]{ Matches one or more @racket[re-pat] in sequence. }
> + at defform[(rep re-pat num)]{ Matches @racket[re-pat] in sequence @racket[num] times, where @racket[num] must be syntactically a number. }
> + at defform[(difference re-pat_0 re-pat_1)]{ Matches everything that @racket[re-pat_0] does, except what @racket[re-pat_1] matches. }
> + at defform[(intersection re-pat_0 re-pat_1)]{ Matches the intersection of @racket[re-pat_0] and @racket[re-pat_1]. }
> + at defform[(seq/close re-pat ...)]{ Matches the prefix closure of the sequence @racket[(seq re-pat ...)]. }
> +
> + at section[#:tag "re-ex"]{Examples}
> +
> + at interaction-eval[#:eval our-eval (require unstable/automata/machine racket/function)]
> +
> + at defexamples[
> +#:eval our-eval
> +(define-syntax-rule (test-re R (succ ...) (fail ...))
> +  (let ([r (re R)])
> +    (printf "Success: ~v => ~v\n" succ (machine-accepts? r succ))
> +    ...
> +    (printf "Failure: ~v => ~v\n" fail (machine-accepts? r fail))
> +    ...))
> +(test-re epsilon
> +          [(list)]
> +          [(list 0)])
> + 
> + (test-re nullset
> +          []
> +          [(list) (list 1)])
> + 
> + (test-re "A"
> +          [(list "A")]
> +          [(list)
> +           (list "B")])
> + 
> + (test-re (complement "A")
> +          [(list)
> +           (list "B")
> +           (list "A" "A")]
> +          [(list "A")])
> + 
> + (test-re (union 0 1)
> +          [(list 1)
> +           (list 0)]
> +          [(list)
> +           (list 0 1)
> +           (list 0 1 1)])
> + 
> + (test-re (seq 0 1)
> +          [(list 0 1)]
> +          [(list)
> +           (list 0)
> +           (list 0 1 1)])
> + 
> + (test-re (star 0)
> +          [(list)
> +           (list 0)
> +           (list 0 0)]
> +          [(list 1)])
> + 
> + (test-re (opt "A")
> +          [(list)
> +           (list "A")]
> +          [(list "B")])
> + 
> + (define-re-transformer my-opt
> +  (syntax-rules ()
> +    [(_ pat)
> +     (union epsilon pat)]))
> + 
> + (test-re (my-opt "A")
> +          [(list)
> +           (list "A")]
> +          [(list "B")])
> + 
> + (test-re (plus "A")
> +          [(list "A")
> +           (list "A" "A")]
> +          [(list)])
> + 
> + (test-re (rep "A" 3)
> +          [(list "A" "A" "A")]
> +          [(list)
> +           (list "A")
> +           (list "A" "A")])
> + 
> + (test-re (difference (? even?) 2)
> +          [(list 4)
> +           (list 6)]
> +          [(list 3)
> +           (list 2)])
> + 
> + (test-re (intersection (? even?) 2)
> +          [(list 2)]
> +          [(list 1)
> +           (list 4)])
> + 
> + (test-re (complement (seq "A" (opt "B")))
> +          [(list "A" "B" "C")]
> +          [(list "A")
> +           (list "A" "B")])
> + 
> + (test-re (seq epsilon 1)
> +          [(list 1)]
> +          [(list 0)
> +           (list)])
> + 
> + (test-re (seq 1 epsilon)
> +          [(list 1)]
> +          [(list 0)
> +           (list)])
> + 
> + (test-re (seq epsilon
> +               (union (seq (star 1) (star (seq 0 (star 1) 0 (star 1))))
> +                      (seq (star 0) (star (seq 1 (star 0) 1 (star 0)))))
> +               epsilon)
> +          [(list 1 0 1 0 1)
> +           (list 0 1 0 1 0)
> +           (list 1 0 1 1 0 1)
> +           (list 0 1 0 0 1 0)
> +           (list)]
> +          [(list 1 0)])
> + 
> + (test-re (star (complement 1))
> +          [(list 0 2 3 4)
> +           (list)
> +           (list 2)
> +           (list 234 5 9 1 9 0)
> +           (list 1 0)
> +           (list 0 1)]
> +          [(list 1)])
> + 
> + (test-re (dseq x (? (curry equal? x)))
> +          [(list 0 0)
> +           (list 1 1)]
> +          [(list)
> +           (list 1)
> +           (list 1 0)])]
> +
> 
> collects/unstable/scribblings/unstable.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/unstable/scribblings/unstable.scrbl
> +++ NEW/collects/unstable/scribblings/unstable.scrbl
> @@ -71,6 +71,7 @@ Keep documentation and tests up to date.
>   Add new documentation links to the list immediately below.
> }
> 
> + at include-section["../automata/scribblings/automata.scrbl"]
> @include-section["bytes.scrbl"]
> @include-section["contract.scrbl"]
> @include-section["wrapc.scrbl"]
> @@ -100,6 +101,7 @@ Keep documentation and tests up to date.
> @include-section["string.scrbl"]
> @include-section["struct.scrbl"]
> @include-section["syntax.scrbl"]
> + at include-section["../temp-c/scribblings/temp-c.scrbl"]
> 
> @;{--------}
> 
> 
> collects/unstable/temp-c/dsl.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/temp-c/dsl.rkt
> @@ -0,0 +1,74 @@
> +#lang racket/base
> +(require racket/match
> +         racket/stxparam
> +         (for-syntax racket/base)
> +         "monitor.rkt"
> +         unstable/automata/machine
> +         unstable/automata/re
> +         unstable/automata/re-ext)
> +(provide call ret with-monitor label
> +         re->monitor-predicate/concurrent
> +         re->monitor-predicate/serial
> +         (all-from-out
> +          "monitor.rkt"
> +         unstable/automata/re
> +         unstable/automata/re-ext))
> +
> +(define-syntax-parameter stx-monitor-id 
> +  (λ (stx) (raise-syntax-error 'label "Used outside monitor" stx)))
> +
> +(define-syntax-rule (label n K)
> +  (monitor/c stx-monitor-id n K))
> +
> +(define-syntax with-monitor
> +  (syntax-rules ()
> +    [(_ K)
> +     (let ([monitor (λ (x) #t)])
> +       (syntax-parameterize ([stx-monitor-id (make-rename-transformer #'monitor)])
> +                            K))]
> +    [(_ K T)
> +     (let ([monitor (re->monitor-predicate/serial (re T))])
> +       (syntax-parameterize ([stx-monitor-id (make-rename-transformer #'monitor)])
> +                            K))]
> +    [(_ K #:concurrent T)
> +     (let ([monitor (re->monitor-predicate/concurrent (re T))])
> +       (syntax-parameterize ([stx-monitor-id (make-rename-transformer #'monitor)])
> +                            K))]))
> +
> +(define (re->monitor-predicate/concurrent m)
> +  (define inner-accepts?
> +    (re->monitor-predicate/serial m))
> +  (define t
> +    (thread 
> +     (λ ()
> +       (let loop ()
> +         (define m (thread-receive))
> +         (define evt (car m))
> +         (define qt (cdr m))
> +         (thread-resume qt (current-thread))
> +         (thread-send qt (inner-accepts? evt)
> +                      (λ () (error 'monitor "Failed to contact requester")))
> +         (loop)))))
> +  (define (accepts? evt)
> +    (thread-resume t (current-thread))
> +    (thread-send t (cons evt (current-thread))
> +                 (λ () (error 'monitor "Failed to contact monitor")))
> +    (thread-receive))
> +  accepts?)
> +
> +(define (re->monitor-predicate/serial m)
> +  (define current-re m)
> +  (λ (evt)
> +    #;(printf "~v\n" evt)
> +    (set! current-re (current-re evt))
> +    (machine-accepting? current-re)))
> +
> +(define-match-expander call
> +  (syntax-rules ()
> +    [(_ n p ...)
> +     (monitor:call n _ _ _ _ _ (list p ...))]))
> +
> +(define-match-expander ret
> +  (syntax-rules ()
> +    [(_ n p ...)
> +     (monitor:return n _ _ _ _ _ _ (list p ...))]))
> 
> collects/unstable/temp-c/monitor.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/temp-c/monitor.rkt
> @@ -0,0 +1,47 @@
> +#lang racket/base
> +(require racket/list
> +         racket/contract)
> +
> +(struct monitor (label) #:transparent)
> +(struct monitor:proj monitor (proj-label v) #:transparent)
> +(struct monitor:call monitor (proj-label f app-label kws kw-args args) #:transparent)
> +(struct monitor:return monitor (proj-label f app-label kws kw-args args rets) #:transparent)
> +
> +(define (monitor/c monitor-allows? label c)
> +  (define ctc (coerce-contract 'monitored c))
> +  (make-contract
> +   #:name (build-compound-type-name 'monitored label c)
> +   #:projection
> +   (λ (b)
> +     (define proj ((contract-projection ctc) b))
> +     (define bs (blame-swap b))
> +     (λ (x)
> +       (define proj-label (gensym label))
> +       (define proj-x (proj x))
> +       ; XXX Find a way to get a meaningful reason why the monitor failed
> +       (if (monitor-allows? (monitor:proj label proj-label proj-x))
> +           (if (procedure? proj-x)
> +               (make-keyword-procedure
> +                ; XXX Could I specialize for a few arguments/returns/no kws?
> +                (λ (kws kw-args . args)
> +                  (define app-label (gensym label))
> +                  (if (monitor-allows? (monitor:call label proj-label proj-x app-label kws kw-args args))
> +                      (call-with-values
> +                       (λ () (keyword-apply proj-x kws kw-args args))
> +                       (λ rets
> +                         (if (monitor-allows? (monitor:return label proj-label proj-x app-label kws kw-args args rets))
> +                             (apply values rets)
> +                             (raise-blame-error b x "temporal monitor disallowed return of ~e" rets))))
> +                      (cond
> +                        [(and (empty? kws) (empty? kw-args))
> +                         (raise-blame-error bs x "temporal monitor disallowed call with\n\targuments ~e" args)]
> +                        [else
> +                         (raise-blame-error bs x "temporal monitor disallowed call with\n\tkeywords ~e\n\tkeyword arguments ~e\n\tnormal arguments ~e" kws kw-args args)]))))
> +               proj-x)
> +           (raise-blame-error b x "temporal monitor disallowed projection of ~e" x))))))
> +
> +(provide (struct-out monitor)
> +         (struct-out monitor:proj)
> +         (struct-out monitor:call)
> +         (struct-out monitor:return)
> +         monitor/c)
> \ No newline at end of file
> 
> collects/unstable/temp-c/scribblings/temp-c.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/unstable/temp-c/scribblings/temp-c.scrbl
> @@ -0,0 +1,123 @@
> +#lang scribble/doc
> +@(require scribble/manual
> +          scribble/bnf
> +          scribble/eval
> +          (for-label racket/base
> +                     racket/contract
> +                     racket/match
> +                     racket/list))
> +
> +@(define our-eval (make-base-eval))
> +
> + at title[#:tag "temp-c"][email protected]{Temporal Contracts}: Explicit Contract Monitors}
> +
> + at author[@author+email["Jay McCarthy" "jay at racket-lang.org"]]
> +
> + at defmodule[unstable/temp-c]
> +
> +The contract system implies the presence of a "monitoring system" that ensures that contracts are not violated. The @racketmodname[racket/contract] system compiles this monitoring system into checks on values that cross a contracted boundary. This module provides a facility to pass contract boundary crossing information to an explicit monitor for approval. This monitor may, for example, use state to enforce temporal constraints, such as a resource is locked before it is accessed.
> +
> + at section[#:tag "monitor"]{Monitors}
> +
> + at defmodule[unstable/temp-c/monitor]
> +@(require (for-label unstable/temp-c/monitor))
> +
> + at deftogether[[
> + at defstruct*[monitor ([label symbol?]) #:transparent]
> + at defstruct*[(monitor:proj monitor)
> +            ([label symbol?] [proj-label symbol?] [v any/c])
> +             #:transparent]
> + at defstruct*[(monitor:call monitor)
> +            ([label symbol?] [proj-label symbol?] [f procedure?] 
> +             [app-label symbol?] [kws (listof keyword?)] [kw-args list?] [args list?])
> +            #:transparent]
> + at defstruct*[(monitor:return monitor)
> +            ([label symbol?] [proj-label symbol?] [f procedure?] 
> +             [app-label symbol?] [kws (listof keyword?)] [kw-args list?] [args list?]
> +             [rets list?])
> +             #:transparent]
> + at defproc[(monitor/c [monitor-allows? (-> monitor? boolean?)]
> +                    [label symbol?]
> +                    [c contract?])
> +         contract?]
> +]]{
> +  
> +  @racket[monitor/c] creates a new contract around @racket[c] that uses @racket[monitor-allows?] to approve
> +  contract boundary crossings. (@racket[c] approves positive crossings first.)
> +  
> +  Whenever a value @racket[v] is projected by the result of @racket[monitor/c], @racket[monitor-allows?]
> +  must approve a @racket[(monitor:proj label proj-label v)] structure, where @racket[proj-label] is a unique
> +  symbol for this projection.
> +  
> +  If @racket[monitor-allows?] approves and the value is not a function, then the value is returned.
> +  
> +  If the value is a function, then a projection is returned, whenever it is called, @racket[monitor-allows?]
> +  must approve a @racket[(monitor:call label proj-label v app-label kws kw-args args)] structure,
> +  where @racket[app-label] is a unique symbol for this application and @racket[kws], @racket[kw-args], @racket[args]
> +  are the arguments passed to the function.
> +  
> +  Whenever it returns, @racket[monitor-allows?]
> +  must approve a @racket[(monitor:return label proj-label v app-label kws kw-args args rets)] structure,
> +  where @racket[ret] are the return values of the application.
> +  
> +  The unique projection label allows explicitly monitored contracts to be useful when used in a first-class way 
> +  at different boundaries.
> +  
> +  The unique application label allows explicitly monitored contracts to pair calls and returns when functions
> +  return multiple times or never through the use of continuations.
> +  
> +}
> +  
> +Here is a short example that uses an explicit monitor to ensure that @racket[_malloc] and @racket[_free] are
> +used correctly.
> + at racketblock[
> + (define allocated (make-weak-hasheq))
> + (define memmon
> +   (match-lambda
> +     [(monitor:return 'malloc _ _ _ _ _ _ (list addr))
> +      (hash-set! allocated addr #t)
> +      #t]
> +     [(monitor:call 'free _ _  _ _ _ (list addr))
> +      (hash-has-key? allocated addr)]
> +     [(monitor:return 'free _ _ _ _ _ (list addr) _)
> +      (hash-remove! allocated addr)
> +      #t]
> +     [_
> +      #t]))
> + (provide/contract
> +  [malloc (monitor/c memmon 'malloc (-> number?))]
> +  [free (monitor/c memmon 'free (-> number? void))])
> +]
> +           
> + at section[#:tag "dsl"]{Domain Specific Language}
> +
> + at defmodule[unstable/temp-c/dsl]
> +@(require (for-label racket/match
> +                     racket/contract
> +                     unstable/temp-c/dsl
> +                     unstable/automata/re
> +                     unstable/automata/re-ext))
> +
> +Constructing explicit monitors using only @racket[monitor/c] can be a bit onerous. This module provides some helpful tools for making the definition easier. It provides everything from @racketmodname[unstable/temp-c/monitor], as well as all bindings from @racketmodname[unstable/automata/re] and @racketmodname[unstable/automata/re-ext]. The latter provide a DSL for writing "dependent" regular expression machines over arbitrary @racketmodname[racket/match] patterns.
> +
> +First, a few @racket[match] patterns are available to avoid specify all the details of monitored events (since most of the time the detailed options are unnecessary.)
> +
> + at defform[(call n a ...)]{ A @racket[match] expander for call events to the labeled function @racket[n] with arguments @racket[a]. }
> + at defform[(ret n a ...)]{ A @racket[match] expander for return events to the labeled function @racket[n] with return values @racket[a]. }
> +
> + at defform[(with-monitor contract-expr re-pat)]{ Defines a monitored contract where the structural portion of the contract is the @racket[contract-expr] (which may included embedded @racket[label] expressions) and where the temporal portion of the contract is the regular expression given by @racket[re-pat]. (Note: @racket[re-pat] is not a Racket expression that evaluates to a regular expression. It is a literal regular expession.)  An optional @racket[#:concurrent] may be added between the contract and the regular expression to ensure that the machine is safe against race-conditions.}
> +
> + at defform[(label id contract-expr)]{ Labels a portion of a structural contract inside of @racket[with-monitor] with the label @racket[id]. }
> +
> +Here is a short example for @racket[_malloc] and @racket[_free]:
> + at racketblock[
> +(with-monitor 
> +    (cons/c (label 'malloc (-> addr?))
> +            (label 'free (-> addr? void?)))
> +  (complement 
> +   (seq (star _)
> +        (dseq (call 'free addr)
> +              (seq
> +               (star (not (ret 'malloc (== addr))))
> +               (call 'free (== addr)))))))
> +]
> \ No newline at end of file




Posted on the dev mailing list.