CPS

对[CPS]变换的再次尝试，使用栈的方法去变换

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104

(define name -1)
(define get-name
	(lambda ()
		(set! name (+ name 1))
		(string->symbol
			(string-append "val" 
				(number->string name)))))
(define deep
	(lambda (tree)
		(if (not (pair? tree))
			0
			(+ 1 (deep-forest (cdr tree))))))
(define accumulate
	(lambda (pro lst)
		(if (= (length lst) 1)
			(pro (car lst))
			(pro (car lst) (accumulate pro (cdr lst))))))
			
(define deep-forest
	(lambda (trees)
		(accumulate max
			(map deep trees))))

(define change
	(lambda (tree)
		(if (= 1 (deep tree))
			(let ((name (get-name)))
				(list tree name name))
			(let ((fro (change-forest (cdr tree))))
				(let ((t (car fro))
					(name (cadr fro))
					(rands (caddr fro)))
					(list t name (cons (car tree) rands)))))))
(define change-forest
	(lambda (trees)
		(let ((pos (find-position (map deep trees))))
			(let ((left-trees (get-left-trees trees pos))
				(tree (get-tree trees pos))
				(right-trees (get-right-trees trees pos)))
				(let ((ch (change tree)))
					(let ((old-tree (car ch))
						(name (cadr ch))
						(new-tree (caddr ch)))
						(list old-tree name 
							(append left-trees 
								(list new-tree)
								right-trees)))))))) 

(define get-tree
	(lambda (trees pos)
		(if (= (car pos) 0)
			(car trees)
			(get-tree (cdr trees) (cdr pos)))))
(define get-left-trees
	(lambda (trees pos)
		(if (= (car pos) 0)
			(list)
			(cons (car trees)
				(get-left-trees (cdr trees) (cdr pos))))))
(define get-right-trees
	(lambda (trees pos)
		(if (= (car pos) 0)
			(cdr trees)
			(get-right-trees (cdr trees) (cdr pos)))))
(define helper
	(lambda (lst max)
		(if (null? lst)
			(lst)
			(if (= max (car lst))
				(cons max (map (lambda (n) (- n 1)) (cdr lst)))
				(cons (car lst) (helper (cdr lst) max))))))
(define find-position
	(lambda (lst)
		(let ((ma (accumulate max lst))) 
			(map (lambda (n) (- n ma))
				 (helper lst ma)))))
(define CPS-helper
	(lambda (exp en-exp)	
		(let ((ope (car exp))
			(rands (cdr exp)))
			(let ((cps-ope (translate->CPS-name ope)))
				(append (cons cps-ope rands) 
					(list en-exp))))))

(define translate->CPS-name
	(lambda (sy)
		(string->symbol
			(string-append "cps&"
				(symbol->string sy)))))
(define CPS
	(lambda (exp)
		(if (not (pair? exp))
			exp
			(if (equal? (car exp) 'lambda)
				(list 'lambda (cadr exp)
					(CPS (caddr exp)))
			(let ((ch (change exp)))
				(let ((ch-tree (car ch))
					(name (cadr ch))
					(new-tree (caddr ch)))
					(CPS-helper ch-tree
						(list 'lambda (list name)

实例

1
2
3
4
5
6
7
>(CPS '(lambda (x y) (+ x (+ x y))))
<'(lambda (x y)
   (cps&+
    x
    y
    (lambda (val30)
      (cps&+ x val30 (lambda (val31) val31)))))

##CPS2

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
(define name 0)

(define get-name
	 (lambda ()
		(let ((na (string->symbol (string-append "val" (number->string name)))))
			(set! name (+ name 1))
			na)))
(define get-next-exp ;return (next-exp (var new-exp))
	(lambda (exp)
		(define helper
			(lambda (exp)
				(if (null? exp) #f
					(if (pair? (car exp)) 0
						(+ 1 (helper (cdr exp)))))))
		(let ((index (helper exp))
			(vec (list->vector exp))
			(name (get-name)))
			(if index (list (vector-ref vec index) 	;-----------------------------add index
						(begin (vector-set! vec index name)
							(list 'lambda (list name) (vector->list vec))));------------------lambda 
					(display "get-next-exp error!")))))
(define lambda?
	(lambda (exp)
		(equal? 'lambda (car exp))))
(define name->CPS-name
	(lambda (name)
			(string->symbol
				(string-append "cps&"
					(symbol->string name)))))
(define small-exp?	
	(lambda (exp)
		(= 1 (deep exp))))
(define deep
	(lambda (tree)
		(if (not (pair? tree))
			0
			(if (lambda? tree)
				(+ 1 (deep (caddr tree)))
				(+ 1 (deep-forest (cdr tree)))))))
(define deep-forest
	(lambda (trees)
		(accumulate max
			(map deep trees))))

(define accumulate
	(lambda (pro lst)
		(if (= (length lst) 1)
			(pro (car lst))
			(pro (car lst) (accumulate pro (cdr lst))))))

(define easy-if?
	(lambda (exp)
		(and (equal? (car exp) 'if)
			(not (pair? (cadr exp))))))

;-------------------------------------------------------------------------------
(define cps
	(lambda (exp)
		(define inner
			(lambda (exp exps)
				(cond ((not (pair? exp))
						(if (null? exps)
							(list 'cont exp)
							(list (inner (car exps) (cdr exps))
								exp)))
					((lambda? exp)
						(list 'lambda (cadr exp)
							(inner (caddr exp) exps)))
					((easy-if? exp)
						(list 'if (cadr exp)
							(inner (caddr exp) exps)
							(inner (cadddr exp) exps)))
					((and (small-exp? exp)
						(null? exps))
						(if (pair? (car exp))
							(cons (inner (car exp) (list))
								(cdr exp))
							(cons (name->CPS-name (car exp))
								(append (cdr exp) (list 'cont)))))
					((small-exp? exp)
						(if (pair? (car exp))
							(cons (list 'lambda (cadr (car exp))
									(inner (caddr (car exp)) exps))
								(cdr exp)) 
							(cons (name->CPS-name (car exp))
								(append (cdr exp) (list (inner (car exps) (cdr exps))))))) 
					(else 
						(let ((n (get-next-exp exp)))
							(let ((next-exp (car n))
								(var&new-exp (cadr n)))
								(inner next-exp (cons var&new-exp exps))))))))
	(list 'lambda (list 'cont)
		(inner exp (list)))))
;have some error
;(cps '((lambda (x) x) 1))
;(cps '(f (lambda (x) x) 1))

ps:可通过首页的邮件和我交流，标明文章名即可