介绍

在[lambda curicuit]里，它只有一种最小的单元“函数”。使用函数构建自然数和各种各样的数据类型，还有构造器“cons”,
在看到丘奇数和if以及cons的lambda表示的时候，我产生了一个关于解释器的想法，那就是否可以写一个最小的解释器，用于解释[lambda演算],之后在它的前后加上翻译器，将输入输出翻译成相应的形式，
从而拥有普通解释器一样的效果。

最小内核 value-of

这里是一个最小的内核，它负责运算[lambda表达式]。

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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;env
(define empty-env
	(lambda ()
		(list)))
(define empty-env?
	(lambda (env)
		(null? env)))
(define extend-env
	(lambda (var val env)
		(cons var (cons val
			env))))
(define extend-env*
	(lambda (vars vals env)
		(if (null? vars)
			env
			(extend-env* (cdr vars) (cdr vals)
				(extend-env (car vars) (car vals)
					env)))))
(define apply-env
	(lambda (env var)
		(if (empty-env? env)
			var
			(if (equal? var (car env))
				(car (cdr env))
				(apply-env (cdr (cdr env))
					var)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;value-of
(define value-of
	(lambda (exp env cont)
		(cond
			((symbol? exp)
				(cont (apply-env env exp)))
			((lambda? exp)
				(let ((var (lambda-pro-var exp))
					(body (lambda-pro-body exp)))
					(turn-of body
						(extend-env var var env)
							(lambda (new-body)
								(cont
									(list 'lambda (list var) 
										new-body))))))
			((call? exp)
				(let ((rator (get-rator exp))
					(rand (get-rand exp)))
					(value-of rator env
						(lambda (pro)
							(value-of rand env
								(lambda (val)
									(apply-procedure pro val env cont)))))))
			(else (display "value-of error")))))
(define get-rator
	(lambda (exp)
		(car exp)))
(define get-rand
	(lambda (exp)
		(cadr exp)))
(define apply-procedure
	(lambda (pro val env cont)
		(let ((var (caadr pro))
			(body (caddr pro)))
			(value-of body
				(extend-env var val env)
				cont))))
(define lambda?
	(lambda (exp)
		(equal? 'lambda (car exp))))
(define call?
	(lambda (exp)
		(= 2 (length exp))))
(define lambda-pro-var
	(lambda (exp)
		(caadr exp)))
(define lambda-pro-body
	(lambda (exp)
		(caddr exp)))
(define turn-of
	(lambda (exp env cont)
		(cond 
			((symbol? exp)
				(cont (apply-env env exp)))
			((lambda? exp)
				(let ((var (lambda-pro-var exp))
					(body (lambda-pro-body exp)))
					(turn-of body
						(extend-env var var env)
						(lambda (new-body)
							(cont (list 'lambda (list var)	
								new-body))))))
			((call? exp)
				(let ((rator (get-rator exp))
					(rand (get-rand exp)))
					(turn-of rator env
						(lambda (new-rator)
							(turn-of rand env
								(lambda (new-rand)
									(cont (list new-rator new-rand))))))))

			(else (display exp)))))

翻译器 translate-of

负责将“+” “-” “if”等基本的函数翻译成”lambda表达式”

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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Basic lambda procedure
(define lambda-add
	(list 'lambda (list 'y)
		(list 'lambda (list 'z)
			(list 'lambda (list 'f)
				(list 'lambda (list 'x)
					(list (list 'y 'f) 
						(list (list 'z 'f) 'x)))))))
(define lambda-cps-add
	'(lambda (x)
	   (lambda (y)
	     (lambda (cont)
     	  (cont
     	   (((lambda (y)
     	       (lambda (z)
     	         (lambda (f)
     	           (lambda (x) ((y f) ((z f) x))))))
     	     x)
     	    y))))))

(define lambda-if
	(list 'lambda (list 'f)
		(list 'lambda (list 'a)
			(list 'lambda (list 'b)
				(list (list 'f 'a) 'b)))))
(define lambda-false
	(list 'lambda (list 'f)
		(list 'lambda (list 'x)
			'x)))
(define lambda-true
	(list 'lambda (list 'f)
		(list 'lambda (list 'x)
			'f)))
	
(define lambda-zero?
	(list 'lambda (list 'n)
		(list 
			(list 'n
				(list 'lambda (list 'x)
					lambda-false))
			lambda-true)))
(define lambda-cps-zero?
	'(lambda (x)
	   (lambda (cont)
	     (cont
	      ((lambda (n)
	         ((n
	           (lambda (x) (lambda (f) (lambda (x) x))))
	          (lambda (f) (lambda (x) f))))
	       x)))))

(define lambda-cons
	(list 'lambda (list 'a)
		(list 'lambda (list 'b)
			(list 'lambda (list 'f)
				(list (list 'f 'a) 'b)))))
(define lambda-cps-cons
	'(lambda (x)
	   (lambda (y)
     	(lambda (cont)
     	  (cont
     	   (((lambda (a)
          	  (lambda (b) (lambda (f) ((f a) b))))
          	x)
         		y))))))
(define lambda-car 
	(list 'lambda (list 'p)
		(list 'p lambda-true)))
(define lambda-cps-car
	'(lambda (x)
   		(lambda (cont)
     	(cont
  	    (((lambda (p) (p (lambda (f) (lambda (x) f))))
     	   x)
     	  y)))))
(define lambda-cdr
	(list 'lambda (list 'p)	
		(list 'p lambda-false)))
(define lambda-cps-cdr
	'(lambda (x)
   		(lambda (cont)
   		  (cont
     		 (((lambda (p) (p (lambda (f) (lambda (x) x))))
     	   		x)
     		  y)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;expval->lambda-val
(define num->lambda-num
	(lambda (num)
		(define get-body
			(lambda (n)
				(if (= n 0)
					'x
					(list 'f 
						(get-body (- n 1))))))
		(list 'lambda (list 'f)
			(list 'lambda (list 'x)
				(get-body num)))))
(define bool->lambda-bool
	(lambda (bool)
		(list 'lambda (list 'f)
			(list 'lambda (list 's)
				(if bool 'f 's)))))
			
(define call->lambda-call;----------->have some problem
	(lambda (lam-pro lam-vals)
		(if (= 1 (length lam-vals))
			(list lam-pro (car lam-vals))
			(call->lambda-call
				(list lam-pro (car lam-vals))
				(cdr lam-vals)))))
(define pro->lambda-pro
	(lambda (pro cont)
		(cond
			((equal? '+ pro)
				(cont lambda-add))
			((equal? 'cps&+ pro)
				(cont lambda-cps-add))
			((equal? 'if pro)
				(cont lambda-if))
			((equal? 'zero? pro)
				(cont lambda-zero?))
			((equal? 'cps&zero? pro)
				(cont lambda-cps-zero?))
			((equal? 'cons pro)
				(cont lambda-cons))
			((equal? 'cps&cons pro)
				(cont lambda-cps-cons))
			((equal? 'car pro)
				(cont lambda-car))
			((equal? 'cps&car pro)
				(cont lambda-cps-car))
			((equal? 'cdr pro)
				(cont lambda-cdr))
			((equal? 'cps&cdr pro)
				(cont lambda-cps-cdr))
			(else (translate-of pro cont)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;lambda-val->expval
(define lambda-num->num
	(lambda (exp)
		(apply 
			(apply (eval exp) 
				(list (lambda (x) (+ 1 x))))
			(list 0))))
;lambda-call->call ;maybe not have
(define lambda-bool->bool
	(lambda (exp)
		(apply 
			(apply (eval exp)
				(list #t))
			(list #f))))
(define lambda-bool?
	(lambda (exp)
		(boolean? 
			(lambda-bool->bool exp))))
(define lambda-num?
	(lambda (exp)
		(number? 
			(lambda-num->num exp))))
;lambda-val->val
(define lambda-val->val
	(lambda (exp)
		(cond 
			((lambda-num? exp)
				(lambda-num->num exp))
			((lambda-bool? exp)
				(lambda-bool->bool exp))
			(else (display "lambda-val->val error")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;translate-of 
(define translate-of
	(lambda (exp cont)
		(cond 
			((symbol? exp) (cont exp))
			((number? exp)
				(cont (num->lambda-num exp)))
			((boolean? exp)
				(cont (bool->lambda-bool exp)))
			((equal? 'lambda (car exp))
				(let ((vars (cadr exp))
					(body (caddr exp)))
					(if (null? vars)
						(translate-of body cont)
						(translate-of 
							(list 'lambda (cdr vars)
								body)
							(lambda (new-body)
								(cont 
									(list 'lambda (list (car vars))
										new-body)))))))
			(else 
				(let ((rator (car exp))
					(rands (cdr exp)))
					(pro->lambda-pro rator
						(lambda (lam-pro)
						(if (= 1 (length rands))
							(translate-of (car rands)
								(lambda (lam-val)
									(cont (list lam-pro lam-val))))
							(translate-of (car rands)
								(lambda (lam-val)
									(translate-of 
										(append (list (list lam-pro lam-val))
											(cdr rands))
										cont))))))))
)))	


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;text
(define text
	(lambda (exp)
		(lambda-val->val 
			(value-of-lambda-program 
				(translate-of exp (lambda (val) val))))))
;intertsting thing
;< (text '(+ 1 1 6))
;> 36
;< (text '(+ 1 1 7))
;> 49

最后部分 CPS变换

由于这个语言需要拥有[Exception]功能，所以我额外增加了[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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;first interpreter
;--------------------------------------------------------------name procedure
(define name 0)

(define get-name
	 (lambda ()
		(let ((na (string->symbol (string-append "val" (number->string name)))))
			(set! name (+ name 1))
			na)))
(define name->CPS-name
	(lambda (name)
		(if (and (not (pair? name))
				(prim? name))
			(string->symbol
				(string-append "cps&"
					(symbol->string name)))
			name)))
;--------------------------------------------------------------predicate
(define lambda?
	(lambda (exp)
		(equal? 'lambda (car exp))))

(define prim?
	(lambda (na)
		(or (equal? na '+)
			(equal? na '-)
			(equal? na '*)
			(equal? na '/)
			(equal? na '=)
			(equal? na '>)
			(equal? na '<)
			(equal? na 'zero?)
			(equal? na 'cons)
			(equal? na 'car)
			(equal? na 'cdr)
)))
(define small-exp?	
	(lambda (exp)
		(= 1 (deep exp))))

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

(define try&catch?
	(lambda (exp)
		(and (equal? 'try (car exp))
			(equal? 'catch (caddr exp)))))
(define raise?
	(lambda (exp)
		(and (pair? exp)
			(equal? 'raise (car exp)))))
(define let?
	(lambda (exp)
		(and (pair? exp)
			(equal? (car exp) 'let))))
;--------------------------------------------------------------other procedur

(define get-next-exp
	(lambda (exp)
		(define new-name (get-name))
		(define get-exp "null")
		(define inner
			(lambda (index exp)
				(if (< 0 (car index))
					(begin 
						(set! get-exp (car exp))
						(cons new-name (cdr exp)))
					(cons (car exp)
						(inner (cdr index) (cdr exp))))))
		(let ((new-body (inner (map deep exp) exp)))
			(list get-exp (list 'lambda (list new-name)
							new-body)))))

(define deep
	(lambda (tree)
		(if (not (pair? tree))
			0
			(if (lambda? tree)
				0
				(+ 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 delete-try&catch
	(lambda (exps)
		(if (and (pair? (car exps))
				(lambda? (car exps))
				(try&catch? (caddr (car exps))))
			(cons (cadddr (caddr (car exps)))
				(cdr exps))	
			(delete-try&catch (cdr exps)))))
;--------------------------------------------------------------main procedure
(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)))
					((let? exp)
						(let ((vars (map car (cadr exp)))
							(vals (map cadr (cadr exp)))
							(body (caddr exp)))			
						(inner (cons (list 'lambda vars body)
								vals) 
								exps)))
;it is so big, then I think that have a better solutions
;----------------------------------------------------------
					((raise? exp)						
						(let ((body (cadr exp))
							(new-exps (delete-try&catch exps)))
							(inner body new-exps)))
					((try&catch? exp)
						(let ((exp1 (cadr exp))
							(handler-pro (cadddr exp)))
								(if (and (or (not (pair? exp1))
											(small-exp? exp1))
										(not (raise? exp1)))
									(inner exp1 exps)
									(let ((name (get-name)))
										(inner exp1
											(cons 
												(list 'lambda (list name)
													(list 'try name 'catch
														handler-pro))
												exps))))))
;-----------------------------------------------------------------------------
					((small-exp? exp)
						(let ((exp1 (map cps exp)))
						(if (null? exps)
							(cons (name->CPS-name (car exp1))
								(append (cdr exp1) (list 'cont)))
							(cons (name->CPS-name (car exp1))
								(append (cdr exp1) (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))))))))
	(cond 
		((not (pair? exp)) exp)
		((lambda? exp) 
			(list 'lambda (append (cadr exp) (list 'cont))
				(inner (caddr exp) (list))))
		(else (list 'lambda (list 'cont) 
				(inner exp (list)))))
))
;may be
;have some error
;(cps '((lambda (x) x) 1))
;(cps '(f (lambda (x) x) 1))
;(cps '(if b (lambda (x) x) 1))
;(cps '(try (raise 1) catch (lambda (x) x)))

END

1
2
3
4
5
;;;;;;;;;;;;;;;;;;entir
(define ff
	(lambda (exp)
		(text (list (cps exp)
				(list 'lambda (list 'val) 'val)))))

CTV语言勉勉强强可以使用

1
2
3
4
5
6
7
8
9
10
11
(ff '(+ 1 2))
>3

(ff '(try (if (zero? 1) (raise 1) 2) catch (lambda (x) x)))
>2

(ff '(let ((x 1)) x))
>1

(ff '(zero? 0))
>#t