Randomized tests for the delimited control model.
Tests in randomized-tests.rkt are deliberately not run by DrDr at the moment because they fail too consistently.
This commit is contained in:
Casey Klein
parent
8ff358b559
commit
1ccd6e7a2c
|
|
@ -1198,6 +1198,8 @@ path/s is either such a string or a list of them.
|
|||
"collects/redex/examples/church.rkt" drdr:command-line (mzc *)
|
||||
"collects/redex/examples/combinators.rkt" drdr:command-line (mzc *)
|
||||
"collects/redex/examples/compatible-closure.rkt" drdr:command-line (mzc *)
|
||||
"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 120 drdr:random #t
|
||||
"collects/redex/examples/delim-cont/randomized-tests.rkt" drdr:random #t
|
||||
"collects/redex/examples/delim-cont/test.rkt" drdr:command-line (mzc *)
|
||||
"collects/redex/examples/letrec.rkt" drdr:command-line (mzc *)
|
||||
"collects/redex/examples/omega.rkt" drdr:command-line (mzc *)
|
||||
|
|
|
|||
76
collects/redex/examples/delim-cont/model-impl.rkt
Normal file
76
collects/redex/examples/delim-cont/model-impl.rkt
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
#lang racket
|
||||
|
||||
(provide % abort call/comp call/cm current-marks
|
||||
(rename-out [_call/cc call/cc]
|
||||
[_if if]
|
||||
[_+ +]
|
||||
[_print print]
|
||||
[_cons cons]
|
||||
[_set! set!]
|
||||
[_zero? zero?]))
|
||||
|
||||
(define tag
|
||||
(let ([tags (make-hash)])
|
||||
(λ (v)
|
||||
(hash-ref tags v
|
||||
(λ ()
|
||||
(let ([t (make-continuation-prompt-tag)])
|
||||
(hash-set! tags v t)
|
||||
t))))))
|
||||
|
||||
(define-syntax-rule (% tag-val expr handler)
|
||||
(call-with-continuation-prompt
|
||||
(λ () expr)
|
||||
(let ([v tag-val])
|
||||
(if (let comparable? ([v v])
|
||||
(cond [(procedure? v) #f]
|
||||
[(list? v) (andmap comparable? v)]
|
||||
[else #t]))
|
||||
(tag v)
|
||||
(raise-type-error '% "non-procedure" v)))
|
||||
(let ([h handler])
|
||||
(λ (x) (h x)))))
|
||||
|
||||
(define (abort tag-val result)
|
||||
(abort-current-continuation (tag tag-val) result))
|
||||
|
||||
(define ((force-unary f) x) (f x))
|
||||
|
||||
(define (_call/cc proc tag-val)
|
||||
(call/cc (compose proc force-unary) (tag tag-val)))
|
||||
|
||||
(define (call/comp proc tag-val)
|
||||
(call-with-composable-continuation (compose proc force-unary) (tag tag-val)))
|
||||
|
||||
(define (call/cm key val thunk)
|
||||
(with-continuation-mark key val (thunk)))
|
||||
|
||||
(define (current-marks key tag-val)
|
||||
(continuation-mark-set->list
|
||||
(current-continuation-marks (tag tag-val))
|
||||
key))
|
||||
|
||||
(define-syntax-rule (_if e1 e2 e3)
|
||||
(let ([v1 e1])
|
||||
(case v1
|
||||
[(#t) e2]
|
||||
[(#f) e3]
|
||||
[else (raise-type-error 'if "#t or #f" v1)])))
|
||||
|
||||
(define (_+ x y) (+ x y))
|
||||
|
||||
(define (_print n)
|
||||
(if (number? n)
|
||||
(begin (print n) #f)
|
||||
(raise-type-error 'print "number" n)))
|
||||
|
||||
(define (_cons x xs)
|
||||
(if (list? xs)
|
||||
(cons x xs)
|
||||
(raise-type-error 'cons "list?" 1 x xs)))
|
||||
|
||||
(define-syntax-rule (_set! x e)
|
||||
(begin (set! x e) #f))
|
||||
|
||||
(define (_zero? x)
|
||||
(equal? 0 x))
|
||||
147
collects/redex/examples/delim-cont/randomized-tests-test.rkt
Normal file
147
collects/redex/examples/delim-cont/randomized-tests-test.rkt
Normal file
|
|
@ -0,0 +1,147 @@
|
|||
#lang racket
|
||||
|
||||
(require "randomized-tests.rkt"
|
||||
"reduce.rkt"
|
||||
"grammar.rkt"
|
||||
rackunit
|
||||
(except-in redex/reduction-semantics plug))
|
||||
|
||||
(define-syntax (test-transformation stx)
|
||||
(syntax-case stx ()
|
||||
[(_ program expected-output expected-result)
|
||||
#`(match-let ([(answer actual-output actual-result)
|
||||
(model-eval (transform-intermediate (term program)))])
|
||||
(begin
|
||||
#,(syntax/loc #'expected-output
|
||||
(check-equal? actual-output expected-output))
|
||||
#,(syntax/loc #'expected-result
|
||||
(check-equal? actual-result 'expected-result))))]))
|
||||
|
||||
(test-transformation
|
||||
(<> ()
|
||||
()
|
||||
(% 0
|
||||
(wcm ()
|
||||
((λ (k)
|
||||
(begin (k 7) (print 1)))
|
||||
(cont 0 hole)))
|
||||
(λ (x) x)))
|
||||
"" 7)
|
||||
|
||||
(test-transformation
|
||||
(<> ()
|
||||
()
|
||||
(cont 1 (begin hole (print 3))))
|
||||
"" procedure)
|
||||
|
||||
(test-transformation
|
||||
(<> ()
|
||||
()
|
||||
(% 0
|
||||
(print
|
||||
(wcm ()
|
||||
((λ (k) (begin (k 1) 2))
|
||||
(comp (print hole)))))
|
||||
(λ (x) x)))
|
||||
"12" #f)
|
||||
|
||||
(test-transformation
|
||||
(<> ()
|
||||
(1)
|
||||
(% 1
|
||||
(dw
|
||||
x_1
|
||||
(print 1)
|
||||
(wcm ()
|
||||
((λ (k) (k 3))
|
||||
(cont 1 (dw x_1 (print 1) hole (print 2)))))
|
||||
(print 2))
|
||||
(λ (x) x)))
|
||||
"12" 3)
|
||||
|
||||
(test-transformation
|
||||
(<> ()
|
||||
(1)
|
||||
(% 0
|
||||
((% 0
|
||||
(dw
|
||||
x_1
|
||||
(print 1)
|
||||
(wcm ()
|
||||
((λ (k) k)
|
||||
(cont 0 (dw x_1 (print 1) hole (print 2)))))
|
||||
(print 2))
|
||||
(λ (x) x))
|
||||
3)
|
||||
(λ (x) x)))
|
||||
"1212" 3)
|
||||
|
||||
(test-transformation
|
||||
(<> () []
|
||||
(% 0
|
||||
(wcm ([1 2] [3 4])
|
||||
((λ (x) x)
|
||||
(wcm ([1 5] [3 6])
|
||||
(cons (current-marks 1 0)
|
||||
(cons (current-marks 3 0)
|
||||
(list))))))
|
||||
(λ (x) x)))
|
||||
"" ((5 2) (6 4)))
|
||||
|
||||
(test-transformation
|
||||
(<>
|
||||
()
|
||||
()
|
||||
(dw
|
||||
ra
|
||||
(print 1)
|
||||
(print 2)
|
||||
(print 3)))
|
||||
"23" #f)
|
||||
|
||||
(test-transformation
|
||||
(<> ()
|
||||
()
|
||||
(%
|
||||
1
|
||||
(dw x_1
|
||||
(print 1)
|
||||
(abort 1 (cont 1 (dw x_1 (print 1) hole (print 3))))
|
||||
(print 3))
|
||||
(λ (k) (% 1 (k 4) (λ (x) x)))))
|
||||
"313" 4)
|
||||
|
||||
(test-transformation
|
||||
(<>
|
||||
()
|
||||
()
|
||||
((comp
|
||||
(dw
|
||||
ra
|
||||
(print 1)
|
||||
hole
|
||||
(dw q (print 2) (print 3) (print 4))))
|
||||
5))
|
||||
"134" 5)
|
||||
|
||||
(define (transformation-preserves-meaning? p)
|
||||
(let ([original-result (parameterize ([model-eval-steps 1000]) (model-eval p))]
|
||||
[transformed (transform-intermediate p)]
|
||||
[warn (λ () (eprintf "Long test:\n") (pretty-write p (current-error-port)))]
|
||||
[threshold (* 60 2)])
|
||||
(or (timeout? original-result)
|
||||
(let ([transformed-result
|
||||
(timeout-warn threshold (model-eval transformed) (warn))])
|
||||
(if (answer? original-result)
|
||||
(equal? original-result transformed-result)
|
||||
(not (answer? transformed-result))))
|
||||
; filters bad tests
|
||||
(bad-test? (timeout-warn threshold (impl-eval (impl-program transformed)) (warn))))))
|
||||
|
||||
(define-syntax-rule (test-transformation/randomized . kw-args)
|
||||
(let ([test-number 1])
|
||||
(redex-check grammar p (transformation-preserves-meaning? (term p))
|
||||
#:prepare fix-prog
|
||||
#:source :-> . kw-args)))
|
||||
|
||||
(time (test-transformation/randomized #:attempts 1 #:attempt-size (const 3)))
|
||||
385
collects/redex/examples/delim-cont/randomized-tests.rkt
Normal file
385
collects/redex/examples/delim-cont/randomized-tests.rkt
Normal file
|
|
@ -0,0 +1,385 @@
|
|||
#lang racket
|
||||
|
||||
(require "grammar.ss"
|
||||
"reduce.rkt"
|
||||
(except-in redex/reduction-semantics plug)
|
||||
racket/runtime-path)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (main [seed-arg #f])
|
||||
(define seed
|
||||
(if seed-arg
|
||||
(string->number seed-arg)
|
||||
(add1 (random (sub1 (expt 2 31))))))
|
||||
(printf "Test seed: ~s\n" seed)
|
||||
(parameterize ([current-pseudo-random-generator test-prg])
|
||||
(random-seed seed))
|
||||
(parameterize ([redex-pseudo-random-generator test-prg])
|
||||
(time (test #:attempts 3000))
|
||||
(time (test #:source :-> #:attempts 3000))))
|
||||
|
||||
(define-syntax-rule (test . kw-args)
|
||||
(redex-check grammar p (same-behavior? (term p))
|
||||
#:prepare fix-prog . kw-args))
|
||||
|
||||
(define fix-prog
|
||||
(match-lambda
|
||||
[`(<> ,s ,_ ,e)
|
||||
(match-let ([`([,xs ,vs] ...) (remove-duplicates s #:key first)])
|
||||
`(<> ,(map list xs (map (fix-expr xs) vs)) [] ,((fix-expr xs) e)))]))
|
||||
|
||||
(define (fix-expr top-vars)
|
||||
(compose drop-duplicate-binders
|
||||
proper-wcms
|
||||
consistent-dws
|
||||
(curry close top-vars '())))
|
||||
|
||||
(struct error (cause) #:transparent)
|
||||
(struct answer (output result) #:transparent)
|
||||
(struct bad-test (reason) #:transparent)
|
||||
(struct timeout ())
|
||||
|
||||
(define (same-behavior? prog)
|
||||
(let ([impl-behavior (timeout-kill 15 (impl-eval (impl-program (transform-intermediate prog))))])
|
||||
(or (bad-test? impl-behavior)
|
||||
(timeout? impl-behavior)
|
||||
(let ([model-behavior (timeout-warn 30 (model-eval prog) (pretty-write prog))])
|
||||
(or (timeout? model-behavior)
|
||||
(if (error? impl-behavior)
|
||||
(error? model-behavior)
|
||||
(and (answer? model-behavior)
|
||||
(equal? impl-behavior model-behavior))))))))
|
||||
|
||||
(define impl-program
|
||||
(match-lambda
|
||||
[`(<> ,s [] ,e)
|
||||
`(letrec ,s ,e)]
|
||||
[e e]))
|
||||
|
||||
(define-runtime-module-path model-impl "model-impl.rkt")
|
||||
|
||||
(define impl-eval
|
||||
(let ([ns (make-base-empty-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require 'racket)
|
||||
(namespace-require (resolved-module-path-name model-impl)))
|
||||
(define show
|
||||
(match-lambda
|
||||
[(? procedure?) 'procedure]
|
||||
[(? list? vs) (map show vs)]
|
||||
[v v]))
|
||||
(λ (test)
|
||||
(define output (open-output-string))
|
||||
(define result
|
||||
(with-handlers ([exn:fail?
|
||||
(λ (e)
|
||||
(match (exn-message e)
|
||||
[(regexp #rx"%: expected argument of type <non-procedure>")
|
||||
(bad-test "procedure as tag")]
|
||||
[_ (error e)]))])
|
||||
(parameterize ([current-output-port output])
|
||||
(eval test ns))))
|
||||
(if (or (error? result) (bad-test? result))
|
||||
result
|
||||
(answer (get-output-string output)
|
||||
(show result))))))
|
||||
|
||||
(define model-eval-steps (make-parameter +inf.0))
|
||||
|
||||
(define (model-eval prog)
|
||||
(let/ec return
|
||||
(define show
|
||||
(match-lambda
|
||||
[(? number? n) n]
|
||||
[(? boolean? b) b]
|
||||
[`(list . ,vs) (map show vs)]
|
||||
[v 'procedure]))
|
||||
(define (eval prog steps)
|
||||
(define ns (set))
|
||||
(let recur ([p prog] [d steps] [s (set)])
|
||||
(define qs (apply-reduction-relation :-> p))
|
||||
(if (empty? qs)
|
||||
(set! ns (set-add ns p))
|
||||
(if (< d 0)
|
||||
(return (timeout))
|
||||
(for ([q qs])
|
||||
(if (set-member? s q)
|
||||
(return (timeout))
|
||||
(recur q (sub1 d) (set-add s p)))))))
|
||||
(set-map ns values))
|
||||
(match (eval prog (model-eval-steps))
|
||||
[(list (and p `(<> ,_ ,output ,result)))
|
||||
(if (v? result)
|
||||
(answer
|
||||
(apply string-append (map (curry format "~v") output))
|
||||
(show result))
|
||||
(error p))])))
|
||||
|
||||
(define (with-timeout thunk timeout on-timeout)
|
||||
(let ([c (make-channel)])
|
||||
(struct raised (value))
|
||||
(let ([t (thread
|
||||
(λ ()
|
||||
(channel-put
|
||||
c (with-handlers ([exn:fail? raised])
|
||||
(thunk)))))])
|
||||
(match (sync/timeout timeout c)
|
||||
[#f (on-timeout t c)]
|
||||
[(raised v) (raise v)]
|
||||
[x x]))))
|
||||
|
||||
(define-syntax-rule (timeout-kill time expr)
|
||||
(with-timeout (λ () expr) time
|
||||
(λ (t _)
|
||||
(kill-thread t)
|
||||
(timeout))))
|
||||
(define-syntax-rule (timeout-warn time expr warn)
|
||||
(with-timeout (λ () expr) time
|
||||
(λ (_ c)
|
||||
warn
|
||||
(sync c))))
|
||||
|
||||
(define (close top-vars loc-vars expr)
|
||||
(match expr
|
||||
[(? x? x)
|
||||
(let ([bound (append top-vars loc-vars)])
|
||||
(cond [(memq x bound) x]
|
||||
[(not (empty? bound))
|
||||
(random-member bound)]
|
||||
[else (random-literal)]))]
|
||||
[`(set! ,x ,e)
|
||||
(if (empty? top-vars)
|
||||
(close top-vars loc-vars e)
|
||||
`(set! ,(random-member top-vars)
|
||||
,(close top-vars loc-vars e)))]
|
||||
[`(λ ,xs ,e)
|
||||
`(λ ,xs
|
||||
,(close (filter (negate (curryr member xs)) top-vars)
|
||||
(append xs loc-vars)
|
||||
e))]
|
||||
[`(dw ,x ,e_1 ,e_2 ,e_3)
|
||||
`(dw ,x
|
||||
,(close top-vars loc-vars e_1)
|
||||
,(close top-vars loc-vars e_2)
|
||||
,(close top-vars loc-vars e_3))]
|
||||
; substitution does not recur inside continuation values
|
||||
; (not sure why it bothers to recur within dw expression)
|
||||
[`(cont ,v ,E)
|
||||
`(cont ,(close top-vars '() v)
|
||||
,(close top-vars '() E))]
|
||||
[`(cont ,E)
|
||||
`(comp ,(close top-vars '() E))]
|
||||
[(? list?)
|
||||
(map (curry close top-vars loc-vars) expr)]
|
||||
[_ expr]))
|
||||
|
||||
(define drop-duplicate-binders
|
||||
(match-lambda
|
||||
[`(λ ,xs ,e)
|
||||
`(λ ,(remove-duplicates xs) ,(drop-duplicate-binders e))]
|
||||
[(? list? es)
|
||||
(map drop-duplicate-binders es)]
|
||||
[e e]))
|
||||
|
||||
(define (consistent-dws p)
|
||||
(define pre-post
|
||||
(let ([h (make-hash)])
|
||||
(λ (id pre post)
|
||||
(match (hash-ref h id #f)
|
||||
[#f
|
||||
(hash-set! h id (list pre post))
|
||||
(list pre post)]
|
||||
[x x]))))
|
||||
(let recur ([x p] [excluded '()])
|
||||
(match x
|
||||
[`(dw ,x ,e1 ,e2 ,e3)
|
||||
(if (member x excluded)
|
||||
(recur e2 excluded)
|
||||
(match-let ([(list e1’ e3’) (pre-post x e1 e3)])
|
||||
`(dw ,x
|
||||
,(recur e1’ (cons x excluded))
|
||||
,(recur e2 excluded)
|
||||
,(recur e3’ (cons x excluded)))))]
|
||||
[(? list?) (map (curryr recur excluded) x)]
|
||||
[_ x])))
|
||||
|
||||
(define (proper-wcms e)
|
||||
(let fix ([ok? #t] [e e])
|
||||
(match e
|
||||
[`(wcm ,w ,e)
|
||||
(if ok?
|
||||
`(wcm ,(remove-duplicates (fix #t w) #:key first)
|
||||
,(fix #f e))
|
||||
(fix #f e))]
|
||||
[`(list . ,vs)
|
||||
`(list . ,(map (curry fix #t) vs))]
|
||||
[`(λ ,xs ,e)
|
||||
; #f in case applied with a continuation that's already marked
|
||||
`(λ ,xs ,(fix #f e))]
|
||||
[`(cont ,v ,E)
|
||||
`(cont ,(fix #t v) ,(fix #t E))]
|
||||
[`(comp ,E)
|
||||
`(comp ,(fix #t E))]
|
||||
[`(begin ,e1 ,e2)
|
||||
`(begin ,(fix #t e1)
|
||||
,(fix ok? e2))]
|
||||
[`(% ,e1 ,e2 ,e3)
|
||||
`(% ,(fix #t e1) ,(fix ok? e2) ,(fix #t e3))]
|
||||
[`(dw ,x ,e1 ,e2 ,e3)
|
||||
`(dw ,x ,(fix #t e1) ,(fix ok? e2) ,(fix #t e3))]
|
||||
[`(if ,e1 ,e2 ,e3)
|
||||
`(if ,(fix #t e1)
|
||||
,(fix ok? e2)
|
||||
,(fix ok? e3))]
|
||||
[`(set! ,x ,e)
|
||||
`(set! ,x ,(fix #t e))]
|
||||
[(? list?)
|
||||
(map (curry fix #t) e)]
|
||||
[_ e])))
|
||||
|
||||
(define transform-intermediate
|
||||
(match-lambda
|
||||
[(and p `(<> ,s ,o ,e))
|
||||
(define fresh (make-fresh p))
|
||||
(define allocated (map first s))
|
||||
(define (alloc-cell prefix)
|
||||
(define cell (fresh prefix))
|
||||
(set! allocated (cons cell allocated))
|
||||
cell)
|
||||
(define no-dw? (alloc-cell "handlers-disabled?"))
|
||||
(define dw-frame-locs
|
||||
(let ([locs (make-hash)])
|
||||
(λ (x)
|
||||
(hash-ref
|
||||
locs x
|
||||
(λ () (let ([ys (list (alloc-cell (format "~s-allocated?" x))
|
||||
(alloc-cell (format "~s-skip-pre?" x))
|
||||
(alloc-cell (format "~s-comp-cont" x)))])
|
||||
(hash-set! locs x ys)
|
||||
ys))))))
|
||||
(define transform
|
||||
(match-lambda
|
||||
[`(wcm () ,m)
|
||||
(transform m)]
|
||||
[`(wcm ([,k ,v] . ,w) ,m)
|
||||
`(call/cm ,(transform k) ,(transform v)
|
||||
(λ () ,(transform `(wcm ,w ,m))))]
|
||||
[(and e `(dw ,x ,e1 ,e2 ,e3))
|
||||
(match-let ([(list a? s? c) (dw-frame-locs x)]
|
||||
[t (fresh "t")])
|
||||
`((λ (,t)
|
||||
(if ,a?
|
||||
(begin (if ,no-dw? #f (set! ,s? #t)) (,c ,t))
|
||||
(% 1
|
||||
(dynamic-wind
|
||||
(λ ()
|
||||
(if ,no-dw?
|
||||
#f
|
||||
(if ,a?
|
||||
(if ,s? (set! ,s? #f) ,(transform e1))
|
||||
#f)))
|
||||
(λ ()
|
||||
((call/comp
|
||||
(λ (k)
|
||||
(begin
|
||||
(set! ,c k)
|
||||
(abort 1 k)))
|
||||
1)))
|
||||
(λ ()
|
||||
(if ,no-dw?
|
||||
(set! ,a? #t)
|
||||
(if ,a?
|
||||
,(transform e3)
|
||||
(set! ,a? #t)))))
|
||||
(λ (k) (begin (if ,no-dw? #f (set! ,s? #t)) (k ,t))))))
|
||||
(λ () ,(transform e2))))]
|
||||
[`(cont ,v ,E)
|
||||
(let ([x (fresh "v")])
|
||||
`(begin
|
||||
(set! ,no-dw? #t)
|
||||
((λ (,x)
|
||||
(% ,x
|
||||
,(transform
|
||||
(term (plug ,E (call/cc (λ (k) (abort ,x k)) ,x))))
|
||||
(λ (x) (begin (set! ,no-dw? #f) x))))
|
||||
,(transform v))))]
|
||||
[`(comp ,E)
|
||||
(define numbers
|
||||
(match-lambda
|
||||
[(? integer? n) (list n)]
|
||||
[(? list? l) (append-map numbers l)]
|
||||
[_ (list)]))
|
||||
(define t (add1 (apply max 0 (numbers E))))
|
||||
`(begin
|
||||
(set! ,no-dw? #t)
|
||||
(% ,t
|
||||
,(transform
|
||||
(term (plug ,E (call/comp (λ (k) (abort ,t k)) ,t))))
|
||||
(λ (x) (begin (set! ,no-dw? #f) x))))]
|
||||
[`(list ,vs ...)
|
||||
`(list ,@(map transform-value vs))]
|
||||
[(? list? xs)
|
||||
(map transform xs)]
|
||||
[e e]))
|
||||
(define transform-value
|
||||
(match-lambda
|
||||
[(and e (or `(cont ,_ ,_) `(comp ,_)))
|
||||
`(λ (x) (,(transform e) x))]
|
||||
[e (transform e)]))
|
||||
(define e’ (transform e))
|
||||
(define s’ (map (match-lambda [(list x v) (list x (transform-value v))]) s))
|
||||
`(<> ,(map (λ (x) (match (assoc x s’)
|
||||
[#f (list x #f)]
|
||||
[(list _ v’) (list x v’)]))
|
||||
allocated)
|
||||
,o
|
||||
,e’)]))
|
||||
|
||||
;; The built-in `plug' sometimes chooses the wrong hole.
|
||||
(define-metafunction grammar
|
||||
[(plug hole any) any]
|
||||
[(plug (in-hole W (dw x e_1 E e_2)) any)
|
||||
(in-hole W (dw x e_1 (plug E any) e_2))]
|
||||
[(plug (wcm w M) any)
|
||||
(wcm w (plug M any))]
|
||||
[(plug (v ... W e ...) any)
|
||||
(v ... (plug W any) e ...)]
|
||||
[(plug (begin W e) any)
|
||||
(begin (plug W any) e)]
|
||||
[(plug (% W e_1 e_2) any)
|
||||
(% (plug W any) e_1 e_2)]
|
||||
[(plug (% v e W) any)
|
||||
(% v e (plug W any))]
|
||||
[(plug (% v_1 W v_2) any)
|
||||
(% v_1 (plug W any) v_2)]
|
||||
[(plug (set! x W) any)
|
||||
(set! x (plug W any))]
|
||||
[(plug (if W e_1 e_2) any)
|
||||
(if (plug W any) e_1 e_2)])
|
||||
|
||||
(define (make-fresh p)
|
||||
(define suffix
|
||||
(let recur ([x p] [s 0])
|
||||
(cond [(symbol? x)
|
||||
(match (regexp-match #rx"_(.+)$" (symbol->string x))
|
||||
[(list _ n) (max s (add1 (string->number n)))]
|
||||
[#f s])]
|
||||
[(pair? x) (recur (cdr x) (recur (car x) s))]
|
||||
[else s])))
|
||||
(λ (prefix)
|
||||
(begin0 (string->symbol (format "~a_~a" prefix suffix))
|
||||
(set! suffix (add1 suffix)))))
|
||||
|
||||
(define (random-literal)
|
||||
(random-member
|
||||
'(dynamic-wind abort current-marks cons
|
||||
-inf.0 +inf.0 -1 0 1 1/3 -1/4 .33 -.25 4-3i 3+4i
|
||||
call/cc call/comp call/cm
|
||||
#f #t zero? print + first rest)))
|
||||
|
||||
(define (random-member xs)
|
||||
(parameterize ([current-pseudo-random-generator test-prg])
|
||||
(list-ref xs (random (length xs)))))
|
||||
|
||||
(define test-prg (make-pseudo-random-generator))
|
||||
Loading…
Reference in New Issue
Block a user