fixed things up so that everything is at least compiling now
svn: r10980
This commit is contained in:
Robby Findler
parent
ba4b0b6301
commit
86c7c808d4
|
|
@ -1,6 +1,5 @@
|
|||
(module arithmetic mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
#lang scheme
|
||||
(require redex)
|
||||
|
||||
(define-language lang
|
||||
(e (binop e e)
|
||||
|
|
@ -39,4 +38,4 @@
|
|||
[(--> (in-hole e-ctxt_1 a) (in-hole e-ctxt_1 b))
|
||||
(c--> a b)]))
|
||||
|
||||
(traces reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2)))))
|
||||
(traces reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2))))
|
||||
|
|
@ -9,10 +9,8 @@ reflects the (broken) spec).
|
|||
|
||||
|#
|
||||
|
||||
(module beginner mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(lib "match.ss"))
|
||||
#lang scheme
|
||||
(require redex)
|
||||
|
||||
(provide run-tests
|
||||
run-big-test)
|
||||
|
|
@ -105,18 +103,10 @@ reflects the (broken) spec).
|
|||
quote))
|
||||
(not (prim-op? (term x))))))
|
||||
|
||||
(define beg-e-subst
|
||||
(subst
|
||||
[(? number?)
|
||||
(constant)]
|
||||
[(? symbol?)
|
||||
(variable)]
|
||||
;; slight cheat here -- but since cond, if, and, or, etc
|
||||
;; aren't allowed to be variables (syntactically), we're okay.
|
||||
[`(,@(e ...))
|
||||
(all-vars '())
|
||||
(build (lambda (vars . e) e))
|
||||
(subterms '() e)]))
|
||||
(define-metafunction beg-e-subst lang
|
||||
[(x v x) v]
|
||||
[(x v (any_1 ...)) ((beg-e-subst (x v any_1)) ...)]
|
||||
[(x v any) any])
|
||||
|
||||
(define (maker? v)
|
||||
(and (symbol? v)
|
||||
|
|
@ -405,19 +395,19 @@ reflects the (broken) spec).
|
|||
(term x_selector))))
|
||||
d/e_after ...))
|
||||
|
||||
where
|
||||
[(==> a b) (--> (in-hole p-ctxt_1 a) (in-hole p-ctxt_1 b))]
|
||||
[(e==> a b) (--> (in-hole p-ctxt a) b)]))
|
||||
with
|
||||
[(--> (in-hole p-ctxt_1 a) (in-hole p-ctxt_1 b)) (==> a b)]
|
||||
[(--> (in-hole p-ctxt a) b) (e==> a b)]))
|
||||
|
||||
(define (defined? f befores)
|
||||
(ormap
|
||||
(lambda (before)
|
||||
(match before
|
||||
[`(define (,a-name ,@(x ...)) ,b)
|
||||
[`(define (,a-name ,x ...) ,b)
|
||||
(eq? f a-name)]
|
||||
[`(define ,a-name (lambda ,@(x ...)))
|
||||
[`(define ,a-name (lambda ,x ...))
|
||||
(eq? f a-name)]
|
||||
[`(define-struct ,struct-name (,@(fields ...)))
|
||||
[`(define-struct ,struct-name (,fields ...))
|
||||
(or (ormap (lambda (field)
|
||||
(eq? f (string->symbol (format "~a-~a" struct-name field))))
|
||||
fields)
|
||||
|
|
@ -440,7 +430,10 @@ reflects the (broken) spec).
|
|||
orig-args)]
|
||||
[else (loop (cdr args)
|
||||
(cdr vars)
|
||||
(beg-e-subst (car vars) (car args) body))])))
|
||||
(term-let ((x (car vars))
|
||||
(v (car args))
|
||||
(body body))
|
||||
(term (beg-e-subst (x v body)))))])))
|
||||
|
||||
(define (selector-name-match? struct fields selector)
|
||||
(ormap (lambda (field) (string=? (format "~a-~a" struct field)
|
||||
|
|
@ -927,5 +920,4 @@ reflects the (broken) spec).
|
|||
;; timing test
|
||||
;#;
|
||||
(time (run-tests)
|
||||
(run-big-test)))
|
||||
|
||||
(run-big-test))
|
||||
|
|
@ -1,6 +1,5 @@
|
|||
(module church mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
#lang scheme
|
||||
(require redex)
|
||||
|
||||
(reduction-steps-cutoff 100)
|
||||
|
||||
|
|
@ -54,4 +53,4 @@
|
|||
(lambda (z)
|
||||
(app (app m s) (app (app n s) z)))))))
|
||||
(let (two (lambda (s) (lambda (z) (app s (app s z)))))
|
||||
(app (app plus two) two)))))
|
||||
(app (app plus two) two))))
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
#lang scheme
|
||||
|
||||
;"one point basis"
|
||||
;"formal aspects of computing"
|
||||
|
||||
(module combinators mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
(require redex)
|
||||
|
||||
(initial-font-size 12)
|
||||
(reduction-steps-cutoff 100)
|
||||
|
|
@ -54,14 +54,15 @@
|
|||
(define (make-w b c c*) `(,c ((,c ((,b ,c) ((,c ((,b j) ,c*)) ,c*))) ,c*)))
|
||||
(define (make-s b c w) `((,b ((,b (,b ,w)) ,c)) (,b ,b)))
|
||||
|
||||
(traces/multiple lang
|
||||
(traces lang
|
||||
relation
|
||||
(list
|
||||
`((,c* abs1) abs2)
|
||||
`(((,(make-c 'c*) abs1) abs2) abs3)
|
||||
`(((,(make-b 'c) abs1) abs2) abs3)
|
||||
`((,(make-w 'b 'c 'c*) abs1) abs2)
|
||||
`(((,(make-s 'b 'c 'w) abs1) abs2) abs3)))
|
||||
`(((,(make-s 'b 'c 'w) abs1) abs2) abs3))
|
||||
#:multiple #t)
|
||||
|
||||
(require (lib "pretty.ss"))
|
||||
#;
|
||||
|
|
@ -87,4 +88,4 @@
|
|||
(make-c c*)
|
||||
(make-w (make-b (make-c c*))
|
||||
(make-c c*)
|
||||
c*))))
|
||||
c*)))
|
||||
|
|
@ -1,6 +1,5 @@
|
|||
(module compatible-closure mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
#lang scheme
|
||||
(require redex)
|
||||
|
||||
(define-language grammar
|
||||
(B t
|
||||
|
|
@ -15,4 +14,4 @@
|
|||
|
||||
(define ->r (compatible-closure r grammar B))
|
||||
|
||||
(traces grammar ->r '((f * f) * (t * f))))
|
||||
(traces grammar ->r '((f * f) * (t * f)))
|
||||
|
|
|
|||
|
|
@ -1,67 +0,0 @@
|
|||
(module eta mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui)
|
||||
(planet robby/redex:5/subst))
|
||||
|
||||
(reduction-steps-cutoff 100)
|
||||
|
||||
(define-language lang
|
||||
(e (e e)
|
||||
x
|
||||
(+ e e)
|
||||
v)
|
||||
(c (v c)
|
||||
(c e)
|
||||
(+ v c)
|
||||
(+ c e)
|
||||
hole)
|
||||
(v (lambda (x) e)
|
||||
number)
|
||||
(x (variable-except lambda +)))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(c=> ((lambda (variable_x) e_body) v_arg)
|
||||
,(lc-subst (term variable_x) (term v_arg) (term e_body)))
|
||||
(c=> (+ number_1 number_2)
|
||||
,(+ (term number_1) (term number_2)))
|
||||
(c=> (side-condition (lambda (variable_x) (e_fun variable_x))
|
||||
(equal? (term e_fun) (lc-subst (term variable_x) 1234 (term e_fun))))
|
||||
e_fun)
|
||||
|
||||
(--> (in-hole c (number_n v_arg))
|
||||
,(format "procedure application: expected procedure, given: ~a; arguments were: ~a"
|
||||
(term number_n)
|
||||
(term v_arg)))
|
||||
(--> (in-hole c (+ (name non-num (lambda (variable) e)) (name arg2 v)))
|
||||
,(format "+: expects type <number> as 1st argument, given: ~s; other arguments were: ~s"
|
||||
(term non-num) (term arg2)))
|
||||
(--> (in-hole c (+ (name arg1 v) (name non-num (lambda (variable) e))))
|
||||
,(format "+: expects type <number> as 2nd argument, given: ~s; other arguments were: ~s"
|
||||
(term arg1) (term non-num)))
|
||||
|
||||
where
|
||||
|
||||
[(c=> x y) (--> (in-hole c_1 x) (in-hole c_1 y))]))
|
||||
|
||||
(define lc-subst
|
||||
(subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(+ ,n2 ,n1)
|
||||
(all-vars '())
|
||||
(build (lambda (vars n1 n2) `(+ ,n1 ,n1)))
|
||||
(subterm '() n1)
|
||||
(subterm '() n2)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
(traces lang reductions '(+ (lambda (x) ((+ 1 2) x)) 1)))
|
||||
|
|
@ -1,254 +0,0 @@
|
|||
(module iswim mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(lib "contract.ss"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Expression grammar:
|
||||
|
||||
(define-language iswim-grammar
|
||||
(M (M M)
|
||||
(o1 M)
|
||||
(o2 M M)
|
||||
V
|
||||
("letcc" X M)
|
||||
("cc" M M))
|
||||
(V X
|
||||
("lam" variable M)
|
||||
b
|
||||
("[" M "]"))
|
||||
(X variable)
|
||||
(b number)
|
||||
(o1 "add1" "sub1" "iszero")
|
||||
(o2 "+" "-" "*" "^")
|
||||
(on o1 o2)
|
||||
|
||||
;; Evaluation contexts:
|
||||
(E hole
|
||||
(E M)
|
||||
(V E)
|
||||
(o1 E)
|
||||
(o2 E M)
|
||||
(o2 V E)
|
||||
("cc" E M)
|
||||
("cc" V E))
|
||||
|
||||
;; Continuations (CK machine):
|
||||
(k "mt"
|
||||
("fun" V k)
|
||||
("arg" M k)
|
||||
("narg" (V ... on) (M ...) k))
|
||||
|
||||
;; Environments and closures (CEK):
|
||||
(env ((X = vcl) ...))
|
||||
(cl (M : env))
|
||||
(vcl (V- : env))
|
||||
|
||||
;; Values that are not variables:
|
||||
(V- ("lam" variable M)
|
||||
b)
|
||||
|
||||
;; Continuations with closures (CEK):
|
||||
(k- "mt"
|
||||
("fun" vcl k-)
|
||||
("arg" cl k-)
|
||||
("narg" (vcl ... on) (cl ...) k-)))
|
||||
|
||||
(define M? (redex-match iswim-grammar M))
|
||||
(define V? (redex-match iswim-grammar V))
|
||||
(define o1? (redex-match iswim-grammar o1))
|
||||
(define o2? (redex-match iswim-grammar o2))
|
||||
(define on? (redex-match iswim-grammar on))
|
||||
(define k? (redex-match iswim-grammar k))
|
||||
|
||||
(define env? (redex-match iswim-grammar env))
|
||||
(define cl? (redex-match iswim-grammar cl))
|
||||
(define vcl? (redex-match iswim-grammar vcl))
|
||||
(define k-? (redex-match iswim-grammar k-))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Substitution:
|
||||
|
||||
;; The subst form makes implemention of capture-avoiding
|
||||
;; easier. We just have to describe how variables bind
|
||||
;; in our language's forms.
|
||||
|
||||
(define iswim-subst/backwards
|
||||
(subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`("lam" ,X ,M)
|
||||
(all-vars (list X))
|
||||
(build (lambda (X-list M) `("lam" ,(car X-list) ,M)))
|
||||
(subterm (list X) M)]
|
||||
[`(,(and o (or "add1" "sub1" "iszero")) ,M1)
|
||||
(all-vars '())
|
||||
(build (lambda (vars M1) `(,o ,M1)))
|
||||
(subterm '() M1)]
|
||||
[`(,(and o (or "+" "-" "*" "^")) ,M1 ,M2)
|
||||
(all-vars '())
|
||||
(build (lambda (vars M1 M2) `(,o ,M1 ,M2)))
|
||||
(subterm '() M1)
|
||||
(subterm '() M2)]
|
||||
[`(,M1 ,M2)
|
||||
(all-vars '())
|
||||
(build (lambda (empty-list M1 M2) `(,M1 ,M2)))
|
||||
(subterm '() M1)
|
||||
(subterm '() M2)]
|
||||
[`("letcc" ,X ,M)
|
||||
(all-vars (list X))
|
||||
(build (lambda (X-list M) `("letcc" ,(car X-list) ,M)))
|
||||
(subterm (list X) M)]
|
||||
[`("cc" ,M1 ,M2)
|
||||
(all-vars '())
|
||||
(build (lambda (vars M1 M2) `("cc" ,M1 ,M2)))
|
||||
(subterm '() M1)
|
||||
(subterm '() M2)]
|
||||
[`("[" ,E "]")
|
||||
(all-vars '())
|
||||
(build (lambda (vars) `("[" ,E "]")))]))
|
||||
|
||||
|
||||
;; the argument order for the subst-generated function
|
||||
;; doesn't match the order in the notes:
|
||||
(define (iswim-subst M Xr Mr)
|
||||
(iswim-subst/backwards Xr Mr M))
|
||||
|
||||
(define empty-env '())
|
||||
|
||||
;; Environment lookup
|
||||
(define (env-lookup env X)
|
||||
(let ([m (assq X env)])
|
||||
(and m (caddr m))))
|
||||
|
||||
;; Environment extension
|
||||
(define (env-extend env X vcl)
|
||||
(cons (list X '= vcl) env))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Reductions:
|
||||
|
||||
;; beta_v reduction
|
||||
(define beta_v
|
||||
(reduction-relation
|
||||
iswim-grammar
|
||||
(--> (("lam" X_1 M_1) V_1)
|
||||
,(iswim-subst (term M_1) (term X_1) (term V_1)))))
|
||||
|
||||
(define delta
|
||||
(reduction-relation
|
||||
iswim-grammar
|
||||
(--> ("add1" b_1) ,(add1 (term b_1)))
|
||||
(--> ("sub1" b_1) ,(sub1 (term b_1)))
|
||||
(--> ("iszero" b_1)
|
||||
,(if (zero? (term b_1))
|
||||
(term ("lam" x ("lam" y x)))
|
||||
(term ("lam" x ("lam" y y)))))
|
||||
(--> ("+" b_1 b_2) ,(+ (term b_1) (term b_2)))
|
||||
(--> ("-" b_1 b_2) ,(- (term b_1) (term b_2)))
|
||||
(--> ("*" b_1 b_2) ,(* (term b_1) (term b_2)))
|
||||
(--> ("^" b_1 b_2) ,(expt (term b_1) (term b_2)))))
|
||||
|
||||
;; ->v
|
||||
(define ->v (compatible-closure (union-reduction-relations beta_v delta)
|
||||
iswim-grammar
|
||||
M))
|
||||
|
||||
;; :->v
|
||||
(define :->v (context-closure (union-reduction-relations beta_v delta)
|
||||
iswim-grammar
|
||||
E))
|
||||
|
||||
;; :->v+letcc
|
||||
(define :->v+letcc
|
||||
(union-reduction-relations
|
||||
:->v
|
||||
(reduction-relation
|
||||
iswim-grammar
|
||||
|
||||
;; letcc rule:
|
||||
(--> (in-hole E_1 ("letcc" X_1 M_1))
|
||||
(in-hole E_1 ,(iswim-subst (term M_1)
|
||||
(term X_1)
|
||||
`("[" (in-hole E_1 ||) "]"))))
|
||||
|
||||
;; cc rule:
|
||||
(--> (in-hole E ("cc" ("[" (in-hole E_2 ||) "]") V_1))
|
||||
(in-hole E_2 V_1)))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Helpers:
|
||||
|
||||
(define (delta*n on Vs)
|
||||
(let ([l (apply-reduction-relation delta `(,on ,@Vs))])
|
||||
(if (null? l)
|
||||
#f
|
||||
(car l))))
|
||||
|
||||
(define (delta*1 o1 V)
|
||||
(delta*n o1 (list V)))
|
||||
|
||||
(define (delta*2 o2 V1 V2)
|
||||
(delta*n o2 (list V1 V2)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Abbreviations:
|
||||
|
||||
(define (if0 test then else)
|
||||
(let ([X (variable-not-in `(,then ,else) 'X)])
|
||||
`(((("iszero" ,test) ("lam" ,X ,then)) ("lam" ,X ,else)) 77)))
|
||||
|
||||
(define true '("lam" x ("lam" y x)))
|
||||
(define false '("lam" x ("lam" y y)))
|
||||
(define boolean-not `("lam" x ((x ,false) ,true)))
|
||||
|
||||
(define mkpair '("lam" x ("lam" y ("lam" s ((s x) y)))))
|
||||
(define fst '("lam" p (p ("lam" x ("lam" y x)))))
|
||||
(define snd '("lam" p (p ("lam" x ("lam" y y)))))
|
||||
|
||||
(define Y_v '("lam" f ("lam" x
|
||||
((("lam" g (f ("lam" x ((g g) x))))
|
||||
("lam" g (f ("lam" x ((g g) x)))))
|
||||
x))))
|
||||
|
||||
(define mksum `("lam" s
|
||||
("lam" x
|
||||
,(if0 'x 0 '("+" x (s ("sub1" x)))))))
|
||||
(define sum `(,Y_v ,mksum))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Exports:
|
||||
|
||||
(provide iswim-grammar)
|
||||
|
||||
(provide/contract (M? (any/c . -> . any/c))
|
||||
(V? (any/c . -> . any/c))
|
||||
(o1? (any/c . -> . any/c))
|
||||
(o2? (any/c . -> . any/c))
|
||||
(on? (any/c . -> . any/c))
|
||||
(k? (any/c . -> . any/c))
|
||||
(env? (any/c . -> . any/c))
|
||||
(cl? (any/c . -> . any/c))
|
||||
(vcl? (any/c . -> . any/c))
|
||||
(iswim-subst (M? symbol? M? . -> . M?))
|
||||
(env-lookup (env? symbol? . -> . (union false/c vcl?)))
|
||||
(env-extend (env? symbol? vcl? . -> . env?))
|
||||
(empty-env env?)
|
||||
(beta_v reduction-relation?)
|
||||
(delta reduction-relation?)
|
||||
(delta*1 (o1? V? . -> . (union false/c V?)))
|
||||
(delta*2 (o2? V? V? . -> . (union false/c V?)))
|
||||
(delta*n (on? (listof V?) . -> . (union false/c V?)))
|
||||
(->v reduction-relation?)
|
||||
(:->v reduction-relation?)
|
||||
(:->v+letcc reduction-relation?)
|
||||
(if0 (M? M? M? . -> . M?))
|
||||
(true M?)
|
||||
(false M?)
|
||||
(boolean-not M?)
|
||||
(mkpair M?)
|
||||
(fst M?)
|
||||
(snd M?)
|
||||
(Y_v M?)
|
||||
(sum M?)))
|
||||
|
|
@ -1,8 +1,12 @@
|
|||
(module letrec mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui)
|
||||
(planet robby/redex:5/subst)
|
||||
(lib "list.ss"))
|
||||
#lang scheme
|
||||
|
||||
#|
|
||||
|
||||
BUG: letrec & let are not handled properly by substitution
|
||||
|
||||
|#
|
||||
|
||||
(require redex "subst.ss")
|
||||
|
||||
(reduction-steps-cutoff 20)
|
||||
|
||||
|
|
@ -26,42 +30,15 @@
|
|||
(begin ec e e ...)
|
||||
hole))
|
||||
|
||||
(define substitute
|
||||
(subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(set! ,x ,e)
|
||||
(all-vars '())
|
||||
(build (lambda (vars name body) `(set! ,name ,body)))
|
||||
(subterm '() x)
|
||||
(subterm '() e)]
|
||||
[`(let ((,x ,e1)) ,e2)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars letval body) `(let ((,(car vars) ,letval)) ,body)))
|
||||
(subterm '() e1)
|
||||
(subterm (list x) e2)]
|
||||
[`(letrec ((,x ,e1)) ,e2)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars letval body) `(letrec ((,(car vars) ,letval)) ,body)))
|
||||
(subterm (list x) e1)
|
||||
(subterm (list x) e2)]
|
||||
[`(begin ,@(es ...))
|
||||
(all-vars (list))
|
||||
(build (lambda (vars . rest) `(begin ,@rest)))
|
||||
(subterms '() es)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
;; collect : term -> term
|
||||
;; performs a garbage collection on the term `p'
|
||||
(define (collect p)
|
||||
(define (substitute var exp body)
|
||||
(term-let ((var var)
|
||||
(exp exp)
|
||||
(body body))
|
||||
(term (subst (var exp body)))))
|
||||
|
||||
(define (find-unused vars p)
|
||||
(filter (λ (var) (unused? var p))
|
||||
vars))
|
||||
|
|
@ -122,8 +99,7 @@
|
|||
set!)
|
||||
|
||||
(==> (in-hole pc_1 ((lambda (x_1) e_1) v_1))
|
||||
(in-hole pc_1
|
||||
,(substitute (term x_1) (term v_1) (term e_1)))
|
||||
(in-hole pc_1 (subst (x_1 v_1 e_1)))
|
||||
βv)
|
||||
|
||||
(==> ((store (name the-store any) ...)
|
||||
|
|
@ -131,16 +107,15 @@
|
|||
,(let ((new-x (variable-not-in (term (the-store ...)) (term x_1))))
|
||||
(term
|
||||
((store the-store ... (,new-x v_1))
|
||||
(in-hole ec_1
|
||||
,(substitute (term x_1) new-x (term e_1))))))
|
||||
(in-hole ec_1 (subst (x_1 ,new-x e_1))))))
|
||||
let)
|
||||
|
||||
(==> (in-hole pc_1 (letrec ((x_1 e_1)) e_2))
|
||||
(in-hole pc_1 (let ((x_1 0)) (begin (set! x_1 e_1) e_2)))
|
||||
letrec)
|
||||
|
||||
where
|
||||
[(==> a b) (--> a ,(collect (term b)))]))
|
||||
with
|
||||
[(--> a ,(collect (term b))) (==> a b)]))
|
||||
|
||||
(define (run e) (traces lang reductions `((store) ,e)))
|
||||
|
||||
|
|
@ -152,4 +127,4 @@
|
|||
(run '(letrec ((f (lambda (x)
|
||||
(letrec ((y 1))
|
||||
(f 1)))))
|
||||
(f 3))))
|
||||
(f 3)))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
(module omega mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(planet robby/redex:5/gui))
|
||||
#lang scheme
|
||||
(require redex "subst.ss")
|
||||
|
||||
(reduction-steps-cutoff 10)
|
||||
|
||||
|
|
@ -30,31 +28,9 @@
|
|||
e_1
|
||||
abort)
|
||||
(--> (in-hole c_1 ((lambda (variable_x) e_body) v_arg))
|
||||
(in-hole c_1 ,(lc-subst (term variable_x) (term v_arg) (term e_body)))
|
||||
(in-hole c_1 (subst (variable_x v_arg e_body)))
|
||||
βv)))
|
||||
|
||||
(define lc-subst
|
||||
(plt-subst
|
||||
['abort (constant)]
|
||||
['call/cc (constant)]
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(call/cc ,v)
|
||||
(all-vars '())
|
||||
(build (lambda (vars arg) `(call/cc ,arg)))
|
||||
(subterm '() v)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
|
||||
(traces lang reductions '((lambda (x) (x x)) (lambda (x) (x x))))
|
||||
(traces lang reductions '((call/cc call/cc) (call/cc call/cc)))
|
||||
(traces lang reductions '((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
#lang scheme
|
||||
(require redex)
|
||||
|
||||
#|
|
||||
|
||||
semaphores make things much more predictable...
|
||||
|
||||
|#
|
||||
|
||||
(module semaphores mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
|
||||
(reduction-steps-cutoff 100)
|
||||
|
||||
(define-language lang
|
||||
|
|
@ -166,4 +165,4 @@ semaphores make things much more predictable...
|
|||
(semaphore-post (semaphore x)))
|
||||
(begin (semaphore-wait (semaphore x))
|
||||
(set! y (cons 2 y))
|
||||
(semaphore-post (semaphore x)))))))
|
||||
(semaphore-post (semaphore x))))))
|
||||
|
|
@ -1,8 +1,5 @@
|
|||
(module subject-reduction mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui)
|
||||
(planet robby/redex:5/subst)
|
||||
(lib "plt-match.ss"))
|
||||
#lang scheme
|
||||
(require redex)
|
||||
|
||||
(reduction-steps-cutoff 10)
|
||||
|
||||
|
|
@ -35,27 +32,9 @@
|
|||
|
||||
;; this rules calls subst with the wrong arguments, which is caught by the example below.
|
||||
(--> (in-hole c_1 ((lambda (x_format t_1) e_body) v_actual))
|
||||
(in-hole c_1 ,(lc-subst (term x_format) (term e_body) (term v_actual)))
|
||||
(in-hole c_1 (subst x_format v_actual e_body))
|
||||
βv)))
|
||||
|
||||
(define lc-subst
|
||||
(plt-subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x ,t) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars) ,t) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(call/cc ,v)
|
||||
(all-vars '())
|
||||
(build (lambda (vars arg) `(call/cc ,arg)))
|
||||
(subterm '() v)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
(define (type-check term)
|
||||
(let/ec k
|
||||
(let loop ([term term]
|
||||
|
|
@ -87,6 +66,6 @@
|
|||
(equal? (type-check term2) t1)))))
|
||||
|
||||
(define (show term)
|
||||
(traces/pred lang reductions (list term) (pred term)))
|
||||
(traces reductions term #:pred (pred term)))
|
||||
|
||||
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x)))))
|
||||
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x))))
|
||||
74
collects/redex/examples/subst.ss
Normal file
74
collects/redex/examples/subst.ss
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
#lang scheme
|
||||
(require redex)
|
||||
(provide subst subst-n)
|
||||
|
||||
(define-language subst-lang
|
||||
(x variable))
|
||||
|
||||
(define-metafunction subst-n
|
||||
subst-lang
|
||||
[((x_1 any_1) (x_2 any_2) ... any_3)
|
||||
(subst (x_1 any_1 (subst-n ((x_2 any_2) ... any_3))))]
|
||||
[(any_3) any_3])
|
||||
|
||||
(define-metafunction subst
|
||||
subst-lang
|
||||
;; 1. x_1 bound, so don't continue in λ body
|
||||
[(x_1 any_1 (λ (x_2 ... x_1 x_3 ...) any_2))
|
||||
(λ (x_2 ... x_1 x_3 ...) any_2)
|
||||
(side-condition (not (member (term x_1) (term (x_2 ...)))))]
|
||||
;; 2. general purpose capture avoiding case
|
||||
[(x_1 any_1 (λ (x_2 ...) any_2))
|
||||
,(term-let ([(x_new ...)
|
||||
(variables-not-in (term (x_1 any_1 any_2))
|
||||
(term (x_2 ...)))])
|
||||
(term
|
||||
(λ (x_new ...)
|
||||
(subst (x_1 any_1 (subst-vars ((x_2 x_new) ... any_2)))))))]
|
||||
;; 3. replace x_1 with e_1
|
||||
[(x_1 any_1 x_1) any_1]
|
||||
;; 4. x_1 and x_2 are different, so don't replace
|
||||
[(x_1 any_1 x_2) x_2]
|
||||
;; the last two cases cover all other expression forms
|
||||
[(x_1 any_1 (any_2 ...))
|
||||
((subst (x_1 any_1 any_2)) ...)]
|
||||
[(x_1 any_1 any_2) any_2])
|
||||
|
||||
(define-metafunction subst-vars
|
||||
subst-lang
|
||||
[((x_1 any_1) x_1) any_1]
|
||||
[((x_1 any_1) (any_2 ...)) ((subst-vars ((x_1 any_1) any_2)) ...)]
|
||||
[((x_1 any_1) any_2) any_2]
|
||||
[((x_1 any_1) (x_2 any_2) ... any_3)
|
||||
(subst-vars ((x_1 any_1) (subst-vars ((x_2 any_2) ... any_3))))]
|
||||
[(any) any])
|
||||
|
||||
(begin
|
||||
(test-equal (term (subst (x y x))) (term y))
|
||||
(test-equal (term (subst (x y z))) (term z))
|
||||
(test-equal (term (subst (x y (x (y z))))) (term (y (y z))))
|
||||
(test-equal (term (subst (x y ((λ (x) x) ((λ (y1) y1) (λ (x) z))))))
|
||||
(term ((λ (x) x) ((λ (y2) y2) (λ (x) z)))))
|
||||
(test-equal (term (subst (x y (if0 (+ 1 x) x x))))
|
||||
(term (if0 (+ 1 y) y y)))
|
||||
(test-equal (term (subst (x (λ (z) y) (λ (y) x))))
|
||||
(term (λ (y1) (λ (z) y))))
|
||||
(test-equal (term (subst (x 1 (λ (y) x))))
|
||||
(term (λ (y) 1)))
|
||||
(test-equal (term (subst (x y (λ (y) x))))
|
||||
(term (λ (y1) y)))
|
||||
(test-equal (term (subst (x (λ (y) y) (λ (z) (z2 z)))))
|
||||
(term (λ (z1) (z2 z1))))
|
||||
(test-equal (term (subst (x (λ (z) z) (λ (z) (z1 z)))))
|
||||
(term (λ (z2) (z1 z2))))
|
||||
(test-equal (term (subst (x z (λ (z) (z1 z)))))
|
||||
(term (λ (z2) (z1 z2))))
|
||||
(test-equal (term (subst (x3 5 (λ (x2) x2))))
|
||||
(term (λ (x1) x1)))
|
||||
(test-equal (term (subst (z * (λ (z x) 1))))
|
||||
(term (λ (z x) 1)))
|
||||
(test-equal (term (subst (q (λ (x) z) (λ (z x) q))))
|
||||
(term (λ (z1 x1) (λ (x) z))))
|
||||
(test-equal (term (subst (x 1 (λ (x x) x))))
|
||||
(term (λ (x x) x)))
|
||||
(test-results))
|
||||
|
|
@ -1,8 +1,5 @@
|
|||
(module threads mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(planet robby/redex:5/gui)
|
||||
(lib "plt-match.ss"))
|
||||
#lang scheme
|
||||
(require redex)
|
||||
|
||||
(reduction-steps-cutoff 100)
|
||||
|
||||
|
|
@ -58,34 +55,7 @@
|
|||
(in-hole tc_1 ,(substitute (term x_1) (term new-x) (term e_1))))))
|
||||
let)))
|
||||
|
||||
(define substitute
|
||||
(plt-subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(set! ,x ,e)
|
||||
(all-vars '())
|
||||
(build (lambda (vars name body) `(set! ,name ,body)))
|
||||
(subterm '() x)
|
||||
(subterm '() e)]
|
||||
[`(let ((,x ,e1)) ,e2)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars letval body) `(let ((,(car vars) ,letval)) ,body)))
|
||||
(subterm '() e1)
|
||||
(subterm (list x) e2)]
|
||||
[`(+ ,e1 ,e2)
|
||||
(all-vars '())
|
||||
(build (lambda (vars e1 e2) `(+ ,e1 ,e2)))
|
||||
(subterm '() e1)
|
||||
(subterm '() e2)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
(define (substitute . x) (error 'substitute "~s" x))
|
||||
|
||||
(define (run es) (traces threads reductions `((store) (threads ,@es))))
|
||||
(provide run)
|
||||
|
|
@ -98,7 +68,7 @@
|
|||
[`(+ ,e1 ,e2) (+ 1 (count e1) (count e2))]))
|
||||
|
||||
;; use a pretty-printer that just summaizes the terms, showing the depth of each thread.
|
||||
(traces threads reductions
|
||||
(traces reductions
|
||||
'((store (x 1))
|
||||
(threads
|
||||
(set! x (+ x -1))
|
||||
|
|
@ -114,4 +84,3 @@
|
|||
(+ 1 1)
|
||||
(+ 1 1)
|
||||
(+ 1 1)))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
(module types mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(planet robby/redex:5/gui))
|
||||
#lang scheme
|
||||
(require redex
|
||||
"subst.ss")
|
||||
|
||||
(reduction-steps-cutoff 10)
|
||||
|
||||
|
|
@ -34,9 +33,7 @@
|
|||
(r--> number num)
|
||||
|
||||
(r--> (lambda (x_1 t_1) e_body)
|
||||
(-> t_1 ,(lc-subst (term x_1)
|
||||
(term t_1)
|
||||
(term e_body))))
|
||||
(-> t_1 (subst (x_1 t_1 e_body))))
|
||||
|
||||
(r--> ((-> t_1 t_2) t_1) t_2)
|
||||
|
||||
|
|
@ -61,27 +58,12 @@
|
|||
(not (equal? (term t_2) 'num))))
|
||||
,(format "=: not comparing numbers ~s and ~s" (term t_1) (term t_2)))
|
||||
|
||||
where
|
||||
with
|
||||
|
||||
[(r--> a b) (--> (in-hole c_1 a) (in-hole c_1 b))]
|
||||
[(e--> a b) (--> (in-hole c a) b)]))
|
||||
[(--> (in-hole c_1 a) (in-hole c_1 b)) (r--> a b)]
|
||||
[(--> (in-hole c a) b) (e--> a b)]))
|
||||
|
||||
(define lc-subst
|
||||
(subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x ,t) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars) ,t) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(,f ,@(xs ...))
|
||||
(all-vars '())
|
||||
(build (lambda (vars f . xs) `(,f ,@xs)))
|
||||
(subterm '() f)
|
||||
(subterms '() xs)]))
|
||||
|
||||
(traces lang reductions
|
||||
(traces reductions
|
||||
'((lambda (x num) (lambda (y num) (if (= x y) 0 x))) 1))
|
||||
(traces lang reductions
|
||||
(traces reductions
|
||||
'((lambda (x num) (lambda (y num) (if (= x y) 0 (lambda (x num) x)))) 1))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -8,11 +8,10 @@ In the other window, you expect to see the currently unreducted terms in green a
|
|||
|
||||
|#
|
||||
|
||||
(module color-test mzscheme
|
||||
#lang scheme/gui
|
||||
|
||||
(require "../reduction-semantics.ss"
|
||||
"../gui.ss"
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss"))
|
||||
"../gui.ss")
|
||||
|
||||
(reduction-steps-cutoff 1)
|
||||
|
||||
|
|
@ -40,14 +39,14 @@ In the other window, you expect to see the currently unreducted terms in green a
|
|||
|
||||
(define-language empty-language)
|
||||
|
||||
(traces/pred empty-language
|
||||
(traces
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> (number_1 word)
|
||||
(,(+ (term number_1) 1) word)
|
||||
inc))
|
||||
(list '(1 word))
|
||||
color-range-pred))
|
||||
'(1 word)
|
||||
#:pred color-range-pred))
|
||||
|
||||
(let ()
|
||||
(define-language empty-language)
|
||||
|
|
@ -58,8 +57,7 @@ In the other window, you expect to see the currently unreducted terms in green a
|
|||
"green"
|
||||
"white")))
|
||||
|
||||
(traces/pred empty-language
|
||||
(reduction-relation
|
||||
(traces (reduction-relation
|
||||
empty-language
|
||||
(--> (number_1 word)
|
||||
(,(+ (term number_1) 1) word)
|
||||
|
|
@ -67,5 +65,5 @@ In the other window, you expect to see the currently unreducted terms in green a
|
|||
(--> (number_1 word)
|
||||
(,(* (term number_1) 2) word)
|
||||
dup))
|
||||
(list '(1 word))
|
||||
last-color-pred)))
|
||||
'(1 word)
|
||||
#:pred last-color-pred))
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
(module schemeunit-test mzscheme
|
||||
(require "../schemeunit.ss"
|
||||
(all-except "../reduction-semantics.ss" check)
|
||||
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 2)))
|
||||
|
||||
(define-language lang
|
||||
(e number (+ e e) (choose e e))
|
||||
(ec hole (+ e ec) (+ ec e))
|
||||
(v number true false))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> (in-hole ec_1 (+ number_1 number_2))
|
||||
(in-hole ec_1 ,(+ (term number_1) (term number_2))))
|
||||
(--> (in-hole ec_1 (choose e_1 e_2))
|
||||
(in-hole ec_1 e_1))
|
||||
(--> (in-hole ec_1 (choose e_1 e_2))
|
||||
(in-hole ec_1 e_2))))
|
||||
|
||||
(define tests-passed 0)
|
||||
|
||||
(define (try-it check in out key/vals)
|
||||
(let ([sp (open-output-string)])
|
||||
(parameterize ([current-output-port sp])
|
||||
(test/text-ui (test-case "X" (check reductions in out))))
|
||||
(let ([s (get-output-string sp)])
|
||||
(for-each
|
||||
(λ (key/val)
|
||||
(let* ([key (car key/val)]
|
||||
[val (cadr key/val)]
|
||||
[m (regexp-match (format "\n~a: ([^\n]*)\n" key) s)])
|
||||
(unless m
|
||||
(error 'try-it "didn't find key ~s in ~s" key s))
|
||||
(unless (if (regexp? val)
|
||||
(regexp-match val (cadr m))
|
||||
(equal? val (cadr m)))
|
||||
(error 'try-in "didn't match key ~s, expected ~s got ~s" key val (cadr m)))))
|
||||
key/vals)))
|
||||
(set! tests-passed (+ tests-passed 1)))
|
||||
|
||||
(try-it check-reduces
|
||||
'(choose 1 2)
|
||||
1
|
||||
'((multiple-results "(2 1)")))
|
||||
|
||||
(try-it check-reduces
|
||||
'(+ 1 2)
|
||||
1
|
||||
'((expected "1")
|
||||
(actual "3")))
|
||||
|
||||
(try-it check-reduces/multiple
|
||||
'(+ (choose 3 4) 1)
|
||||
'(4 6)
|
||||
'((expecteds "(4 6)")
|
||||
(actuals #rx"[(][45] [54][)]")))
|
||||
|
||||
(printf "schemeunit-tests: all ~a tests passed.\n" tests-passed))
|
||||
|
|
@ -1,125 +0,0 @@
|
|||
(module subst-test mzscheme
|
||||
(require "../subst.ss"
|
||||
(lib "match.ss"))
|
||||
|
||||
(define (lc-subst1 var val exp) (subst/proc var val exp lc-separate))
|
||||
(define (lc-free-vars exp) (free-vars/memoize (make-hash-table) exp lc-separate))
|
||||
(define (lc-rename old-name new-name exp) (alpha-rename old-name new-name exp lc-separate))
|
||||
|
||||
(define lc-subst2
|
||||
(subst
|
||||
[`(lambda ,vars ,body)
|
||||
(all-vars vars)
|
||||
(build (lambda (vars body) `(lambda ,vars ,body)))
|
||||
(subterm vars body)]
|
||||
[`(let (,l-var ,exp) ,body)
|
||||
(all-vars (list l-var))
|
||||
(build (lambda (l-vars exp body) `(let (,@l-vars ,exp) ,body)))
|
||||
(subterm '() exp)
|
||||
(subterm (list l-var) body)]
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(,fun ,@(args ...))
|
||||
(all-vars '())
|
||||
(build (lambda (vars fun . args) `(,fun ,@args)))
|
||||
(subterm '() fun)
|
||||
(subterms '() args)]))
|
||||
|
||||
(define (lc-separate exp constant variable combine sub-piece)
|
||||
(match exp
|
||||
[`(lambda ,vars ,body)
|
||||
(combine (lambda (vars body) `(lambda ,vars ,body))
|
||||
vars
|
||||
(sub-piece vars body))]
|
||||
[`(let (,l-var ,exp) ,body)
|
||||
(combine (lambda (l-vars exp body) `(let (,(car l-vars) ,exp) ,body))
|
||||
(list l-var)
|
||||
(sub-piece '() exp)
|
||||
(sub-piece (list l-var) body))]
|
||||
[(? symbol?) (variable (lambda (x) x) exp)]
|
||||
[(? number?) (constant exp)]
|
||||
[`(,fun ,@(args ...))
|
||||
(apply
|
||||
combine
|
||||
(lambda (variables fun . args) `(,fun ,@args))
|
||||
'()
|
||||
(append
|
||||
(list (sub-piece '() fun))
|
||||
(map (lambda (x) (sub-piece '() x)) args)))]))
|
||||
|
||||
(define test-cases 0)
|
||||
(define failed-tests? #f)
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test-exp expected)
|
||||
(syntax (test test-exp expected equal?))]
|
||||
[(_ test-exp expected same?)
|
||||
(syntax
|
||||
(let ([actual test-exp]
|
||||
[expected-v expected])
|
||||
;(printf "testing: ~s\n" (syntax-object->datum #'test-exp))
|
||||
(set! test-cases (+ test-cases 1))
|
||||
(unless (same? actual expected-v)
|
||||
(set! failed-tests? #t)
|
||||
(printf " test: ~s\n expected: ~s\n got: ~s\n"
|
||||
(syntax-object->datum #'test-exp)
|
||||
expected-v
|
||||
actual))))]))
|
||||
|
||||
(define (set-equal? xs ys)
|
||||
(and (andmap (lambda (x) (memq x ys)) xs)
|
||||
(andmap (lambda (y) (memq y xs)) ys)))
|
||||
|
||||
(define (lc-tests)
|
||||
(tests lc-free-vars lc-subst1 lc-rename)
|
||||
(tests #f lc-subst2 #f))
|
||||
|
||||
(define (tests free-vars subst rename)
|
||||
(when free-vars
|
||||
(test (free-vars 'x) '(x) set-equal?)
|
||||
(test (free-vars '(lambda (x) x)) '() set-equal?)
|
||||
(test (free-vars '(lambda (x) y)) '(y) set-equal?)
|
||||
(test (free-vars '(let (x 1) x)) '() set-equal?)
|
||||
(test (free-vars '(let (x 1) y)) '(y) set-equal?)
|
||||
(test (free-vars '(let (x x) y)) '(y x) set-equal?)
|
||||
(test (free-vars '(let (x 1) (y y))) '(y) set-equal?)
|
||||
(test (free-vars '(lambda (y) (y y))) '() set-equal?))
|
||||
|
||||
(when rename
|
||||
(test (rename 'x 'y 'x) 'x)
|
||||
(test (rename 'x 'y '(lambda (x) x)) '(lambda (y) y)))
|
||||
|
||||
(test (subst 'x 1 'x) 1)
|
||||
(test (subst 'x 1 'y) 'y)
|
||||
(test (subst 'x 1 '(lambda (x) x)) '(lambda (x) x))
|
||||
(test (subst 'x 1 '(lambda (y) x)) '(lambda (y) 1))
|
||||
(test (subst 'x 'y '(lambda (y) x)) '(lambda (y@) y))
|
||||
(test (subst 'x 'y '(lambda (y) (x y))) '(lambda (y@) (y y@)))
|
||||
(test (subst 'x 'y '(let (x 1) 1)) '(let (x 1) 1))
|
||||
(test (subst 'x 'y '(let (x 1) x)) '(let (x 1) x))
|
||||
(test (subst 'x 'y '(let (x 1) y)) '(let (x 1) y))
|
||||
(test (subst 'x 'y '(let (y 1) (x y))) '(let (y@ 1) (y y@)))
|
||||
(test (subst 'q '(lambda (x) y) '(lambda (y) y)) '(lambda (y) y))
|
||||
(test (subst 'q '(lambda (x) y) '(let ([y q]) y)) '(let ([y (lambda (x) y)]) y))
|
||||
(test (subst 'p '1 '(let (t 2) ((p t) t)))
|
||||
'(let (t 2) ((1 t) t)))
|
||||
(test (subst 'p '(lambda (s) s)
|
||||
'(let (t (lambda (s) s)) ((p t) t)))
|
||||
'(let (t (lambda (s) s)) (((lambda (s) s) t) t)))
|
||||
(test (subst 'p
|
||||
'(lambda (s) (s s))
|
||||
'(let (t (lambda (s) s))
|
||||
p))
|
||||
'(let (t (lambda (s) s))
|
||||
(lambda (s) (s s))))
|
||||
|
||||
(test (subst 's
|
||||
'(lambda (z) (s z))
|
||||
'(lambda (s) (lambda (z) (s z))))
|
||||
'(lambda (s) (lambda (z) (s z))))
|
||||
|
||||
(test (subst 's
|
||||
'(lambda (s) (lambda (z) (s z)))
|
||||
'(lambda (z) (s z)))
|
||||
'(lambda (z) ((lambda (s) (lambda (z) (s z))) z)))))
|
||||
Loading…
Reference in New Issue
Block a user