732 lines
20 KiB
Racket
732 lines
20 KiB
Racket
#lang scheme
|
|
|
|
(require redex/reduction-semantics
|
|
"reduction.ss")
|
|
|
|
;
|
|
;
|
|
; ;;; ;;; ;;; ;
|
|
; ;; ;; ; ; ;
|
|
; ;; ;; ;;; ;;;;; ;;; ;;;;; ;; ;; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;
|
|
; ; ; ; ;;;;; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ;;; ;;;; ;;; ;;;;; ;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
;; heap-ref
|
|
(test-equal (term (heap-ref (box y) ((w 0) (x 1) (y 2) (z 3)))) 2)
|
|
|
|
;; heap-set
|
|
(test-equal (term (heap-set 7 (box y) ((w 0) (x 1) (y 2) (z 3))))
|
|
(term ((w 0) (x 1) (y 7) (z 3))))
|
|
|
|
;; push
|
|
(test-equal (term (push (1 2 3) (4 5 ε)))
|
|
(term (1 2 3 4 5 ε)))
|
|
|
|
;; push-uninit
|
|
(test-equal (term (push-uninit 2 (1 2 (3 uninit 4 ε))))
|
|
(term (uninit uninit 1 2 (3 uninit 4 ε))))
|
|
|
|
;; stack-ref
|
|
(test-equal (term (stack-ref 1 (1 2 3 (ε)))) 2)
|
|
(test-equal (term (stack-ref 3 (1 2 (3 4 (ε))))) 4)
|
|
|
|
;; stack-set
|
|
(test-equal (term (stack-set 2 1 (1 uninit uninit 4 ε)))
|
|
(term (1 2 uninit 4 ε)))
|
|
(test-equal (term (stack-set 4 3 (1 2 (3 uninit 5 ε))))
|
|
(term (1 2 (3 4 5 ε))))
|
|
|
|
;; load
|
|
|
|
(define-syntax test-load
|
|
(syntax-rules ()
|
|
[(_ e (e* h t))
|
|
(test-predicate
|
|
(redex-match runtime (uninit (((ε))) h t (e*)))
|
|
(term (load e ())))]))
|
|
|
|
(test-load
|
|
(proc-const (val ref) 'body)
|
|
((clos x_1) ((x_1 ((clos 2 () x_2)))) ((x_2 'body))))
|
|
|
|
(test-load
|
|
(application
|
|
(proc-const (val ref) 'body1)
|
|
(proc-const (val) 'body2))
|
|
((application (clos x_1) (clos x_2))
|
|
((x_1 ((clos 2 () x_3)))
|
|
(x_2 ((clos 1 () x_4))))
|
|
((x_3 'body1) (x_4 'body2))))
|
|
|
|
(test-load
|
|
(seq
|
|
(proc-const (val ref) 'body1)
|
|
(proc-const (val) 'body2))
|
|
((seq (clos x_1) (clos x_2))
|
|
((x_1 ((clos 2 () x_3)))
|
|
(x_2 ((clos 1 () x_4))))
|
|
((x_3 'body1) (x_4 'body2))))
|
|
|
|
(test-load
|
|
(let-rec ((lam () (1) 'body1)
|
|
(lam (val) (0) 'body2))
|
|
(lam (val val) (0) 'body3))
|
|
((let-rec ((lam 0 (1) x_1)
|
|
(lam 1 (0) x_2))
|
|
(lam 2 (0) x_3))
|
|
()
|
|
((x_3 'body3) (x_1 'body1) (x_2 'body2))))
|
|
|
|
(test-load
|
|
(let-one
|
|
(proc-const (val ref) 'body1)
|
|
(proc-const (val) 'body2))
|
|
((let-one (clos x_1) (clos x_2))
|
|
((x_1 ((clos 2 () x_3)))
|
|
(x_2 ((clos 1 () x_4))))
|
|
((x_3 'body1) (x_4 'body2))))
|
|
|
|
(test-load
|
|
(let-void 0 (proc-const (val ref) 'body))
|
|
((let-void 0 (clos x_1))
|
|
((x_1 ((clos 2 () x_2))))
|
|
((x_2 'body))))
|
|
|
|
(test-load
|
|
(boxenv 0 (proc-const (val ref) 'body))
|
|
((boxenv 0 (clos x_1))
|
|
((x_1 ((clos 2 () x_2))))
|
|
((x_2 'body))))
|
|
|
|
(test-load
|
|
(install-value 0
|
|
(proc-const (val ref) 'body1)
|
|
(proc-const (val) 'body2))
|
|
((install-value 0 (clos x_1) (clos x_2))
|
|
((x_1 ((clos 2 () x_3)))
|
|
(x_2 ((clos 1 () x_4))))
|
|
((x_3 'body1) (x_4 'body2))))
|
|
|
|
(test-load
|
|
(branch
|
|
(proc-const (val ref) 'body1)
|
|
(proc-const (val) 'body2)
|
|
(proc-const () 'body3))
|
|
((branch (clos x_1) (clos x_2) (clos x_3))
|
|
((x_1 ((clos 2 () x_4)))
|
|
(x_2 ((clos 1 () x_5)))
|
|
(x_3 ((clos 0 () x_6))))
|
|
((x_4 'body1) (x_5 'body2) (x_6 'body3))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (application (loc-noclr 0)))) 'x))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'x))
|
|
()
|
|
((x_1 (self-app x_1 (loc-noclr 0))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam (val) (0) (application (loc-noclr 1) 'x))) 'y))
|
|
((let-void 1 (let-rec ((lam 1 (0) x_1)) 'y))
|
|
()
|
|
((x_1 (self-app x_1 (loc-noclr 1) 'x)))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (application (loc-noclr 0) 'x))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'y))
|
|
()
|
|
((x_1 (application (loc-noclr 0) 'x)))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (boxenv 0 (application (loc-box-noclr 0))))) 'x))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'x))
|
|
()
|
|
((x_1 (boxenv 0 (application (loc-box-noclr 0)))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam (val) (0) (application (loc-noclr 0)))) 'x))
|
|
((let-void 1 (let-rec ((lam 1 (0) x_1)) 'x))
|
|
()
|
|
((x_1 (application (loc-noclr 0))))))
|
|
|
|
(test-load
|
|
(let-one 'x (let-void 1 (let-rec ((lam () (1 0) (application (loc-noclr 1)))) 42)))
|
|
((let-one 'x (let-void 1 (let-rec ((lam 0 (1 0) x_1)) 42)))
|
|
()
|
|
((x_1 (self-app x_1 (loc-noclr 1))))))
|
|
|
|
(test-load
|
|
(let-one 'x (let-void 1 (let-rec ((lam () (1) (application (loc-noclr 0)))) 42)))
|
|
((let-one 'x (let-void 1 (let-rec ((lam 0 (1) x_1)) 42)))
|
|
()
|
|
((x_1 (application (loc-noclr 0))))))
|
|
|
|
(test-load
|
|
(let-one 'x (let-void 1 (let-rec ((lam () (1) (application (loc-noclr 0)))) 42)))
|
|
((let-one 'x (let-void 1 (let-rec ((lam 0 (1) x_1)) 42)))
|
|
()
|
|
((x_1 (application (loc-noclr 0))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (lam () (0) (application (loc-noclr 0))))) 'x))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'x))
|
|
()
|
|
((x_1 (lam 0 (0) x_2))
|
|
(x_2 (application (loc-noclr 0))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0 0) (application (loc-noclr 0)))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0 0) x_1)) 'y))
|
|
()
|
|
((x_1 (application (loc-noclr 0))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0 0) (application (loc-noclr 1)))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0 0) x_1)) 'y))
|
|
()
|
|
((x_1 (self-app x_1 (loc-noclr 1))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (let-one 'x (boxenv 0 (application (loc-noclr 1)))))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'y))
|
|
()
|
|
((x_1 (let-one 'x (boxenv 0 (self-app x_1 (loc-noclr 1))))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (let-one (application (loc-noclr 1)) 'x))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'y))
|
|
()
|
|
((x_1 (let-one (application (loc-noclr 1)) 'x)))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (application (application (loc-noclr 0))))) 'x))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'x))
|
|
()
|
|
((x_1 (application (application (loc-noclr 0)))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (let-rec () (application (loc-noclr 0))))) 'x))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'x))
|
|
()
|
|
((x_1 (let-rec () (self-app x_1 (loc-noclr 0)))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (let-void 1 (install-value 1 'x (application (loc-noclr 1)))))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'y))
|
|
()
|
|
((x_1 (let-void 1 (install-value 1 'x (self-app x_1 (loc-noclr 1))))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (let-void 1 (install-value 1 (application (loc-noclr 1)) 'x)))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'y))
|
|
()
|
|
((x_1 (let-void 1 (install-value 1 (application (loc-noclr 1)) 'x))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (seq 'x (application (loc-noclr 0))))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'y))
|
|
()
|
|
((x_1 (seq 'x (self-app x_1 (loc-noclr 0)))))))
|
|
|
|
(test-load
|
|
(let-void 1 (let-rec ((lam () (0) (seq (application (loc-noclr 0)) 'x))) 'y))
|
|
((let-void 1 (let-rec ((lam 0 (0) x_1)) 'y))
|
|
()
|
|
((x_1 (seq (application (loc-noclr 0)) 'x)))))
|
|
|
|
(test-load
|
|
(case-lam (lam (val) () (lam (val) (0) 'x)) (lam (val val) () 'y))
|
|
((case-lam (lam 1 () x_1) (lam 2 () x_3))
|
|
()
|
|
((x_1 (lam 1 (0) x_2)) (x_2 'x) (x_3 'y))))
|
|
|
|
;
|
|
;
|
|
; ;;;;; ;; ;
|
|
; ; ; ; ;
|
|
; ; ; ;;; ;; ; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;;
|
|
; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ;
|
|
; ;;;; ;;;;; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ;;;; ;;;;; ;; ;; ;;; ;;; ;;;;; ;;; ;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
(define step (compose car (curry apply-reduction-relation ->)))
|
|
|
|
;; application
|
|
(test-->
|
|
->
|
|
(term (uninit (((ε))) () () ((application 1 2 3))))
|
|
(term (uninit (uninit uninit ((ε))) () () ((reorder (call 2) (1 ?) (2 0) (3 1))))))
|
|
|
|
;; self-app
|
|
(test-->
|
|
->
|
|
(term
|
|
((clos x)
|
|
('a ((clos x) ('b ε)))
|
|
((x ((clos 0 ((clos x)) x1))))
|
|
((x1 (self-app x1 (loc-noclr 1) 'c)))
|
|
((self-app x1 (loc-noclr 1) 'c))))
|
|
(term
|
|
((clos x)
|
|
('a ((clos x) ('b ε)))
|
|
((x ((clos 0 ((clos x)) x1))))
|
|
((x1 (self-app x1 (loc-noclr 1) 'c)))
|
|
((application (loc-noclr 1) 'c))))
|
|
(term
|
|
((clos x)
|
|
(uninit 'a ((clos x) ('b ε)))
|
|
((x ((clos 0 ((clos x)) x1))))
|
|
((x1 (self-app x1 (loc-noclr 1) 'c)))
|
|
((reorder (self-call x1) ('c 0))))))
|
|
|
|
;; reorder
|
|
(test-->
|
|
->
|
|
(term (uninit (((ε))) () () ((reorder (call 1) ('x 0) ((loc-noclr 0) ?)))))
|
|
(term (uninit (((ε))) () () (framepush 'x framepop (set 0)
|
|
framepush (loc-noclr 0) framepop
|
|
(call 1)))))
|
|
(test-->
|
|
->
|
|
(term (uninit (((ε))) () () ((reorder (call 1) ((loc-noclr 0) ?) ('x 0)))))
|
|
(term (uninit (((ε))) () () ((reorder (call 1) ('x 0) ((loc-noclr 0) ?)))))
|
|
(term (uninit (((ε))) () () (framepush (loc-noclr 0) framepop (set 0)
|
|
framepush 'x framepop
|
|
(swap 0) (call 1)))))
|
|
|
|
(test-->
|
|
->
|
|
(term (uninit (((ε))) () ((x 'q)) ((reorder (self-call x) ('x 0) ((loc-noclr 0) 1)))))
|
|
(term (uninit (((ε))) () ((x 'q)) (framepush 'x framepop (set 0)
|
|
framepush (loc-noclr 0) framepop (set 1)
|
|
(self-call x)))))
|
|
(test-->
|
|
->
|
|
(term (uninit (((ε))) () ((x 'q)) ((reorder (self-call x) ((loc-noclr 0) 1) ('x 0)))))
|
|
(term (uninit (((ε))) () ((x 'q)) ((reorder (self-call x) ('x 0) ((loc-noclr 0) 1)))))
|
|
(term (uninit (((ε))) () ((x 'q)) (framepush (loc-noclr 0) framepop (set 1)
|
|
framepush 'x framepop (set 0)
|
|
(self-call x)))))
|
|
|
|
(test-equal
|
|
(sort
|
|
(map
|
|
car
|
|
(apply-reduction-relation/tag-with-names
|
|
->
|
|
(term
|
|
(uninit
|
|
(uninit uninit 'a 'b 'c ε)
|
|
()
|
|
()
|
|
((reorder (call 2) ((loc-noclr 0) ?) ((loc-noclr 1) 0) ((loc-noclr 2) 1)))))))
|
|
string<=?)
|
|
'("finalize-app-not-last" "reorder" "reorder"))
|
|
|
|
;; swap
|
|
(test-->
|
|
->
|
|
(term ('z ('a 'b 'c ε) () () ((swap 1))))
|
|
(term ('b ('a 'z 'c ε) () () ())))
|
|
|
|
;; call
|
|
(test-->
|
|
->
|
|
(term ((clos x1) ('x 'y 'z ('q ('r ε))) ((x1 ((clos 2 ('w) x2)))) ((x2 'z)) ((call 2))))
|
|
(term ((clos x1) (('w ('x 'y ε))) ((x1 ((clos 2 ('w) x2)))) ((x2 'z)) ('z))))
|
|
|
|
(test-->
|
|
->
|
|
(term ((clos x1)
|
|
('x 'y 'z ('q ('r ε)))
|
|
((x1 ((clos 1 () x2) (clos 2 ('w) x3) (clos 2 ('w) x4))))
|
|
((x2 'a) (x3 'b) (x4 'c))
|
|
((call 2))))
|
|
(term ((clos x1)
|
|
(('w ('x 'y ε)))
|
|
((x1 ((clos 1 () x2) (clos 2 ('w) x3) (clos 2 ('w) x4))))
|
|
((x2 'a) (x3 'b) (x4 'c))
|
|
('b))))
|
|
|
|
(test-equal
|
|
(caar
|
|
(apply-reduction-relation*
|
|
->
|
|
(term (load (application (lam (val) () (loc-noclr 0)) (application (lam (val) () (loc-noclr 0)) 'x)) ()))))
|
|
''x)
|
|
|
|
;; self-call
|
|
(test-->
|
|
->
|
|
(term
|
|
('c
|
|
('d 'b ((clos x) ('c ε)))
|
|
((x ((clos 0 ((clos x)) x1))))
|
|
((x1 (self-app x1 (loc-noclr 1) 'c)))
|
|
((self-call x1))))
|
|
(term
|
|
('c
|
|
(((clos x) ('d ε)))
|
|
((x ((clos 0 ((clos x)) x1))))
|
|
((x1 (self-app x1 (loc-noclr 1) 'c)))
|
|
((self-app x1 (loc-noclr 1) 'c)))))
|
|
|
|
(test-equal
|
|
(map
|
|
car
|
|
(apply-reduction-relation*
|
|
->
|
|
(term (load (let-void 1 (let-rec ((lam (val val) (0)
|
|
(branch (loc-noclr 1)
|
|
(loc-noclr 2)
|
|
(application (loc-noclr 2) #t (loc-noclr 3)))))
|
|
(application (loc-noclr 2) #f #t))) ()))))
|
|
'(#f))
|
|
|
|
;; arity
|
|
(test-equal
|
|
(step (term ((clos x1) ('y 'q ε) ((x1 ((clos 2 ('w) x2)))) ((x2 'z)) ((call 1)))))
|
|
(term error))
|
|
|
|
(test-->>
|
|
->
|
|
(term (uninit (((ε))) () ((x 'x)) ((let-one 7 (boxenv 0 (application (lam 0 (1) x) 'y))))))
|
|
(term error))
|
|
|
|
(test-->
|
|
->
|
|
(term
|
|
((clos x170017)
|
|
(19 ((ε)))
|
|
((x170017
|
|
((clos 4 () x170018)))
|
|
(x170015
|
|
((clos 9 () x170016))))
|
|
((x170018 (clos x170015))
|
|
(x170016 void))
|
|
((call 1))))
|
|
(term error))
|
|
|
|
;; non-closure
|
|
(test-equal
|
|
(step (term ('f ('x 'y 'q ε) () () ((call 2)))))
|
|
(term error))
|
|
|
|
;; localref
|
|
(test-->
|
|
->
|
|
(term (uninit (1 ε) () () ((loc 0))))
|
|
(term (1 (1 ε) () () ())))
|
|
|
|
;; loc-box
|
|
(test-->
|
|
->
|
|
(term (uninit ((box x) ε) ((x 1)) () ((loc-box 0))))
|
|
(term (1 ((box x) ε) ((x 1)) () ())))
|
|
|
|
;; loc-clr
|
|
(test-equal
|
|
(step (term (uninit (1 ε) () () ((loc-clr 0)))))
|
|
(term (1 (uninit ε) () () ())))
|
|
|
|
;; loc-box-clr
|
|
(test-equal
|
|
(step (term (uninit ((box x) ε) ((x 1)) () ((loc-box-clr 0)))))
|
|
(term (1 (uninit ε) ((x 1)) () ())))
|
|
|
|
;; value
|
|
(test-equal
|
|
(step (term (uninit (((ε))) () () (3))))
|
|
(term (3 (((ε))) () () ())))
|
|
|
|
;; close-lam
|
|
(test-equal
|
|
(step (term (uninit ('x 'y ('z ε)) () ((x 'q)) ((lam 3 (0 2) x)))))
|
|
(term ((clos x1) ('x 'y ('z ε)) ((x1 ((clos 3 ('x 'z) x)))) ((x 'q)) ())))
|
|
|
|
;; close-case-lam
|
|
(test-equal
|
|
(step (term (uninit ('x 'y ('z ε)) ((x1 'a)) ((x2 'b) (x3 'c)) ((case-lam (lam 3 (0 2) x2) (lam 2 (1 0) x3))))))
|
|
(term ((clos x4) ('x 'y ('z ε)) ((x4 ((clos 3 ('x 'z) x2) (clos 2 ('y 'x) x3))) (x1 'a)) ((x2 'b) (x3 'c)) ())))
|
|
|
|
;; let-one
|
|
(test-equal
|
|
(step (term (uninit ('x ε) () () ((let-one 'y 'z)))))
|
|
(term (uninit (uninit 'x ε) () () (framepush 'y framepop (set 0) 'z))))
|
|
|
|
;; framepop
|
|
(test-equal
|
|
(step (term (uninit ('u ('w ('x 'y ('z ε)))) () () (framepop))))
|
|
(term (uninit ('z ε) () () ())))
|
|
|
|
;; framepush
|
|
(test-equal
|
|
(step (term (7 ('x uninit ('y ε)) () () (framepush))))
|
|
(term (7 (((('x uninit ('y ε))))) () () ())))
|
|
|
|
;; set
|
|
(test-equal
|
|
(step (term ('z ('x ('y ε)) () () ((set 1)))))
|
|
(term ('z ('x ('z ε)) () () ())))
|
|
|
|
;; set-box
|
|
(test-equal
|
|
(step (term ('x ((box y) ε) ((y 'z)) () ((set-box 0)))))
|
|
(term ('x ((box y) ε) ((y 'x)) () ())))
|
|
|
|
;; boxenv
|
|
(test-equal
|
|
(step (term (uninit (9 ε) ((y 8)) () ((boxenv 0 'z)))))
|
|
(term (uninit ((box x) ε) ((x 9) (y 8)) () ('z))))
|
|
|
|
;; let-void
|
|
(test-equal
|
|
(step (term (uninit ('x 'y ε) () () ((let-void 3 'z)))))
|
|
(term (uninit (uninit uninit uninit 'x 'y ε) () () ('z))))
|
|
|
|
;; let-void-box
|
|
(test-predicate
|
|
(redex-match
|
|
runtime
|
|
(uninit
|
|
((box variable_1) (box variable_2) (box x) ε)
|
|
((variable_1 undefined) (variable_2 undefined) (x 'y))
|
|
()
|
|
('z)))
|
|
(step (term (uninit ((box x) ε) ((x 'y)) () ((let-void-box 2 'z))))))
|
|
|
|
;; install-value
|
|
(test-->
|
|
->
|
|
(term (uninit (uninit ε) () () ((install-value 0 'r 'b) 'q)))
|
|
(term (uninit (uninit ε) () () (framepush 'r framepop (set 0) 'b 'q))))
|
|
(test-->
|
|
->
|
|
(term (uninit (uninit ε) () () ((install-value-box 0 'r 'b) 'q)))
|
|
(term (uninit (uninit ε) () () (framepush 'r framepop (set-box 0) 'b 'q))))
|
|
|
|
;; seq-many
|
|
(test-equal
|
|
(step (term (uninit (((ε))) () () ((seq 'x 'y 'z) 'w))))
|
|
(term (uninit (((ε))) () () (framepush 'x framepop (seq 'y 'z) 'w))))
|
|
|
|
;; seq-one
|
|
(test-equal
|
|
(step (term (uninit ((((ε)))) () () ((seq 'x 'y) 'z))))
|
|
(term (uninit ((((ε)))) () () (framepush 'x framepop 'y 'z))))
|
|
|
|
;; branch
|
|
(let ([test-branch (λ (cond res)
|
|
(test-->>
|
|
->
|
|
`(uninit
|
|
('t 'f ε)
|
|
()
|
|
()
|
|
((branch (let-one 'q ,cond)
|
|
(loc 0)
|
|
(loc 1))))
|
|
`(',res ('t 'f ε) () () ())))])
|
|
(test-branch ''not-false 't)
|
|
(test-branch #f 'f))
|
|
|
|
;; let-rec
|
|
(test-->
|
|
->
|
|
(term
|
|
('x
|
|
(uninit uninit (box x1) ε)
|
|
((x1 'x))
|
|
((x2 'f) (x3 'g))
|
|
((let-rec
|
|
((lam 1 (1 2) x2)
|
|
(lam 1 (0 2) x3))
|
|
(loc-noclr 0)))))
|
|
(term
|
|
('x
|
|
((clos x4) (clos x5) (box x1) ε)
|
|
((x1 'x)
|
|
(x4 ((clos 1 ((clos x5) (box x1)) x2)))
|
|
(x5 ((clos 1 ((clos x4) (box x1)) x3))))
|
|
((x2 'f) (x3 'g))
|
|
((loc-noclr 0)))))
|
|
|
|
(test-->
|
|
->
|
|
(term
|
|
(uninit
|
|
(uninit ((ε)))
|
|
((x1 ((clos 0 () x2))))
|
|
((x2 'x) (x3 'y))
|
|
((let-rec ((lam 0 (0) x3)) 'z))))
|
|
(term
|
|
(uninit
|
|
((clos x4) ((ε)))
|
|
((x1 ((clos 0 () x2))) (x4 ((clos 0 ((clos x4)) x3))))
|
|
((x2 'x) (x3 'y))
|
|
('z))))
|
|
|
|
(test-->>
|
|
->
|
|
#:cycles-ok
|
|
(term
|
|
(uninit
|
|
(((ε)))
|
|
()
|
|
((x1 (application (loc-noclr 0)))
|
|
(x2 (application (loc-noclr 0))))
|
|
((let-void
|
|
2
|
|
(let-rec ((lam 0 (1) x1)
|
|
(lam 0 (0) x2))
|
|
(application (loc-noclr 1))))))))
|
|
|
|
;; indirect
|
|
(test-->>
|
|
->
|
|
#:cycles-ok
|
|
(term
|
|
(uninit
|
|
(((ε)))
|
|
((x1 ((clos 0 () x2))))
|
|
((x2 (application (indirect x3)))
|
|
(x3 (clos x1)))
|
|
((application (indirect x3))))))
|
|
|
|
;; loops
|
|
(test-->>
|
|
->
|
|
#:cycles-ok
|
|
(term
|
|
(uninit
|
|
(((ε)))
|
|
()
|
|
((x1 (application
|
|
(loc-noclr 1)
|
|
(loc-noclr 1)))
|
|
(x2 (let-one
|
|
7
|
|
(application
|
|
(let-one 8 (loc-noclr 3))
|
|
(let-one 9 (loc-noclr 3))))))
|
|
((application (lam 1 () x1) (lam 1 () x2))))))
|
|
|
|
(test-->>
|
|
->
|
|
#:cycles-ok
|
|
(term (load (let-one (indirect x57042) (application (loc-noclr 1) (loc-noclr 1)))
|
|
((x57042 (proc-const (val) (application (loc-noclr 1) (loc-noclr 1))))))))
|
|
|
|
(test-->>
|
|
->
|
|
#:cycles-ok
|
|
(term (load (let-void 1 (let-rec ((lam () (0) (application (loc-noclr 0)))) (application (loc-noclr 0)))) ())))
|
|
|
|
; mutable variables
|
|
(test-->>
|
|
->
|
|
`(uninit (((ε))) ()
|
|
()
|
|
((let-void
|
|
1
|
|
(install-value 0 777 (boxenv 0 (install-value-box 0 888 (loc-box-noclr 0)))))))
|
|
(term (888 ((box x) ((ε))) ((x 888)) () ())))
|
|
|
|
(test-->>
|
|
->
|
|
`(uninit (((ε))) () ()
|
|
((let-one
|
|
(let-void
|
|
1
|
|
(install-value
|
|
0
|
|
'foo
|
|
(boxenv
|
|
0
|
|
(let-one
|
|
(install-value-box 1 7 void)
|
|
(seq (loc-clr 0) (let-one (loc-box-noclr 2) (loc-noclr 0)))))))
|
|
(loc-noclr 0))))
|
|
(term (7 (7 ((ε))) ((x 7)) () ())))
|
|
|
|
;; locals pushed for seq sub-exprs should be popped
|
|
(test-->>
|
|
->
|
|
(term (uninit (((ε))) () () ((seq (let-one 1 (loc 0)) (let-one 2 (loc 0)) 3))))
|
|
(term (3 (((ε))) () () ())))
|
|
|
|
; closure-captured value is above explicit arguments
|
|
(test-equal
|
|
(caar
|
|
(apply-reduction-relation*
|
|
->
|
|
(term (load (application
|
|
(let-void
|
|
1
|
|
(install-value
|
|
0
|
|
777
|
|
(boxenv
|
|
0
|
|
(lam
|
|
(val val val)
|
|
(0)
|
|
(install-value-box 0 (loc-noclr 3) (loc-box-noclr 0))))))
|
|
111
|
|
222
|
|
333)
|
|
()))))
|
|
333)
|
|
|
|
;; ref arg
|
|
(test-->>
|
|
->
|
|
#:cycles-ok
|
|
(term (uninit (((ε))) () ((x1 (loc-box-noclr 0))) ((let-one 'x (boxenv 0 (application (lam 1 () x1) (loc-noclr 1)))))))
|
|
(term ('x ((((box x2) ε))) ((x3 ((clos 1 () x1))) (x2 'x)) ((x1 (loc-box-noclr 0))) ())))
|
|
|
|
;; case-lam
|
|
(test-equal
|
|
(map
|
|
car
|
|
(apply-reduction-relation*
|
|
->
|
|
(term
|
|
(load (application
|
|
(let-one 'a
|
|
(let-one 'b
|
|
(let-one 'c
|
|
(case-lam (lam () (2) (loc-noclr 0))
|
|
(lam (val) (1) (loc-noclr 0))
|
|
(lam (val) (0) (loc-noclr 0))))))
|
|
'x)
|
|
()))))
|
|
'('b))
|
|
|
|
(test-equal
|
|
(apply-reduction-relation*
|
|
->
|
|
(term (load (application (case-lam (lam (val) () 1) (lam (val val) () 2))) ())))
|
|
'(error))
|
|
|
|
(test-equal
|
|
(apply-reduction-relation*
|
|
->
|
|
(term (load (application (case-lam)) ())))
|
|
'(error))
|
|
|
|
(test-results)
|