网络书屋(Web Reading Room)

A blogging framework for hackers.

It's a Dead program.How to Let It Alive?

All programs are data. All intepreters are program. All Handware and software,or type checkers etc are interpreter.

I think data conceives the soul,not only the fixed process,but changing vari-language.

The Little Scheme

Here below is the interpreter from TLS

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
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
#lang racket
;;简单环境配置
    (define atom?
     (lambda (x)
      (and (not (pair? x)) (not (null? x)))))


    ;第一大部分 定义好整体框架
    (define value
     (lambda (e)
      (meaning e (quote ()))))
    (define meaning
     (lambda (e table)
      ((expression-to-action e) e table)))

    ;;第二大部分 解析atom and list action

    (define expression-to-action
     (lambda (e)
      (cond
       ((atom? e) (atom-to-action e))
       (else (list-to-action e)))))
    (define atom-to-action
     (lambda (e)
      (cond
       ((number? e) *const)
       ((eq? e #t) *const)
       ((eq? e #f) *const)
       ((eq? e (quote cons)) *const)
       ((eq? e (quote car)) *const)
       ((eq? e (quote cdr)) *const)
       ((eq? e (quote null?)) *const)
       ((eq? e (quote eq?)) *const)
       ((eq? e (quote atom?)) *const)
       ((eq? e (quote zero?)) *const)
       ((eq? e (quote add1)) *const)
       ((eq? e (quote sub1)) *const)
       ((eq? e (quote number?)) *const)
       (else *identifier))))
    (define list-to-action
     (lambda (e)
      (cond
       ((atom? (car e))
        (cond
         ((eq? (car e) (quote quote))
          *quote)
         ((eq? (car e) (quote lambda))
          *lambda)
         ((eq? (car e) (quote cond))
          *cond)
         (else *application)))
       (else *application))))

    ;; 第三大部分 定义 6星==5个special forms 和一个general forms(*application)

    ;;;环境额外配置 这些配置仅仅是为了增加可读性 无任何编程技巧
    (define first
     (lambda (p)
      (cond
       (else (car p)))))
    (define second
     (lambda (p)
      (cond
       (else car (cdr p)))))
    (define third
     (lambda (p)
      (cond
       (else car (cdr (cdr p))))))
(define text-of second)
    ;; *identifier
    (define table-of first)
    (define formals-of second)
(define body-of third)
    ;;*cond
    (define question-of first)
    (define answer-of second)
(define cond-lines-of cdr)
    ;;*application
    (define function-of car)
(define arguments-of cdr)

    (define build
     (lambda (s1 s2)
      (cond
       (else (cons s1
              (cons s2 (quote ())))))))
    ;;1st star
    (define *const
     (lambda (e table)
      (cond
       ((number? e) e)
       ((eq? e #t) #t)
       ((eq? e #f) #f)
       (else (build (quote primitive) e)))))
    ;;2nd star
    (define *quote
     (lambda (e table)
      (text-of e)))
    ;;3rd star
    (define *lambda
     (lambda (e table)
      (build (quote non-primitive)
       (cons table (cdr e)))))
    ;;4th star
    (define *identifier
     (lambda (e table)
      (lookup-in-table e table initial-table)))
    (define initial-table
     (lambda (name)
      (car (quote ()))))
    (define lookup-in-table
     (lambda (name table table-f)
      (cond
       ((null? table) (table-f name))
       (else (lookup-in-entry name
              (car table)
              ; (lambda (name)
                  ; (cdr table)
                  ; (table-f)))))))
(lambda (name)
 (lookup-in-table name
  (cdr table)
  table-f)))))))
    (define lookup-in-entry
     (lambda (name entry entry-f)
      (lookup-in-entry-help name
       (first entry)
       (second entry)
       entry-f)))
    (define lookup-in-entry-help
     (lambda (name names values entry-f)
      (cond
       ((null? names) (entry-f name))
       ((eq? (car names) name)
        (car values))
       (else (lookup-in-entry-help name
              (cdr names)
              (cdr values)
              entry-f)))))

    ;; 5th star
    (define *cond
     (lambda (e table)
      (evcon (cond-lines-of e) table)))
    (define evcon
     (lambda (lines table)
      (cond
       ((else? (question-of (car lines)))
        (meaning (answer-of (car lines))
         table))
       ((meaning (question-of (car lines))
         table)
        (meaning (answer-of (car lines))
         table))
       (else (evcon (cdr lines) table)))))

    (define else?
     (lambda (x)
      (cond
       ((atom? x) (eq? x (quote else)))
       (else #f))))


    ;;6th star 你需要解析arguments的各个部分这是evlis的工作
    (define *application
     (lambda (e table)
      (apply
       (meaning (function-of e) table)
       (evlis (arguments-of e) table))))

    (define evlis
     (lambda (args table)
      (cond
       ((null? args) (quote ()))
       (else
        (cons (meaning (car args) table)
         (evlis (cdr args) table))))))


    ;;第四大部分 进行 apply的定义 反向运用primitive和non-primitive 去除核心的primitive和non-primitive前缀,并升级环境

    (define apply
     (lambda (fun vals)
      (cond
       ((primitive? fun)
        (apply-primitive
         (second fun) vals))
       ((non-primitive? fun)
        (apply-closure
         (second fun) vals)))))

    (define primitive?
     (lambda (l)
      (eq? (first l) (quote primitive))))
    (define non-primitive?
     (lambda (l)
      (eq? (first l) (quote non-primitive))))
    (define apply-primitive
     (lambda (name vals)
      (cond
       ((eq? name (quote cons))
        (cons (first vals) (second vals)))
       ((eq? name (quote car))
        (car (first vals)))
       ((eq? name (quote cdr))
        ((eq? name (quote cdr))
         (cdr (first vals)))
        ((eq? name (quote null?))
         (null? (first vals)))
        ((eq? name (quote eq?))
         (eq? (first vals) (second vals)))
        ((eq? name (quote atom?))
         (:atom? (first vals)))
        ((eq? name (quote zero?))
         (zero? (first vals)))
        ((eq? name (quote add1))
         (add1 (first vals)))
        ((eq? name (quote sub1))
         (sub1 (first vals)))
        ((eq? name (quote number?))
         (number? (first vals)))))))
    (define :atom?
     (lambda (x)
      (cond
       ((atom? x) #t)
       ((null? x) #f)
       ((eq? (car x) (quote primitive))
#t)
       ((eq? (car x) (quote non-primitive))
#t)
       (else #f))))

    ;;closure=table+arguments+body ;;arguments 通过formals-of获取 body-of获取body
    (define apply-closure
     (lambda (closure vals)
      (meaning (body-of closure)
       (extend-table
        (new-entry
         (formals-of closure)
         vals)
        (table-of closure)))))
    (define new-entry build)
(define extend-table cons)


    ;;测试这个解释器
    ;(value (cons (* (+ 1 3) 4) 'hello)) ;;不通过
    (value (+ 2 4))
(value (* 15 (+ 2 4)))
    ;;(value (cons (quote (* (+ 1 3) 4)) (cons 'h '()))) ;;测试不通过

The Season scheme

Here below is the interpreter from TLS

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
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
#lang racket
;; The Seasoned Schemer
;; chapter 20
;; What's in Store ?

(define abort '())

(define global-table '())

(define (add1 n)
 (+ n 1))

(define (sub1 n)
 (- n 1))

    (define (atom? a)
     (and (not (pair? a))
      (not (null? a))))

(define (text-of x)
 (cadr x))

(define (formals-of x)
 (cadr x))

(define (body-of x)
 (cddr x))

(define (ccbody-of x)
 (cddr x))

(define (name-of x)
 (cadr x))

    (define (right-side-of x)
     (if (null? (cddr x))
      0
      (caddr x)))

(define (cond-lines-of x)
 (cdr x))

    (define (else? x)
     (if (atom? x)
      (eq? x 'else)
#f))

(define (question-of x)
 (car x))

(define (answer-of x)
 (cadr x))

(define (function-of x)
 (car x))

(define (arguments-of x)
 (cdr x))


(define (lookup table name)
 (table name))

    (define (extend name1 val table)
     (lambda (name2)
      (if (eq? name1 name2)
       val
       (table name2))))

    (define (define? e)
     (eq? (and (pair? e)
           (car e)) 'def))

(define (*define e)
 (set! global-table
  (extend (name-of e)
   (box (the-meaning (right-side-of e)))
   global-table)))

    (define (box it)
     (lambda (sel)
      (sel it (lambda (new)
               (set! it new)))))

    (define (setbox box new)
     (box (lambda (it set)
           (set new))))

    (define (unbox box)
     (box (lambda (it set)
           it)))

(define (the-meaning e)
 (meaning e lookup-in-global-table))

(define (lookup-in-global-table name)
 (lookup global-table name))

(define (meaning e table)
 ((expression-to-action e) e table))

(define (*quote e table)
 (text-of e))

(define (*identifier e table)
 (unbox (lookup table e)))

(define (*set e table)
 (setbox
  (lookup table (name-of e))
  (meaning (right-side-of e) table)))

    (define (*lambda e table)
     (lambda (args)
      (beglis (body-of e)
       (multi-extend (formals-of e)
        (box-all args)
        table))))

    ;; (define (beglis es table)
            ;; (cond
                ;; ((null? (cdr es))
                    ;; (meaning (car es) table))
                ;; (else ((lambda (val)
                            ;; (beglis (cdr es) table))
                        ;; (meaning (car es) table)))))

    ;; (define (beglis es table)
            ;; (let ((m (meaning (car es) table)))
                ;; (if (null? (cdr es))
                    ;; m
                    ;; ((lambda (val)
                            ;; (beglis (cdr es) table)) m))))

    ;; (define (beglis es table)
            ;; (let ((m (meaning (car es) table)))
                ;; (if (null? (cdr es))
                    ;; m
                    ;; (let ((val m))
                        ;; (beglis (cdr es) table)))))

    (define (beglis es table)
     (let ((m (meaning (car es) table))
           (d (cdr es)))
      (if (null? d)
       m
       (beglis d table))))

    ;; (define (box-all vals)
            ;; (if (null? vals)
                ;; '()
                ;; (cons (box (car vals))
                    ;; (box-all (cdr vals)))))

    ;; (define (box-all vals)
            ;; (letrec
                ;; ((rec
                        ;; (lambda (vals acc)
                            ;; (if (null? vals)
                                ;; acc
                                ;; (rec (cdr vals)
                                    ;; (cons (box (car vals)) acc))))))
                ;; (rec (reverse vals) '())))

    (define (box-all vals)
     (let loop ((vals (reverse vals))
                (acc '()))
      (if (null? vals)
       acc
       (loop (cdr vals)
        (cons (box (car vals)) acc)))))

    (define (multi-extend names vals table)
     (if (null? names)
      table
      (extend (car names)(car vals)
       (multi-extend (cdr names)(cdr vals)
        table))))

    (define (*application e table)
     ((meaning (function-of e) table)
      (evlis (arguments-of e) table)))

    ;; (define (evlis args table)
            ;; (if (null? args)
                ;; '()
                ;; ((lambda (val)
                        ;; (cons val
                            ;; (evlis (cdr args) table)))
                    ;; (meaning (car args) table))))

    ;; (define (evlis args table)
            ;; (if (null? args)
                ;; '()
                ;; (cons (meaning (car args) table)
                    ;; (evlis (cdr args) table))))

    ;; (define (evlis args table)
            ;; (letrec
                ;; ((rec
                        ;; (lambda (args table acc)
                            ;; (if (null? args)
                                ;; acc
                                ;; (rec (cdr args)
                                    ;; table
                                    ;; (cons (meaning (car args) table)
                                        ;; acc))))))
                ;; (rec (reverse args) table '())))

    (define (evlis args table)
     (let loop ((args (reverse args))
                (table table)
                (acc '()))
      (if (null? args)
       acc
       (loop (cdr args) table
        (cons (meaning (car args) table)
         acc)))))

    (define (a-prim p)
     (lambda (args-in-a-list)
      (p (car args-in-a-list))))

    (define (b-prim p)
     (lambda (args-in-a-list)
      (p (car args-in-a-list)
       (cadr args-in-a-list))))

(define (*const e table)
 (cond
  ((number? e) e)
  ((eq? e #t) #t)
  ((eq? e #f) #f)
  ((eq? e 'cons)(b-prim cons))
  ((eq? e 'car )(a-prim car))
  ((eq? e 'cdr)(a-prim cdr))
  ((eq? e 'eq?)(b-prim eq?))
  ((eq? e 'atom?)(a-prim atom?))
  ((eq? e 'null?)(a-prim null?))
  ((eq? e 'zero?)(a-prim zero?))
  ((eq? e 'add1)(a-prim add1))
  ((eq? e 'sub1)(a-prim sub1))
  ((eq? e 'number)(a-prim number?))))

(define (*cond e table)
 (evcon (cond-lines-of e) table))

(define (evcon lines table)
 (cond
  ((else? (question-of (car lines)))
   (meaning (answer-of (car lines)) table))
  ((meaning (question-of (car lines)) table)
   (meaning (answer-of (car lines)) table))
  (else (evcon (cdr lines) table))))

(define (*letcc e table)
 (let/cc skip
  (beglis (ccbody-of e)
   (extend (name-of e)
    (box (a-prim skip) table)))))

(define (value e)
 (let/cc the-end
  (set! abort the-end)
  (if (define? e)
   (*define e)
   (the-meaning e))))

(define (the-empty-table name)
 (abort
  (cons 'no-answer
   (cons name '()))))

    (define (expression-to-action e)
     (if (atom? e)
      (atom-to-action e)
      (list-to-action e)))

(define (atom-to-action e)
 (cond
  ((number? e) *const)
  ((eq? e #t) *const)
  ((eq? e #f) *const)
  ((eq? e 'cons) *const)
  ((eq? e 'car) *const)
  ((eq? e 'cdr) *const)
  ((eq? e 'null?) *const)
  ((eq? e 'eq?) *const)
  ((eq? e 'atom?) *const)
  ((eq? e 'zero?) *const)
  ((eq? e 'add1) *const)
  ((eq? e 'sub1) *const)
  ((eq? e 'number?) *const)
  (else *identifier)))

    (define (list-to-action e)
     (let ((a (car e)))
      (if (atom? a)
       (let ((prim-of? (lambda (x) (eq? x a ))))
        (cond
         ((prim-of? 'quote) *quote)
         ((prim-of? 'lambda) *lambda)
         ((prim-of? 'letcc) *letcc)
         ((prim-of? 'set!) *set)
         ((prim-of? 'cond) *cond)
         (else *application)))
       *application)))


(set! global-table (lambda (name)
                    (the-empty-table name)))
    (value (cons 'a 'b))
(value (+ (- 3 2) 6))

The CPS control struture

Here below is the method how to change the ordinary subroutine to the continuation passing style Ref..

  • First rule: whenever we see a lambda in the code we want to CPS, we have to add an argument, and then process the body
  • Second rule: “Don’t sweat the small stuff!”

how to add argument?

  • orignial style:
1
2
3
4
5
6
(define rember8
  (lambda (ls)
    (cond
      [(null? ls) '()]
      [(= (car ls) 8) (cdr ls)]
      [else (cons (car ls) (rember8 (cdr ls)))])))
  • incompleted cps style:
1
2
3
4
5
6
(define rember8
  (lambda (ls k)
    (cond
      [(null? ls) '()]
      [(= (car ls) 8) (cdr ls)]
      [else (cons (car ls) (rember8 (cdr ls)))])))

what is the small stuff?

Small stuff is stuff we know will terminate right away. Don’t sweat the small stuff if we know it will be evaluated. Don’t sweat the small stuff if it might be evaluated, but instead pass it to k.

为了更好辨别,我们改为如下形式

1
2
3
4
5
6
(define rember8
  (lambda (ls k)
    (cond
      [(null? ls) (*k* '())]
      [(= (car ls) 8) (*k* (cdr ls))]
      [else (*rember8* (cdr ls) (lambda (x) (*k* (cons (car ls) x))))])))

凡是加上*号的,都代表者continuation的过程。

Why don't null?, =, car, cdr, and cons count? Because they're just
small stuff, and when we combine small stuff together in small ways,
the combination remains small.

Second, all arguments are small stuff. Yep, even the lambda in the
else line, because lambda is *always* small stuff.
  • complete cps style:
1
2
3
4
5
6
(define rember8
  (lambda (ls k)
    (cond
      [(null? ls) (k '())]
      [(= (car ls) 8) (k (cdr ls))]
      [else (rember8 (cdr ls) (lambda (x) (k (cons (car ls) x)))])))

how to evaluate or interpreter a procedre?

ordinary tracing

we will develop a unimplemented language to do give an explanation to it.

Here below is the main language(we can change it ,but now it is not the main cause.)

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
;1 eval
(define eval
   (lambda (Exp Env )
 (cond 
    ((number? Exp)  Exp)
    ((symbol? Exp) (looking Exp Env))
    ((eq? (car Exp) 'QUADE) (cadr Exp))
    ((eq? (car Exp) 'lambda)
        (list 'Closure (cdr Exp) Env))
    ((eq? (car Exp) 'Cond)
        Evcond (cadr Exp Env))
    (else
        (apply 
           (eval (car Exp) Env)
           (Evlist (cdr Exp) Env))))))

;2 apply
(define apply
   (lambda (PROC ARGS)
     (cond 
        ((primitive? PROC)
          (Apply-primitive Proc ARGS))
        ((EQ? (car proc) 'closure)
          (EVAL  (cadadr proc)
            (Bind (caadr proc)
                ARGS
               (Caddr proc))))
         (else error)))))

;;;Attention, primitvie?  apply-primitive  is not finished

;3 Evlist
(define Evlist
  (lambda (l Env)
    (cond 
      ((eq? (car l) '()) '())
      (else
         (cons (eval (car l) Env)
               (eval (cdr l) Env))))))

;4 Evcond
(define Evcond
   (lambda (clauses Env)
     (cond
        ((eq? clauses '()) '())
        ((eq? (caar clauses) 'else)
            (eval (cadar clauses) Env))
         ((false? (Eval (caar clauses) Env))
            (Evcond (cdr clauses) Env))
         (else
            (Eval (cadar clauses) Env)))))

;;;Attention false? is not finished.

;5 looking
(define looking
   (lambda (sym env)
     (cond 
       ((eq? env '()) (error 'unbound-value))
       (else
         ((lambda (vcell)
             (cond 
               ((eq? vcell '())
                  (looking sym (cdr env)))
               (else (cdr vcell))))
           (assq sym (car env)))))))

;6 assq
(define assq
    (lambda (syms alist)
       (cond
         ((eq? alist '()) '())
         ((eq? syms (caar alist)) (car alist))
         (else (assq syms (cdr alist))))))


;7 Bind
(define Bind
   (lambda (vars vals Env)
     (cons (pair-up  vars vals) env)))

;8 Pair-up
(define Pair-up
   (lambda (vars vals)
     (cond 
        ((eq? vars '())
            (cond 
               ((eq? vals? '()) '())
               (else (error 'Too-much-arguments))))
         ((eq? vals '()) (error 'Too-few-arguments))
         (else 
           (cons (cons (car vars)  (car vals))
                  (pair-up (cdr vars) (cdr vals))))))

So now we can use the language below to interpret the form

1
(eval '(((lambda (x)(lambda (y) (+  x y))) 3) 4) e0)

Good explanation begin(kernal part):

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
(apply (eval '((lambda (x) (lambda (y) (+ x y)) 3  e0)
       (Evlist '(4) e0))

(apply (eval '((lambda (x) (lambda (y) (+ x y)) 3  e0)
       cons (eval '(4) e0) (evlist '() e0)))

(apply (eval '((lambda (x) (lambda (y) (+ x y)) 3  e0)
       cons 4 '()))

(apply (eval '((lambda (x) (lambda (y) (+ x y)) 3  e0)
       '(4))


(apply (apply (eval '(lambda (x) (lambda (y) (+ x y))  e0)
       '(3) )
      '(4))

(apply (apply '(closure ((x) (lambad (y) (+ x y))) e0)
       '(3) )
      '(4))

(apply (eval (lambda (y) (+ x y)) e1)
      '(4))

(apply '(closure ((y) (+ x y)) e1)
      '(4))

(eval '(+ x y) e2)

(apply (Eval '+ e2)  (Evlist '(x y) e2))

(apply '(add0101)  '(3 4))   ;add0101 is the assemble executable binary code(speed fast)


+ 3 4 = 7

Finished~ Good ~ Well done.

cps tracing

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Let's trace (rember8  (lambda (x) x))

ls | k

'(1 2 8 3 4 6 7 8 5) | (lambda (x) x) = id
'(2 8 3 4 6 7 8 5)   | (lambda (x) (id (cons 1 x))) = k2
'(8 3 4 6 7 8 5)     | (lambda (x) (k2 (cons 2 x))) = k3

Once we hit the 8, we apply (k (cdr ls)) where k is k3 and ls is '(8 3
4 6 7 8 5)

(k3 '(3 4 6 7 8 5)) = (k2 (cons 2 '(3 4 6 7 8 5)))
(k2 '(2 3 4 6 7 8 5)) = (id (cons 1 '(2 3 4 6 7 8 5)))
(id '(1 2 3 4 6 7 8 5)) = '(1 2 3 4 6 7 8 5)

And we're done.

It is not the end

how to change the procedure above? Leave to you.