Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 144 lines (117 sloc) 3.383 kb
2139060 @kmcallister init
authored
1 ((vau (name-of-define null) env
2 (set-car! env
3 (cons
4 (cons
5 name-of-define
6 (cons
7 (vau (name exp) defn-env
8 (set-car! defn-env
9 (cons
10 (cons name (cons (eval defn-env exp) null))
11 (car defn-env))))
12 null))
13 (car env))))
14 define ())
15
16 (define if (vau (b t f) env
17 (eval env (bool (eval env b) t f))))
18
19 (define quote (vau (x) _ x))
20
21 (define list (vau xs env
22 (if (null? xs)
23 '()
24 (cons
25 (eval env (car xs))
26 (eval env (cons list (cdr xs)))))))
27
28 (define wrap (vau (operative) oper-env
29 (vau args args-env
30 (operate args-env
31 (eval oper-env operative)
32 (operate args-env list args)))))
33
34 (define lambda (vau (params body) static-env
35 (wrap
36 (eval static-env
37 (list vau params '_ body)))))
38
39 (define fact (lambda (n)
40 (if (<= n 1)
41 1
42 (* n (fact (- n 1))))))
43
44 (define last (lambda (xs)
45 (if (null? (cdr xs))
46 (car xs)
47 (last (cdr xs)))))
48
49 (define begin (lambda xs (last xs)))
50
51 (define set! (vau (name exp) env
52 (set-cdr!
53 (lookup name env)
54 (list (eval env exp)))))
55
56 (set! lambda
57 ((lambda (base-lambda)
58 (vau (param . body) env
59 (eval env (list base-lambda param (cons begin body)))))
60 lambda))
61
62 (set! define
63 ((lambda (base-define)
64 (vau (param . body) env
65 (if (pair? param)
66 (eval env
67 (list base-define (car param)
68 (cons lambda (cons (cdr param) body))))
69 (eval env (cons base-define (cons param body))))))
70 define))
71
72 (define (compose f g)
73 (lambda (x) (f (g x))))
74
75 (define caar (compose car car))
76 (define cadr (compose car cdr))
77 (define caddr (compose cadr cdr))
78
79 (define (fib n)
80 (display n)
81 (display "\n")
82 (if (<= n 1)
83 n
84 (+ (fib (- n 1)) (fib (- n 2)))))
85
86 (define (map f xs)
87 (if (null? xs)
88 '()
89 (cons (f (car xs)) (map f (cdr xs)))))
90
91 (define let (vau (binds . body) env
92 (eval env
93 (cons
94 (cons lambda (cons (map car binds) body))
95 (map cadr binds)))))
96
97 (define (to-bool x)
98 (if x #t #f))
99
100 (define (not x)
101 (if x #f #t))
102
103 (define (and-or ident) (vau args env
104 (if (null? args)
105 ident
106 (if (eq? ident (to-bool (eval env (car args))))
107 (eval env (cons (list and-or ident) (cdr args)))
108 (not ident)))))
109
110 (define or (and-or #f))
111 (define and (and-or #t))
112
113 (define cond (vau alts env
114 (if (null? alts)
115 #f
116 (let (( ((test body) . rest) alts ))
117 (if (or (eq? test 'else)
118 (eval env test))
119 (eval env body)
120 (eval env (cons cond rest)))))))
121
122 (define (assq key alist) (cond
123 ((null? alist)
124 #f)
125 ((eq? key (caar alist))
126 (car alist))
127 (else
128 (assq key (cdr alist)))))
129
130 (define (foldr f z xs)
131 (if (null? xs)
132 z
133 (f (car xs) (foldr f z (cdr xs)))))
134
135 (define (append a b)
136 (foldr cons b a))
137
138 (define apply (wrap (vau (operative args) env
139 (eval env (cons
140 operative
141 (map (lambda (x) (list quote x)) args))))))
142
143 ; vim: ft=scheme
Something went wrong with that request. Please try again.