[racket-dev] [plt] Push #22869: master branch updated
I don't expect the interface to the automata to change much, except
perhaps providing more useful macros.
For the actual temporal contract library, are you comfortable with this text:
@section{Warning! Experimental!}
This library is truly experimental and the interface is likely to
drastically change as we get more experience making use of temporal
contracts. In particular, the library comes with no advice about
designing temporal contracts, which are much more subtle than standard
contracts. This subtlety is compounded because, while temporal
contract violations have accurate blame information, we cannot yet
connect violations to sub-pieces of the temporal formula.
For example, applying @racket[f] to @racket["three"] when it is
contracted to only accept numbers will error by blaming the caller and
providing the explanation "expected a <number?>, received: "three"".
In contrast, applying @racket[g] to @racket["even"] and then to
@racket["odd"] when @racket[g] is contracted to accept strings on
every odd invocation, but numbers on every even invocation, will error
by blaming the second (odd) call, but will not provide any explanation
except "the monitor disallowed the call with arguments: "odd"".
Translating non-acceptance of an event trace by an automata into a
palatable user explanation is an open problem.
--
Jay
2011/6/24 Matthias Felleisen <matthias at ccs.neu.edu>:
>
> If all you have is what you had a while ago, it's Planet quality.
> If you wish to polish it into a shape so that people can easily use it,
> unstable is fine but add a huge warning that this subcollects will
> experience a lot of change.
>
>
> On Jun 24, 2011, at 3:53 PM, Jay McCarthy wrote:
>
>> I wanted to put it in unstable so it would be more usable than in a
>> random Github, but not on Planet, since we previously talked about
>> improving it for inclusion in the core. Would you rather I put it on
>> Planet for awhile?
>>
>> Jay
>>
>> 2011/6/24 Matthias Felleisen <matthias at ccs.neu.edu>:
>>>
>>> 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{@bold{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"]{@bold{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
>>>
>>>
>
>
![[logo]](/logo.png){kind=logo}