Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 161 lines (136 sloc) 3.583 kB
d00c4e5 initial import; last touched in 2001
darius authored
1 ; Tail-recursive Scheme interpreter
2 ; Uses: startup scmhelp.lsp
3 ; Based on Abelson & Sussman, chapter 5.
4 ; The most glaring omissions are error-checking, set!, begin, and call/cc.
5
6 (define next '*)
7
8 (define exp '*)
9 (define env '*)
10 (define proc '*)
11 (define rands '*)
12 (define args '*)
13 (define value '*)
14 (define cont '*)
15
16 (define read-eval-print-loop
17 (lambda ()
18 (while (begin
19 (write '>)
20 (not (eq? the-eof-object (set! exp (read)))))
21 (set! exp (macroexpand exp))
22 (set! env init-env)
23 (set! cont (lambda () 'halt))
24 (set! next eval-exp)
25 (run)
26 (print value))))
27
28 (define run
29 (lambda ()
30 (while (not (eq? (next) 'halt)))))
31
32 (define goto
33 (lambda (procedure)
34 (set! next procedure)))
35
36 (define return
37 (lambda (val)
38 (set! value val)
39 (set! next cont)))
40
41 (define eval-exp
42 (lambda ()
43 (if (atom? exp)
44 (return
45 (if (symbol? exp)
46 (lookup-variable exp env)
47 exp))
48 (let ((handler (get (car exp) 'evaluator)))
49 (if handler
50 (handler)
51 (begin ; procedure call
52 (push cont) ; this eventually is popped by apply-proc
53 (push env)
54 (push (cdr exp)) ; save the operands
55 (set! exp (car exp)) ; evaluate the operator
56 (set! cont eval-rands)
57 (goto eval-exp)))))))
58
59 (define eval-rands
60 (lambda ()
61 (set! rands (pop))
62 (set! env (pop))
63 (set! args '())
64 (push value) ; save the procedure
65 (goto rands-loop)))
66
67 (define rands-loop
68 (lambda ()
69 (if (null? rands)
70 (begin
71 (set! args (reverse! args))
72 (set! proc (pop))
73 (goto apply-proc))
74 (begin
75 (set! exp (car rands))
76 (push env)
77 (push args)
78 (push (cdr rands))
79 (set! cont add-arg)
80 (goto eval-exp)))))
81
82 (define add-arg
83 (lambda ()
84 (set! rands (pop))
85 (set! args (cons value (pop)))
86 (set! env (pop))
87 (goto rands-loop)))
88
89 (put 'quote 'evaluator
90 (lambda ()
91 (return (cadr exp))))
92
93 (put 'lambda 'evaluator
94 (lambda ()
95 (return (make-closure exp env))))
96
97 (put 'if 'evaluator
98 (lambda ()
99 (push cont)
100 (push env)
101 (push exp)
102 (set! cont decide)
103 (set! exp (test-exp exp))
104 (goto eval-exp)))
105
106 (define decide
107 (lambda ()
108 (set! exp (pop))
109 (set! env (pop))
110 (set! cont (pop))
111 (set! exp (if value (then-exp exp) (else-exp exp)))
112 (goto eval-exp)))
113
114 (put 'define 'evaluator
115 (lambda ()
116 (push cont)
117 (push env)
118 (push (cadr exp)) ; save the variable being defined
119 (set! exp (caddr exp)) ; evaluate the defining expression
120 (set! cont do-definition)
121 (goto eval-exp)))
122
123 (define do-definition
124 (lambda ()
125 (set! exp (pop))
126 (set! env (pop))
127 (set! cont (pop))
128 (define-variable-value exp value env)
129 (return exp)))
130
131 (define apply-proc
132 (lambda ()
133 (set! cont (pop))
134 (if (primitive? proc)
135 (return (apply proc args))
136 (begin
137 (set! exp (closure-body proc))
138 (set! env
139 (extend-env (closure-formals proc) args (closure-env proc)))
140 (goto eval-exp)))))
141
142 ; Stack operations
143
144 (define stack '())
145
146 (define push
147 (lambda (x)
148 (set! stack (cons x stack))))
149
150 (define pop
151 (lambda ()
152 (let ((result (car stack)))
153 (set! stack (cdr stack))
154 result)))
155
156 ; Here we go
157
158 (define init-env (extend-env '() '() '()))
159
160 (read-eval-print-loop)
Something went wrong with that request. Please try again.