[Scheme]一个Scheme的Metacircular evaluator

Lisp内置的S-expression相当于解析好的语法树，而借助quasiquote和unquote又很容易进行语法树层面的变换，所以Lisp的自举和扩展都很容易。

 1 #lang racket
2
3 (require racket/match)
4 ;------------------------------
5 (define (eval env e k)
6   (match e
7          [(? symbol?) (k (cdr (assq e env)))]
8          [(list 'lambda arg-list exp-list ...)
9           (let ([arg-list (if (empty? arg-list) '(_) arg-list)])
10             (cond
11               [(> (length arg-list) 1)
12                (eval env (lambda (,(car arg-list)) (lambda ,(cdr arg-list) ,@exp-list)) k)]
13               [(> (length exp-list) 1)
14                (eval env (lambda ,arg-list ((lambda (_) ,@(cdr exp-list)) ,(car exp-list))) k)]
15               [else (k
16                       (lambda (arg k2)
17                         (eval (cons (cons (car arg-list) arg) env) (car exp-list) k2)))]))]
18          [(list p arg-list ...)
19           (let ([arg-list (if (empty? arg-list) '(print) arg-list)])
20             (if (= 1 (length arg-list))
21               (eval env p (lambda (p)
22                             (eval env (car arg-list) (lambda (arg)
23                                                        (p arg k)))))
24               (eval env ((,p ,(car arg-list)) ,@(cdr arg-list)) k)))]
25          )
26   )
27 ;------------------------------
28 (define G (list
29             (cons 'print (lambda (n k)
30                            (n (lambda (v k2)
32                               (lambda (v)
33                                 (v 0 (lambda (v) (k (print v))))))))
34             (cons 'newline (lambda (_ k)
35                              (k (newline))))
36             (cons 'call/cc (lambda (f k)
37                              (f (lambda (v k2) (k v)) k)))
38             ))
39 ;------------------------------
40 (eval G (read) identity)

 1 ((lambda (zero one add mul pow sub1 true false and or)
2    ((lambda (sub not zero? two Y)
3       ((lambda (less-equal? equal? three four)
4          ;------------------------------
5          ((lambda (for-each fib)
6             (for-each (lambda (i) (print (fib zero one zero i))(newline)) zero (mul four four))
7             )
8           (Y
9             (lambda (self)
10               (lambda (f i n)
11                 (f i)
12                 (((equal? i n)
13                   (lambda () i)
14                   (lambda () (self f (add i one) n))))
15                 )
16               ))
17           (Y
18             (lambda (self)
19               (lambda (a b i n)
20                 (((equal? i n)
21                   (lambda () a)
22                   (lambda () (self b (add a b) (add i one) n))))
23                 )
24               ))
25           )
26          ;------------------------------
27          )
28        (lambda (m n) (zero? (sub m n)))
29        (lambda (m n) (and (zero? (sub m n)) (zero? (sub n m))))
32        ))
33     (lambda (m n) (n sub1 m))
34     (lambda (a) (a false true))
35     (lambda (n) (n (lambda (x) false) true))
37     (lambda (f)
38       ((lambda (g) (g g))
39        (lambda (g) (f (lambda (a) ((g g) a))))))
40     ))
41  (lambda (f x) x)
42  (lambda (f x) (f x))
43  (lambda (m n f x) (m f (n f x)))
44  (lambda (m n f) (m (n f)))
45  (lambda (e b) (e b))
46  (lambda (n f x)
47    (((n
48        (lambda (g h) (h (g f))))
49      (lambda (u) x))
50     (lambda (u) u)))
51  (lambda (a b) a)
52  (lambda (a b) b)
53  (lambda (a b) (a b a))
54  (lambda (a b) (a a b))
55  )

1 ((lambda (yin)
2    ((lambda (yang)
3       (yin yang))
4     ((lambda (c) (print (lambda (f x) x)) c)
5      (call/cc (lambda (k) k)))))
6  ((lambda (c) (print (lambda (f x) (f x))) c)
7   (call/cc (lambda (k) k))))`

posted @ 2014-05-31 09:47  Scan.  阅读(1211)  评论(0编辑  收藏  举报