├── .gitignore
├── README.md
├── chapter1.ss
├── chapter10.8.ss
├── chapter10.ss
├── chapter3.ss
├── chapter4.ss
├── chapter6.3.ss
├── chapter6.ss
├── chapter7.4.ss
├── chapter7.ss
├── chapter9.ss
├── closure.ss
├── env.ss
├── null-eval.scm
├── prelude.ss
├── pretreat.ss
├── primitives.c
├── run-smoketest.scm
├── scheme.c
├── scheme.h
├── sexpr.ss
├── show.ss
└── test-exprs.scm


/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | lisp-in-small-pieces
 2 | ====================
 3 | 
 4 | I'm working my way through "Lisp in Small Pieces", by Christian Queinnec.
 5 | The book discusses the implementation of Lisps, and develops interpreters
 6 | and compilers demonstrating various techniques and features of Lisps.
 7 | It's a lot of fun to follow along.
 8 | 
 9 | This repository holds the code I've written while studying the book. I skip a few
10 | chapters (in the sense of not writing any code; I still read them!), and I diverge
11 | and divert from the book according to taste.
12 | 
13 | All the code is in Scheme, and much of it uses SISC-specific libraries
14 | (`generic-procedures`, `oo`, `type-system`). It would
15 | be adaptable to other Schemes, I imagine, since they tend to have analogues of
16 | those libraries. But why wouldn't you be writing your own code instead.
17 | 


--------------------------------------------------------------------------------
/chapter1.ss:
--------------------------------------------------------------------------------
  1 | ;; I'm using SISC 1.16.6 and C-u M-x run-scheme sisc
  2 | 
  3 | ;; We'll keep our implementation primitives prefixed with #$, to make
  4 | ;; it easy to distinguish them.
  5 | 
  6 | ;; What's wrong? Don't be like that.
  7 | 
  8 | (define ($wrong . args)
  9 |   (error args))
 10 | 
 11 | ;; Environment. As per the book we used an improper (cons cells rather
 12 | ;; than lists) alist.  We also use symbols as the keys, which saves us
 13 | ;; transforming from symbols to variable names to lookup keys (i.e.,
 14 | ;; we implicitly lift var names from the interpreted language to
 15 | ;; symbols in the interpreting language).
 16 | 
 17 | (define $env.init '())
 18 | 
 19 | (define ($lookup key env)
 20 |   (if (pair? env)
 21 |       (if (eq? (caar env) key)
 22 |           (cdar env)
 23 |           ($lookup key (cdr env)))
 24 |       ($wrong "Env lookup failed" key)))
 25 | 
 26 | (define ($update! key env value)
 27 |   (if (pair? env)
 28 |       (if (eq? caar env)
 29 |           (begin (set-cdr! (car env) value)
 30 |                  value)
 31 |           ($update! key (cdr env) value))
 32 |       ($wrong "No such binding" key)))
 33 | 
 34 | (define ($extend variables values env)
 35 |   (cond ((pair? variables)
 36 |          (if (pair? values)
 37 |              ;; grr not tail call
 38 |              (cons (cons (car variables) (car values))
 39 |                    ($extend (cdr variables) (cdr values) env))
 40 |              ($wrong "Too few values" variables)))
 41 |         ((null? variables)
 42 |          (if (null? values)
 43 |              env
 44 |              ($wrong "Too many values" values)))
 45 |         ;; dotted
 46 |         ((symbol? variables) (cons (cons variables values) env))))
 47 | 
 48 | ;; Ground values
 49 | 
 50 | (define $false 'FALSE)
 51 | (define $undef 'UNDEFINED)
 52 | 
 53 | ;; Heeelpers -- not bothered with distinguishing these.
 54 | 
 55 | (define (any-of expr predicates)
 56 |   (if (pair? predicates)
 57 |       (or ((car predicates) expr)
 58 |           (any-of expr (cdr predicates)))
 59 |       #f))
 60 | 
 61 | (define (eval-args args env)
 62 |   (if (pair? args)
 63 |       ;; rely on in-order eval of interpreting language
 64 |       ;; not tail recursive, ugh
 65 |       (cons ($evaluate (car args) env) (eval-args (cdr args) env))
 66 |       '()))
 67 | 
 68 | ;; Evaluate
 69 | 
 70 | (define ($evaluate expr env)
 71 |   ;; WTF: with SISC, (atom? (quote f)) => #f
 72 |   (if (pair? expr)
 73 |       ;; a form!
 74 |       (case (car expr)
 75 |         ((quote) (cadr expr))
 76 |         ((if) (if (not (eq? $FALSE ($evaluate (cadr expr) env)))
 77 |                   ($evaluate (caddr expr) env)
 78 |                   ($evaluate (cadddr expr))) env)
 79 |         ((begin) ($eprogn (cdr expr) env))
 80 |         ((set!) ($update! (cadr expr) ($evaluate (caddr expr) env)))
 81 |         ((lambda) ($make-function (cadr expr) (cddr expr) env))
 82 |         (else ($invoke ($evaluate (car expr) env)
 83 |                        (eval-args (cdr expr) env))))
 84 |       ;; an atom
 85 |       (cond
 86 |         ((symbol? expr)
 87 |          ($lookup expr env))
 88 |         ((any-of expr (list number? string? char? boolean? vector?))
 89 |          expr)
 90 |         (else
 91 |           ($wrong "Cannot evaluate atom" expr)))))
 92 | 
 93 | (define ($eprogn exprs env)
 94 |   (if (pair? exprs)
 95 |       (let ((rest (cdr exprs)))
 96 |         (if (pair? rest)
 97 |             (begin
 98 |               ($evaluate (car exprs) env)
 99 |               ($eprogn rest env))
100 |             ($evaluate (car exprs) env)))
101 |       $undef))
102 | 
103 | (define ($make-function variables body env)
104 |   (lambda values
105 |     ;; A departure: rather than accepting an argument that is the list
106 |     ;; of arguments, expect to be applied to a list of arguments. This
107 |     ;; makes lifting and dropping procedures easier.  However, it
108 |     ;; means an env (e.g., a dynamic env) cannot be passed as well.
109 |     ($eprogn body ($extend variables values env))))
110 | 
111 | (define ($invoke fn values)
112 |   (if (procedure? fn)
113 |       (apply fn values)
114 |       ($wrong "Not a function" fn)))
115 | 
116 | ;; ... and that's our strict, lexically-scoped interpreter.
117 | 
118 | ;; Easy way to run it:
119 | 
120 | (define $env.global $env.init)
121 | 
122 | (define ($def name val)
123 |   (set! $env.global ($extend name val $env.global)))
124 | 
125 | (define (comparison fn) (lambda (vals) (if (fn vals) #t $false)))
126 | ;; This is kind of vestigial, but I may want this later if application
127 | ;; changes.
128 | (define ($fn fn) fn)
129 | 
130 | ($def '< (comparison <))
131 | ($def '> (comparison >))
132 | ($def 'eq? (comparison eq?))
133 | ($def '+ ($fn +))
134 | ($def '- ($fn -))
135 | 
136 | (define (repl)
137 |   (define (toplevel)
138 |     (let ((expr (read)))
139 |       (if (eq? '(exit) expr)
140 |           (display "Exiting")
141 |           (begin
142 |             (display ($evaluate (read) $env.global))
143 |             (toplevel)))))
144 |   (toplevel))
145 | 
146 | ;; arguably the book does this more nicely by capturing the
147 | ;; continuation on invocation of repl and supplying that as the 'end'
148 | ;; function.
149 | 
150 | ;; Exercise 1.1
151 | 
152 | ;; Modify to trace function invocations
153 | (define ($invoke-trace fn args)
154 |   (let ((result (fn args)))
155 |     (display args)(display " => ")(display result)(newline)
156 |     result))
157 | 
158 | (define $invoke-notrace $invoke)
159 | (set! $invoke $invoke-trace)
160 | 
161 | ;; undo ..
162 | (set! $invoke $invoke-notrace)
163 | 
164 | ;; Exercise 1.2
165 | 
166 | ;; Rewrite eval-args to avoid additional recursion
167 | ;; (this is the case everywhere, oh well)
168 | 
169 | (define (eval-args exprs env)
170 |   (if (null? exprs)
171 |       '()
172 |       (if (pair? (cdr exprs))
173 |           (cons ($evaluate (car exprs) env)
174 |                 (eval-exprs (cdr exprs) env))
175 |           (list ($evaluate (car exprs) env)))))
176 | 
177 | ;; From the book's answer: the outer test only needs to be done once.
178 | (define (eval-args exprs env)
179 |   (define (evargs exprs)
180 |     ;; can assume (pair? exprs)
181 |     (if (pair? (cdr exprs))
182 |         (cons ($evaluate (car exprs) env)
183 |               (evargs (cdr exprs)))
184 |         (list ($evaluate (car exprs) env))))
185 |   (if (pair? exprs)
186 |       (evargs exprs)
187 |       '()))
188 | 
189 | ;; Exercise 1.3
190 | 
191 | ;; If we define this:
192 | (define ($extend names values env)
193 |   (cons (cons names values) env))
194 | 
195 | ;; Now reimplement lookup and update!
196 | 
197 | (define ($lookup key env)
198 | 
199 |   (define (lookup* key names values)
200 |     (if (null? names)
201 |         ($lookup key (cdr env))
202 |         (if (eq? (car names) key)
203 |             (car values)
204 |             (lookup* key (cdr names) (cdr values)))))
205 |   
206 |   (if (null? env)
207 |       ($wrong "Lookup failed" key)
208 |       (lookup* key (caar env) (cdar env))))
209 | 
210 | (define ($update key value env)
211 | 
212 |   (define (update* key names values cell)
213 |     (if (null? names)
214 |         ($update key value (cdr env))
215 |         (if (eq? (car names) key)
216 |             (set-cdr! cell (cons value (cdr values)))
217 |             (update* key (cdr names) (cdr values) values))))
218 | 
219 |   (if (null? env)
220 |       ($wrong "Variable not found" key)
221 |       (update* key (caar env) (cdar env) (car env))))
222 | 
223 | ;; Exercise 1.6
224 | 
225 | ;; Define list
226 | 
227 | ($def 'list ($fn list))
228 | ;; NB harder if you used the syntax provided in the book, which checks
229 | ;; arity of defined functions. One would have to do syntax that
230 | ;; avoided that.
231 | 
232 | ;; Exercise 1.7 implement call/cc
233 | 
234 | (define ($evaluate expr env)
235 |   (if (pair? expr)
236 |       ;; a form!
237 |       (case (car expr)
238 |         ((quote) (cadr expr))
239 |         ((if) (if (not (eq? $FALSE ($evaluate (cadr expr) env)))
240 |                   ($evaluate (caddr expr) env)
241 |                   ($evaluate (cadddr expr))) env)
242 |         ((begin) ($eprogn (cdr expr) env))
243 |         ((set!) ($update! (cadr expr) ($evaluate (caddr expr) env)))
244 |         ((lambda) ($make-function (cadr expr) (cddr expr) env))
245 |         ;; OK. Here we have to both lift the interpreted target into a
246 |         ;; meta-lambda, but drop the supplied continuation to an
247 |         ;; object lambda. Luckily, these look the same, since we made
248 |         ;; our object-lambdas applicable in exactly the same way as
249 |         ;; meta-lambdas.
250 |         ((call/cc) (let ((target ($evaluate (cadr expr) env)))
251 |                      (call/cc (lambda (k)
252 |                                 ($invoke target (list k))))))
253 |         (else ($invoke ($evaluate (car expr) env)
254 |                        (eval-args (cdr expr) env))))
255 |       ;; an atom
256 |       (cond
257 |         ((symbol? expr)
258 |          ($lookup expr env))
259 |         ((any-of expr (list number? string? char? boolean? vector?))
260 |          expr)
261 |         (else
262 |           ($wrong "Cannot evaluate atom" expr)))))
263 | 
264 | ;; Exercise 1.8
265 | 
266 | ;; Define apply
267 | 
268 | ($def 'apply ($fn apply))
269 | ;; book answer has more complication, because of its apply convention,
270 | ;; and syntax for defining things. Technically I ought to do more
271 | ;; argument checking; I leave it to the interpreting language.
272 | 


--------------------------------------------------------------------------------
/chapter10.8.ss:
--------------------------------------------------------------------------------
  1 | ;; Implements the compiler to C, using the AST-transforming of
  2 | ;; chapter10.ss and runtime support.
  3 | 
  4 | (load "prelude.ss")
  5 | (load "chapter10.ss")
  6 | 
  7 | ;; The book rejigs some of the environment management; in particular,
  8 | ;; to put program-defined global variables in their own list. I want
  9 | ;; to keep the structure from chapter9.ss, so I'm going to diverge a
 10 | ;; bit on how globals are treated (by keeping it the same as before).
 11 | 
 12 | ;; There are now two distinct phases: the primitives in the runtime
 13 | ;; differ from the primitives at compile time, so I use a distinct
 14 | ;; environment for the top level of evaluator (which is used only for
 15 | ;; expansion).
 16 | 
 17 | (define (compile/C e out)
 18 | 
 19 |   ;; Helpers for finding the "top" of the global environment in an
 20 |   ;; evaluator, and collating the list of globals introduced in the
 21 |   ;; program.
 22 |   (define (global-defs ev)
 23 |     (-> ev :preparation find-global-environment :next))
 24 | 
 25 |   (define (collect-globals r init)
 26 |     (let collect ((g r)
 27 |                   (g* '()))
 28 |       (if (equal? g init) g*
 29 |           (collect (:next g) (cons (:variable g) g*)))))
 30 | 
 31 |   (let* ((ev (create-evaluator/top))
 32 |          ;; Globals defined in the program get put in the environment
 33 |          ;; after the marker (a 'blank' environment) and before the
 34 |          ;; enhanced (with magic-keywords), predefined environment.
 35 |          (g.init (global-defs ev))
 36 |          (prg (-> e ((:expand ev)) transform))
 37 |          (g (collect-globals (global-defs ev) g.init)))
 38 |     (generate-C-program out e prg g)))
 39 | 
 40 | (define g.top (make <environment>))
 41 | (define sg.top '())
 42 | 
 43 | ;; This is an adaption of create-evaluator from chapter9.ss,
 44 | ;; specialised to use the special top-level environments, which
 45 | ;; contain the runtime definitions for primtives. g.predef and
 46 | ;; sg.predef are relegated to compile-time environments.
 47 | (define (create-evaluator/top)
 48 |   (let ((level 'wait)
 49 |         (g g.top)
 50 |         (sg sg.top))
 51 | 
 52 |     (define (expand e)
 53 |       (let ((prg (objectify e (:preparation level))))
 54 |         (enrich-with-new-global-variables! level)
 55 |         prg))
 56 | 
 57 |     (define (eval . _)
 58 |       (compiler-error "No eval at top level"))
 59 | 
 60 |     ;; NB we should not be evaling at this level, so eval gets false
 61 |     (set! level (make <evaluator> #f eval expand))
 62 | 
 63 |     ;; Special forms are always a part of the global env
 64 |     (set! g (r-extend* g *special-form-keywords*))
 65 |     (set! g (r-extend* g (make-macro-environment level)))
 66 | 
 67 |     ;; eval goes in the global env at each level
 68 |     (let ((eval-var (make <predefined-variable>
 69 |                       'eval (make <functional-description> = 1)))
 70 |           (eval-fn (make <runtime-primitive> eval = 1)))
 71 |       (set! g (r-extend g eval-var))
 72 |       (set! sg (sr-extend sg eval-var eval-fn)))
 73 | 
 74 |     (:preparation! level (mark-global-environment g))
 75 |     (:runtime! level (mark-global-runtime-environment sg))
 76 |     level))
 77 | 
 78 | (define (generate-C-program out e p g)
 79 |   (generate-header out e)
 80 |   (generate-global-environment out g)
 81 |   (generate-quotations out (:quotations p))
 82 |   (generate-functions out (:definitions p))
 83 |   (generate-main out (:form p))
 84 |   (generate-trailer out)
 85 |   #;p)
 86 | 
 87 | (define (generate-header out e)
 88 |   (format out "/* Compiler to C ~%")
 89 |   (pretty-print e out)
 90 |   (format out "~%*/~%~%")
 91 |   (format out "#include \"scheme.h\"~%~%"))
 92 | (define (generate-trailer out)
 93 |   (format out "/* End of generated code */~%"))
 94 | 
 95 | ;; === Globals
 96 | 
 97 | (define (generate-global-environment out g*)
 98 |   (for-each (lambda (gv)
 99 |               (generate-global-variable out gv)) g*))
100 | 
101 | (define (generate-global-variable out var)
102 |   (let ((name (:name var)))
103 |     (format out "SCM_DefineGlobalVariable(~A, \"~A\");~%"
104 |             (IdScheme->IdC name) name)))
105 | 
106 | ;; === Quotations
107 | 
108 | (define (generate-quotations out qv*)
109 |   (when (pair? qv*)
110 |         (format out "/* Quotations */~%")
111 |         (scan-quotations out qv* (length qv*) '())))
112 | 
113 | (define (scan-quotations out qv* i results)
114 |   (when (pair? qv*)
115 |         (let* ((qv (car qv*))
116 |                (value (:value qv))
117 |                (other-qv (already-seen-value? value results)))
118 |           (cond (other-qv
119 |                  (generate-quotation-alias out qv other-qv)
120 |                  (scan-quotations out (cdr qv*) i (cons qv results)))
121 |                 ((C-value? value)
122 |                  (generate-C-value out qv)
123 |                  (scan-quotations out (cdr qv*) i (cons qv results)))
124 |                 ((symbol? value)
125 |                  (scan-symbol out value qv* i results))
126 |                 ((pair? value)
127 |                  (scan-pair out value qv* i results))))))
128 | 
129 | (define (already-seen-value? v qv*)
130 |   (and (pair? qv*)
131 |        (if (equal? v (:value (car qv*))) (car qv*)
132 |            (already-seen-value? v (cdr qv*)))))
133 | 
134 | ;; (Remember that the name of a quotation variable is an index)
135 | (define (generate-quotation-alias out q1 q2)
136 |   (format out "#define thing~A thing~A /* ~S */~%"
137 |           (:name q1) (:name q2) (:value q2)))
138 | 
139 | ;; Immediate values, that is values that can directly represented in C
140 | 
141 | ;; This is machine specific no?
142 | (define *max-fixnum* 16384)
143 | (define *min-fixnum* (- *max-fixnum*))
144 | 
145 | (define (C-value? v)
146 |   (or (null? v)
147 |       (boolean? v)
148 |       (and (integer? v)
149 |            (< *min-fixnum* v *max-fixnum*))
150 |       (string? v)))
151 | (define (generate-C-value out qv)
152 |   (let ((value (:value qv))
153 |         (index (:name qv)))
154 |     (cond ((null? value)
155 |            (format out "#define thing~A SCM_nil /* () */~%" index))
156 |           ((boolean? value)
157 |            (format out "#define thing~A ~A /* ~S */~%" index
158 |                    (if value "SCM_true" "SCM_false") value))
159 |           ((integer? value)
160 |            (format out "#define thing~A SCM_Int2fixnum(~A)~%"
161 |                    index value))
162 |           ((string? value)
163 |            (format out "SCM_DefineString(thing~A_object, \"~A\");~%"
164 |                    index value)
165 |            (format out "#define thing~A SCM_Wrap(&thing~A_object)~%"
166 |                    index index)))))
167 | 
168 | ;; Make a symbol out of an existing string
169 | (define (scan-symbol out value qv* i results)
170 |   (let* ((qv (car qv*))
171 |          (str (symbol->string value))
172 |          (strqv (already-seen-value? str results)))
173 |     (cond (strqv (generate-symbol out qv strqv)
174 |                  (scan-quotations out (cdr qv*) i (cons qv results)))
175 |           (else
176 |            (let ((newqv (make <quotation-variable> i str)))
177 |              (scan-quotations out (cons newqv qv*) (+ i 1) results))))))
178 | 
179 | (define (generate-symbol out qv strqv)
180 |   (format out "SCM_DefineSymbol(thing~A_object, thing~A); /* ~S */~%"
181 |           (:name qv) (:name strqv) (:value qv))
182 |   (format out "#define thing~A SCM_Wrap(&thing~A_object)~%"
183 |           (:name qv) (:name qv)))
184 | 
185 | (define (scan-pair out value qv* i results)
186 |   (let* ((qv (car qv*))
187 |          (d (cdr value))
188 |          (dqv (already-seen-value? d results)))
189 |     (if dqv
190 |         (let* ((a (car value))
191 |                (aqv (already-seen-value? a results)))
192 |           (if aqv
193 |               (begin
194 |                 (generate-pair out qv aqv dqv)
195 |                 (scan-quotations out (cdr qv*) i (cons qv results)))
196 |               (let ((newaqv (make <quotation-variable> i a)))
197 |                 (scan-quotations out (cons newaqv qv*) (+ i 1) results))))
198 |         ;; cdr not seen
199 |         (let ((newdqv (make <quotation-variable> i d)))
200 |           (scan-quotations out (cons newdqv qv*) (+ i 1) results)))))
201 | 
202 | (define (generate-pair out qv aqv dqv)
203 |   (format out
204 |           "SCM_DefinePair(thing~A_object, thing~A, thing~A) /* ~S */~%"
205 |           (:name qv) (:name aqv) (:name dqv) (:value qv))
206 |   (format out "#define thing~A SCM_Wrap(&thing~A_object)~%"
207 |           (:name qv) (:name qv)))
208 | 
209 | 
210 | ;; === Programs
211 | 
212 | (define-generics ->C)
213 | 
214 | (define <output-port> <character-output-port>)
215 | 
216 | (define-method (->C (<program> p) (<output-port> out))
217 |   (error (list "->C unimplemented for " (class-name (type-of p)))))
218 | 
219 | ;; Lots of things will need parens to disambiguate
220 | (define-syntax in-parens
221 |   (syntax-rules ()
222 |     ((_ out . body)
223 |      (let ((out out))
224 |        (format out "(")
225 |        (begin . body)
226 |        (format out ")")))))
227 | 
228 | ;; References and variables get compiled, in general, to C variables.
229 | (define-method (->C (<reference> ref) (<output-port> out))
230 |   (reference->C (:variable ref) out))
231 | 
232 | ;; default implementations; there's two layers of specialisation.
233 | (define-generics reference->C variable->C)
234 | (define-method (reference->C (<variable> v) (<output-port> out))
235 |   (variable->C v out))
236 | (define-method (variable->C (<variable> v) (<output-port> out))
237 |   (format out (IdScheme->IdC (:name v))))
238 | 
239 | (define-method (variable->C (<renamed-variable> v) (<output-port> out))
240 |   (format out "~A_~A" (IdScheme->IdC (:name v)) (:index v)))
241 | (define-method (variable->C (<quotation-variable> v) (<output-port> out))
242 |   (format out "thing~A" (:name v)))
243 | 
244 | (define-method (reference->C (<global-variable> v) (<output-port> out))
245 |   (format out "SCM_CheckedGlobal")
246 |   (in-parens out (variable->C v out)))
247 | 
248 | (define-method (->C (<free-reference> ref) (<output-port> out))
249 |   (format out "SCM_Free")
250 |   (in-parens out (variable->C (:variable ref) out)))
251 | 
252 | ;; Assignments: to globals, and box writes
253 | 
254 | (define-method (->C (<global-assignment> e) (<output-port> out))
255 |   (in-parens out
256 |              (variable->C (:variable e) out)
257 |              (format out "=")
258 |              (->C (:form e) out)))
259 | 
260 | (define-method (->C (<box-read> r) (<output-port> out))
261 |   (format out "SCM_Content")
262 |   (in-parens out (->C (:reference r) out)))
263 | 
264 | (define-method (->C (<box-write> w) (<output-port> out))
265 |   (format out "SCM_Content")
266 |   (in-parens out (->C (:reference w) out))
267 |   (format out "=")
268 |   (->C (:form w) out))
269 | 
270 | (define-method (->C (<box-creation> c) (<output-port> out))
271 |   (variable->C (:variable c) out)
272 |   (format out "= SCM_allocate_box")
273 |   (in-parens out (variable->C (:variable c) out)))
274 | 
275 | ;; If
276 | 
277 | (define-generics boolean->C)
278 | 
279 | (define-method (->C (<alternative> a) (<output-port> out))
280 |   ;; The condition must be coerced to a boolean
281 |   (in-parens out (boolean->C (:condition a) out)
282 |              (format out "?~%")
283 |              (->C (:consequent a) out)
284 |              (format out ":~%")
285 |              (->C (:alternant a) out)))
286 | 
287 | (define-method (boolean->C (<program> e) (<output-port> out))
288 |   (in-parens out (->C e out)
289 |              (format out " != SCM_false")))
290 | 
291 | ;; Sequences
292 | 
293 | (define-method (->C (<sequence> seq) (<output-port> out))
294 |   (in-parens out (->C (:first seq) out)
295 |              (format out ",~%")
296 |              (->C (:last seq) out)))
297 | 
298 | ;; === Function applications
299 | ;; Here is where it gets fun.
300 | 
301 | ;; Predefined procedures with fixed arity get inlined (see ->C at
302 | ;; <predefined-application>). There are a handful of predefined
303 | ;; procedures that have varargs, and these are initialised as
304 | ;; variables, but not given descriptions (so they're not inlined, but
305 | ;; invoked like a "normal" closure).
306 | 
307 | (define-method (->C (<regular-application> a) (<output-port> out))
308 |   (let ((n (number-of (:arguments a))))
309 |     (cond ((< n 4)
310 |            (format out "SCM_invoke~A" n)
311 |            (in-parens out
312 |                       (->C (:function a) out)
313 |                       (->C (:arguments a) out)))
314 |           (else
315 |            (format out "SCM_invoke")
316 |            (in-parens out
317 |                       (->C (:function a) out)
318 |                       (format out ",~A" n)
319 |                       (->C (:arguments a) out))))))
320 | 
321 | (define-method (->C (<fix-let> f) (<output-port> out))
322 |   (in-parens out
323 |              (bindings->C (:variables f) (:arguments f) out)
324 |              (->C (:body f) out)))
325 | 
326 | (define-generics bindings->C)
327 | (define-method (bindings->C (<list> vars)
328 |                             (<some-arguments> args)
329 |                             (<output-port> out))
330 |   (variable->C (car vars) out)(format out "=")
331 |   (->C (:first args) out)(format out ",~%")
332 |   (bindings->C (cdr vars) (:others args) out))
333 | (define-method (bindings->C (<list> vars)
334 |                             (<no-argument> _)
335 |                             (<output-port> out))
336 |   (format out "")) ;; Ummmmm
337 | 
338 | (define-method (->C (<predefined-application> a) (<output-port> out))
339 |   (-> a :variable :description :generator
340 |       (apply (list a out))))
341 | 
342 | (define (make-predef-generator Cname)
343 |   (lambda (e out)
344 |     (format out "~A" Cname)
345 |     (in-parens out (arguments->C (:arguments e) out))))
346 | 
347 | 
348 | ;; For use by the inline generators. Note the second call, not to
349 | ;; arguments->C but to ->C
350 | (define-generics arguments->C)
351 | (define-method (arguments->C (<some-arguments> args) (<output-port> out))
352 |   (->C (:first args) out)
353 |   (->C (:others args) out))
354 | (define-method (arguments->C (<no-argument> _) (<output-port> out))
355 |   #t)
356 | (define-method (->C (<some-arguments> args) (<output-port> out))
357 |   (format out ",~%")
358 |   (->C (:first args) out)
359 |   (->C (:others args) out))
360 | (define-method (->C (<no-argument> _) (<output-port> out))
361 |   #t)
362 | 
363 | ;; === Creating functions
364 | 
365 | (define-method (->C (<closure-creation> c) (<output-port> out))
366 |   (format out "SCM_close")
367 |   (in-parens out
368 |              (format out "SCM_CfunctionAddress(function_~A), ~A, ~A"
369 |                      (:index c)
370 |                      (generate-arity (:variables c))
371 |                      (number-of (:free c)))
372 |              (->C (:free c) out)))
373 | 
374 | (define-method (number-of (<no-free> _)) 0)
375 | (define-method (number-of (<some-free> f))
376 |   (+ 1 (number-of (:others f))))
377 | 
378 | (define (generate-arity vars)
379 |   (let count ((vars vars) (arity 0))
380 |     (if (pair? vars)
381 |         (if (:dotted? (car vars))
382 |             (- (+ arity 1))
383 |             (count (cdr vars) (+ 1 arity)))
384 |         arity)))
385 | 
386 | (define-method (->C (<no-free> _) (<output-port> out))
387 |   #t)
388 | (define-method (->C (<some-free> f) (<output-port> out))
389 |   (format out ",~%")
390 |   (->C (:first f) out)
391 |   (->C (:others f) out))
392 | 
393 | ;; === Function definitions
394 | 
395 | (define (generate-functions out definitions)
396 |   (format out "~%/* Functions */~%")
397 |   (for-each (lambda (def)
398 |               (generate-closure-structure out def)
399 |               (generate-possibly-dotted-def out def))
400 |             (reverse definitions)))
401 | 
402 | (define (generate-closure-structure out def)
403 |   (format out "SCM_DefineClosure(function_~A, "
404 |           (:index def))
405 |   (generate-local-temporaries out (:free def))
406 |   (format out ");~%"))
407 | 
408 | ;; NB book has inconsistent order of args here. I've corrected it.
409 | (define (generate-possibly-dotted-def out def)
410 |   (format out "~%SCM_DeclareFunction(function_~A) {~%"
411 |           (:index def))
412 |   (let ((vars (:variables def))
413 |         (rank -1))
414 |     ;; this is kind of a gross way to do it
415 |     (for-each (lambda (v)
416 |                 (set! rank (+ rank 1))
417 |                 (cond ((:dotted? v)
418 |                        (format out "SCM_DeclareDottedVariable("))
419 |                       ((instance-of? v <variable>)
420 |                        (format out "SCM_DeclareVariable(")))
421 |                 (variable->C v out)
422 |                 (format out ",~A);~%" rank))
423 |               vars)
424 |     (let ((temps (:temporaries def)))
425 |       (when (pair? temps)
426 |             (generate-local-temporaries out temps)
427 |             (format out "~%")))
428 |     (format out "return ")
429 |     (->C (:body def) out)
430 |     (format out ";~%}~%~%")))
431 | 
432 | (define (generate-local-temporaries out temps)
433 |   (when (pair? temps)
434 |         (format out "SCM ")
435 |         (variable->C (car temps) out)
436 |         (format out "; ")
437 |         (generate-local-temporaries out (cdr temps))))
438 | 
439 | ;; === Main
440 | 
441 | (define (generate-main out form)
442 |   (format out "~%/* Expression: */~%")
443 |   (format out "int main(void) {~%")
444 |   (format out "  SCM_print")
445 |   (in-parens out (->C form out))
446 |   (format out ";~%  exit(0);~%}~%"))
447 | 
448 | ;; === Definining primitives
449 | 
450 | ;; In chapter9 I left the generator field alone; now I want to use it,
451 | ;; so, define another initialize.
452 | (define-method (initialize (<functional-description> self)
453 |                            (<procedure> comp)
454 |                            (<number> arity)
455 |                            (<procedure> gen))
456 |   (init* self :comparator! comp :arity! arity :generator! gen))
457 | 
458 | ;; We only inline things with fixed arity. Primitives with varargs are
459 | ;; treated as predefined variables, i.e., follow the invocation
460 | ;; protocol rather than being inlined.
461 | (define-syntax def-runtime
462 |   (syntax-rules ()
463 |     ((_ name Cname arity)
464 |      (let ((v (make <predefined-variable> 'name
465 |                     (make <functional-description> = arity
466 |                           (make-predef-generator 'Cname)))))
467 |        (set! g.top (make <full-environment> v g.top))
468 |        ;; Doesn't need to be in sg, because there's no eval at the top
469 |        ;; level
470 |        'name))))
471 | 
472 | (define-syntax def-runtime-primitive
473 |   (syntax-rules ()
474 |     ((_ name Cname arity)
475 |      (let ((v (make <predefined-variable>
476 |                 'name
477 |                 (make <functional-description>
478 |                   = arity
479 |                   (make-predef-generator 'Cname)))))
480 |        (set! g.top (r-extend g.top v))
481 |        'name))))
482 | 
483 | (def-runtime-primitive cons "SCM_cons" 2)
484 | (def-runtime-primitive car "SCM_car" 1)
485 | (def-runtime-primitive + "SCM_Plus" 2)
486 | (def-runtime-primitive = "SCM_EqnP" 2)
487 | (def-runtime-primitive null? "SCM_nullp" 1)
488 | (def-runtime-primitive pair? "SCM_consp" 1)
489 | (def-runtime-primitive eq? "SCM_eqp" 2)
490 | 
491 | ;; `(list ...)` isn't fixed arity, so it can't be inlined in the same
492 | ;; way as those above. However, it's added to the global environment,
493 | ;; and defined as a procedure in the runtime. Giving a 'blank'
494 | ;; description here keeps the expander from making this a
495 | ;; predefined-application (way back in chapter9.ss). Similarly
496 | ;; `apply`.
497 | (begin
498 |   (set! g.top
499 |         (r-extend* g.top (map (lambda (name)
500 |                                 (make <predefined-variable> name
501 |                                       (make <description>)))
502 |                               '(list apply)))))
503 | 
504 | (begin (set! g.top (mark-global-environment g.top)))
505 | 
506 | ;; Test hook
507 | 
508 | (import os)
509 | 
510 | (define (eval-expr expr)
511 |   (call-with-output-file "test.c"
512 |     (lambda (out) (compile/C expr out)))
513 |   (let* ((gcc (spawn-process
514 |                "gcc" (list "-otest" "test.c" "scheme.c" "primitives.c")))
515 |          (err (get-process-stderr gcc))
516 |          (res (wait-for-process gcc)))
517 |     (if (= res 0)
518 |         (let* ((test (spawn-process "./test"))
519 |                (in (open-character-input-port (get-process-stdout test)))
520 |                (err (get-process-stderr test))
521 |                (res (wait-for-process test)))
522 |           (if (= res 0)
523 |               (let ((output (with-input-from-port in (lambda () (read)))))
524 |                 output)
525 |               (error `("Test program reported an error" ,res ,(read-lines err)))))
526 |         (error `("Test program did not compile" ,res ,(read-lines err))))))
527 | 
528 | (define (read-lines binport)
529 |   (let ((chars (open-character-input-port binport)))
530 |     (let loop ((line '())
531 |                (lines '()))
532 |       (let ((char (read-char chars)))
533 |         (cond ((eof-object? char)
534 |                (reverse (cons (apply string (reverse line)) lines)))
535 |               ((eq? char #\n)
536 |                (loop '() (cons (apply string (reverse line)) lines)))
537 |               (else (loop (cons char line) lines)))))))
538 | 
539 | ;; === Converting Scheme names to C names
540 | 
541 | ;; I've just copied this from the book code, as you'll be able to tell
542 | ;; from the funny paren-style
543 | (define Scheme->C-names-mapping
544 |   '( (*        . "TIMES")
545 |      (+        . "PLUS")
546 |      (-        . "DIFFERENCE")
547 |      (/        . "QUOTIENT")
548 |      (>        . "GREATERP")
549 |      (>=       . "NOT_LESSP")
550 |      (<        . "LESSP")
551 |      (<=       . "NOT_GREATERP")
552 |      (=        . "EQN")
553 |      (eq?      . "EQ")
554 |      (pair?    . "CONSP")
555 |      (null?    . "NULLP")
556 |      (symbol?  . "SYMBOLP")
557 |      (set-car! . "RPLACA")
558 |      (set-cdr! . "RPLACD")
559 |      ) )
560 | 
561 | (define (IdScheme->IdC name)
562 |   (let ((v (assq name Scheme->C-names-mapping)))
563 |     (if (pair? v) (cdr v)
564 |         (let ((str (symbol->string name)))
565 |           (let retry ((Cname (compute-Cname str)))
566 |             (if (Cname-clash? Cname Scheme->C-names-mapping)
567 |                 (retry (compute-another-Cname str))
568 |                 (begin (set! Scheme->C-names-mapping
569 |                              (cons (cons name Cname)
570 |                                    Scheme->C-names-mapping ) )
571 |                        Cname ) ) ) ) ) ) )
572 | 
573 | (define (Cname-clash? Cname mapping)
574 |   (let check ((mapping mapping))
575 |     (and (pair? mapping)
576 |          (or (string=? Cname (cdr (car mapping)))
577 |              (check (cdr mapping)) ) ) ) )
578 | 
579 | ;;; These functions compute a C name for a symbol. Scheme symbols
580 | ;;; cannot be transleted into a name containing an isolated underscore
581 | ;;; so all these names will be used for C generation purposes.
582 | 
583 | (define compute-another-Cname
584 |   (let ((counter 1))
585 |     (lambda (str)
586 |       (set! counter (+ 1 counter))
587 |       (compute-Cname (format #f "~A_~A" str counter)) ) ) )
588 | 
589 | (define (compute-Cname str)
590 |   (define (mapcan f l)
591 |     (if (pair? l)
592 |         (append (f (car l)) (mapcan f (cdr l)))
593 |         '() ) )
594 |   (define (convert-char char)
595 |     (case char
596 |       ((#\_)             '(#\_ #\_))
597 |       ((#\?)             '(#\p))
598 |       ((#\!)             '(#\i))
599 |       ((#\<)             '(#\l))
600 |       ((#\>)             '(#\g))
601 |       ((#\=)             '(#\e))
602 |       ((#\- #\/ #\* #\:) '())
603 |       (else              (list char)) ) )
604 |   (let ((cname (mapcan convert-char (string->list str))))
605 |     (if (pair? cname) (list->string cname) "weird") ) )
606 | 


--------------------------------------------------------------------------------
/chapter10.ss:
--------------------------------------------------------------------------------
  1 | ;; This compiler uses the expander of the previous (and the
  2 | ;; 'objectification'), then walks the resulting object tree and emits
  3 | ;; C.
  4 | 
  5 | (load "chapter9.ss")
  6 | 
  7 | ;; We start by making a code walker: it'll visit each subprogram and
  8 | ;; thereby construct a new program.
  9 | 
 10 | 
 11 | ;; I'm going to take a slightly different route to the book, by
 12 | ;;  1. using a generic procedure to pick the fields to visit, rather
 13 | ;;  than reflection; this requires a (fairly simple) implementation of
 14 | ;;  the procedure for each class;
 15 | ;;  2. constructing a new tree rather than setting fields
 16 | ;;
 17 | ;; The supplied procedure gets to see each subprogram first; if it
 18 | ;; chooses to walk the subprogram (i.e., it's not of interest, but
 19 | ;; sub-sub-programs might be) then each program-like field will be
 20 | ;; examined.
 21 | ;;
 22 | ;; As we'll see, the supplied procedure will *also* be a generic
 23 | ;; procedure, with a default implementation that just calls walk, and
 24 | ;; specialised implementations that recurse into fields explicitly.
 25 | (define (walk fun program . args)
 26 |   (visit program (if (null? args)
 27 |                      fun
 28 |                      (lambda (p) (apply fun p args)))))
 29 | 
 30 | (define-generics visit)
 31 | 
 32 | ;; Some programs don't have any fields that are programs; stop walking
 33 | (define-method (visit (<program> p)
 34 |                       (<procedure> f))
 35 |   p)
 36 | 
 37 | (define-method (visit (<global-assignment> assign)
 38 |                       (<procedure> fun))
 39 |   (make <global-assignment> (:variable assign)
 40 |         (fun (:form assign))))
 41 | (define-method (visit (<local-assignment> assign)
 42 |                       (<procedure> fun))
 43 |   (make <local-assignment> (fun (:reference assign))
 44 |         (fun (:form assign))))
 45 | (define-method (visit (<function> f)
 46 |                       (<procedure> fun))
 47 |   (make <function> (:variables f)
 48 |         (fun (:body f))))
 49 | (define-method (visit (<alternative> alt)
 50 |                       (<procedure> fun))
 51 |   (make <alternative> (fun (:condition alt))
 52 |         (fun (:consequent alt))
 53 |         (fun (:alternant alt))))
 54 | (define-method (visit (<sequence> seq)
 55 |                       (<procedure> fun))
 56 |   (make <sequence> (fun (:first seq))
 57 |         (fun (:last seq))))
 58 | (define-method (visit (<some-arguments> args)
 59 |                       (<procedure> fun))
 60 |   (make <some-arguments> (fun (:first args))
 61 |         (fun (:others args))))
 62 | (define-method (visit (<regular-application> app)
 63 |                       (<procedure> fun))
 64 |   (make <regular-application>
 65 |     (fun (:function app)) (fun (:arguments app))))
 66 | (define-method (visit (<predefined-application> app)
 67 |                       (<procedure> fun))
 68 |   (make <predefined-application> (:variable app)
 69 |         (fun (:arguments app))))
 70 | (define-method (visit (<fix-let> fix)
 71 |                       (<procedure> fun))
 72 |   (make <fix-let> (:variables fix)
 73 |         (fun (:arguments fix))
 74 |         (fun (:body fix))))
 75 | 
 76 | ;; Here's the canonical example of a walker:
 77 | (define-generics identity)
 78 | (define-method (identity (<program> p)) (walk identity p))
 79 | 
 80 | ;; === Using boxes for mutable variables
 81 | 
 82 | (define-generics insert-boxes)
 83 | 
 84 | (define-method (insert-boxes (<program> p))
 85 |   (walk insert-boxes p))
 86 | 
 87 | ;; A few more classes to represent box reads, writes, and the creation
 88 | ;; of boxes.
 89 | (define-class (<box-read> <program>)
 90 |   (reference :reference :reference!))
 91 | (define-method (initialize (<box-read> self)
 92 |                            (<reference> ref))
 93 |   (init* self :reference! ref))
 94 | (define-method (visit (<box-read> read)
 95 |                       (<procedure> fun))
 96 |   (make <box-read> (fun (:reference read))))
 97 | 
 98 | (define-class (<box-write> <program>)
 99 |   (reference :reference :reference!)
100 |   (form :form :form!))
101 | (define-method (initialize (<box-write> self)
102 |                            (<reference> ref)
103 |                            (<program> form))
104 |   (init* self :reference! ref :form! form))
105 | (define-method (visit (<box-write> write)
106 |                       (<procedure> fun))
107 |   (make <box-write> (fun (:reference write))
108 |         (fun (:form write))))
109 | 
110 | (define-class (<box-creation> <program>)
111 |   (variable :variable :variable!))
112 | (define-method (initialize (<box-creation> self)
113 |                            (<variable> var))
114 |   (init* self :variable! var))
115 | 
116 | ;; And now for the specialisations that we care about:
117 | (define-method (insert-boxes (<local-reference> ref))
118 |   (if (:mutable? (:variable ref))
119 |       (make <box-read> ref)
120 |       ref))
121 | 
122 | ;; Rewrite assignments to locals as box-writes. Note that I don't use
123 | ;; walk, because I'm recursing on a field that I know is a program;
124 | ;; that's going to be the case in general.
125 | (define-method (insert-boxes (<local-assignment> set))
126 |   (make <box-write> (:reference set) (insert-boxes (:form set))))
127 | 
128 | (define-method (insert-boxes (<function> f))
129 |   (let ((body (boxify-mutable-variables (:body f)
130 |                                         (:variables f))))
131 |     (make <function> (:variables f) (insert-boxes body))))
132 | 
133 | (define-method (insert-boxes (<fix-let> f))
134 |   (let ((body (boxify-mutable-variables (:body f)
135 |                                         (:variables f)))
136 |         (args (insert-boxes (:arguments f))))
137 |     (make <fix-let> (:variables f) args (insert-boxes body))))
138 | 
139 | (define (boxify-mutable-variables body vars)
140 |   (if (pair? vars)
141 |       (if (:mutable? (car vars))
142 |           (boxify-mutable-variables
143 |            (make <sequence> (make <box-creation> (car vars)) body) (cdr vars))
144 |           (boxify-mutable-variables body (cdr vars)))
145 |       body))
146 | 
147 | 
148 | ;; === Lambda-lifting
149 | 
150 | ;; This transforms abstractions in-place, from those closing over free
151 | ;; variables to those taking a flattened, free (variable) environment
152 | ;; as well as their arguments. Subsequent transformations will bubble
153 | ;; these up to the top of the program.
154 | 
155 | ;; The entry point
156 | (define (lambda-lift p)
157 |   (lift-procedures p #f '()))
158 | 
159 | ;; Classes to represent functions with flattened environments.
160 | 
161 | ;; Same abstract super thing here as for <arguments>
162 | (define-class (<free-environment> <program>))
163 | 
164 | (define-generics :free :free!)
165 | (define-class (<flat-function> <function>)
166 |   (free :free :free!))
167 | (define-method (initialize (<flat-function> self)
168 |                            (<list> vars)
169 |                            (<program> body)
170 |                            (<free-environment> free))
171 |   (init* self :variables! vars :body! body :free! free))
172 | (define-method (visit (<flat-function> f)
173 |                       (<procedure> fun))
174 |   (make <flat-function> (:variables f)
175 |         (fun (:body f)) (fun (:free f))))
176 | 
177 | (define-class (<some-free> <free-environment>)
178 |   (first :first :first!)
179 |   (others :others :others!))
180 | (define-method (initialize (<some-free> self)
181 |                            (<program> first)
182 |                            (<free-environment> others))
183 |   (init* self :first! first :others! others))
184 | (define-method (visit (<some-free> env)
185 |                       (<procedure> fun))
186 |   (make <some-free> (fun (:first env)) (fun (:others env))))
187 | 
188 | (define-class (<no-free> <free-environment>))
189 | 
190 | ;; Slight difference to the book, so that it can inherit the
191 | ;; implementation of evaluate.
192 | (define-class (<free-reference> <local-reference>))
193 | 
194 | (define-generics lift-procedures)
195 | 
196 | (define-method (lift-procedures (<program> p)
197 |                                 (<value> f) ; <flat-function> | #f
198 |                                 (<list> vars))
199 |   (walk lift-procedures p f vars))
200 | 
201 | ;; If a local reference is not in the var list for this abstraction,
202 | ;; it's free, so put it in the free-environment and replace it with a
203 | ;; free-reference. I use a bit of mutation here, but it operates only
204 | ;; on things created during the tree walk.
205 | (define-method (lift-procedures (<local-reference> ref)
206 |                                 (<value> f) ; <flat-function> | #f
207 |                                 (<list> vars))
208 |   (let ((v (:variable ref)))
209 |     (if (memq v vars)
210 |         ref
211 |         (begin
212 |           (adjoin-free-variable! f ref)
213 |           (make <free-reference> v)))))
214 | ;; Add a free variable to the free-environment if it's not there
215 | ;; already
216 | (define (adjoin-free-variable! flat ref)
217 |   (when (instance-of? flat <flat-function>)
218 |         (let check ((free* (:free flat)))
219 |           (if (instance-of? free* <no-free>)
220 |               (:free! flat (make <some-free> ref (:free flat)))
221 |               (unless (eq? (:variable ref)
222 |                            (:variable (:first free*)))
223 |                       (check (:others free*)))))))
224 | 
225 | (define-method (lift-procedures (<fix-let> fix)
226 |                                 (<value> f)
227 |                                 (<list> vars))
228 |   (let ((newvars (append (:variables fix) vars)))
229 |     (make <fix-let> (:variables fix)
230 |           (lift-procedures (:arguments fix) f vars)
231 |           (lift-procedures (:body fix) f newvars))))
232 | 
233 | ;; Again, a bit of mutation, because we construct the flat-fun with
234 | ;; the 'original' body as a placeholder, then process the body with
235 | ;; itself as the container for the free-environment, *then* process
236 | ;; the free environment of the new abstraction (which now contains the
237 | ;; vars free in that abstraction) in terms of the surrounding
238 | ;; abstraction, to collect those vars already free outside the new
239 | ;; abstraction.
240 | (define-method (lift-procedures (<function> fun)
241 |                                 (<value> f)
242 |                                 (<list> vars))
243 |   (let* ((localvars (:variables fun))
244 |          (body (:body fun))
245 |          (newf (make <flat-function> localvars body (make <no-free>))))
246 |     (:body! newf (lift-procedures body newf localvars))
247 |     ;; reprocess the free variables in terms of the current abstraction
248 |     (:free! newf (lift-procedures (:free newf) f vars))
249 |     newf))
250 | 
251 | ;; === Collect quotations and functions
252 | 
253 | (define-generics :quotations :quotations! :definitions :definitions!)
254 | 
255 | (define-class (<flat-program> <program>)
256 |   (form :form :form!)
257 |   (quotations :quotations :quotations!)
258 |   (definitions :definitions :definitions!))
259 | (define-method (initialize (<flat-program> self)
260 |                            (<program> form)
261 |                            (<list> quotes)
262 |                            (<list> defs))
263 |   (init* self :form! form :quotations! quotes :definitions! defs))
264 | (define-method (visit (<flat-program> flat)
265 |                       (<procedure> fun))
266 |   (make <flat-program> (:quotes flat)
267 |         (map fun (:definitions flat))))
268 | 
269 | ;; NB uses the `name` slot to store the index
270 | (define-class (<quotation-variable> <variable>)
271 |   (value :value :value!))
272 | (define-method (initialize (<quotation-variable> self)
273 |                            (<number> index)
274 |                            (<value> value))
275 |   (init* self :name! index :value! value))
276 | ;; I have my own class so I can distinguish them when evaluating
277 | (define-class (<quotation-reference> <global-reference>))
278 | 
279 | ;; An extracted, lifted lambda. NB 'free' is *not* a free environment
280 | ;; here, but merely a list of variables free in the body.
281 | (define-generics :index :index!)
282 | (define-class (<function-definition> <flat-function>)
283 |   (index :index :index!))
284 | (define-method (initialize (<function-definition> self)
285 |                            (<list> vars)
286 |                            (<program> body)
287 |                            (<list> free)
288 |                            (<number> index))
289 |   (init* self :variables! vars :body! body :free! free :index! index))
290 | (define-method (visit (<function-definition> def)
291 |                       (<procedure> fun))
292 |   (make <function-definition>
293 |     (:variables def) (fun (:body def)) (:free def) (:index def)))
294 | 
295 | ;; This will now stand in for abstractions that have been lifted; now
296 | ;; we inherit the free var environment from the flat-function, but
297 | ;; refer to the function definition.
298 | (define-class (<closure-creation> <program>)
299 |   (index :index :index!)
300 |   (variables :variables :variables!)
301 |   (free :free :free!))
302 | (define-method (initialize (<closure-creation> self)
303 |                            (<number> index)
304 |                            (<list> vars)
305 |                            (<free-environment> free))
306 |   (init* self :index! index :variables! vars :free! free))
307 | (define-method (visit (<closure-creation> c)
308 |                       (<procedure> fun))
309 |   (make <closure-creation> (:index c) (:variables c)
310 |         (fun (:free c))))
311 | 
312 | ;; Now the entry point. Again, this uses mutation on something created
313 | ;; for the transformation. The reason is similar to above, we need to
314 | ;; create both a reference and the container to collect things into.
315 | (define (extract-things p)
316 |   (let ((result (make <flat-program> p '() '())))
317 |     (:form! result (extract p result))
318 |     result))
319 | 
320 | (define-generics extract)
321 | 
322 | (define-method (extract (<program> p)
323 |                         (<flat-program> top))
324 |   (walk extract p top))
325 | 
326 | (define-method (extract (<constant> c)
327 |                         (<flat-program> top))
328 |   (let* ((qv* (:quotations top))
329 |          (qv (make <quotation-variable> (length qv*) (:value c))))
330 |     (:quotations! top (cons qv qv*))
331 |     (make <quotation-reference> qv)))
332 | 
333 | (define-method (extract (<flat-function> f)
334 |                         (<flat-program> top))
335 |   ;; First construct a new flat-function given what we know
336 |   (let* ((newbody (extract (:body f) top))
337 |          (vars (:variables f))
338 |          (freevars (let extr ((free (:free f)))
339 |                      (if (instance-of? free <some-free>)
340 |                          (cons (:variable (:first free))
341 |                                (extr (:others free)))
342 |                          '())))
343 |          (index (adjoin-definition! top vars newbody freevars)))
344 |     (make <closure-creation> index vars (:free f))))
345 | 
346 | (define (adjoin-definition! top vars body free)
347 |   (let* ((defs (:definitions top))
348 |          (newindex (length defs)))
349 |     (:definitions!
350 |      top
351 |      (cons (make <function-definition> vars body free newindex)
352 |            defs))
353 |     newindex))
354 | 
355 | ;; Lastly, the wole program gets made into a thunk. (I like this name
356 | ;; better than that of the book)
357 | (define (thunkify-main top)
358 |   (let ((index (length (:definitions top))))
359 |     (make <flat-program>
360 |       (make <regular-application>
361 |         (make <closure-creation> index '() (make <no-free>))
362 |         (make <no-argument>))
363 |       (:quotations top)
364 |       (cons (make <function-definition>
365 |               '() (:form top) '() index)
366 |             (:definitions top)))))
367 | 
368 | ;; === Collect temporaries
369 | 
370 | ;; We want to convert fix-let forms into blocks with local variables;
371 | ;; but C does not have nested local scopes, so we have to rename any
372 | ;; variables that would otherwise conflict.
373 | 
374 | (define-generics :temporaries :temporaries!)
375 | (define-class (<with-temp-function-definition> <function-definition>)
376 |   (temporaries :temporaries :temporaries!))
377 | (define-method (initialize (<with-temp-function-definition> self)
378 |                            (<list> vars)
379 |                            (<program> body)
380 |                            (<list> free)
381 |                            (<number> index)
382 |                            (<list> temporaries))
383 |   (init* self
384 |          :variables! vars :body! body
385 |          :free! free :index! index
386 |          :temporaries! temporaries))
387 | (define-method (visit (<with-temp-function-definition> def)
388 |                       (<procedure> fun))
389 |   (make <with-temp-function-definition>
390 |     (:variables def)
391 |     (fun (:body def))
392 |     (:free def)
393 |     (:index def)
394 |     (:temporaries def)))
395 | 
396 | (define (gather-temporaries p)
397 |   (make <flat-program>
398 |     ;; form quotes defs
399 |     (:form p) (:quotations p)
400 |     (map (lambda (def)
401 |            (let* ((holder (make <with-temp-function-definition>
402 |                             (:variables def)
403 |                             (:body def)
404 |                             (:free def)
405 |                             (:index def)
406 |                             '()))
407 |                   (fresh
408 |                    (collect-temporaries holder holder '())))
409 |              (:temporaries! fresh (:temporaries holder))
410 |              fresh))
411 |          (:definitions p))))
412 | 
413 | (define-generics collect-temporaries)
414 | (define-method (collect-temporaries (<program> p)
415 |                                     (<with-temp-function-definition> f)
416 |                                     (<list> r))
417 |   (walk collect-temporaries p f r))
418 | 
419 | ;; We're going to build up a list of variables to renamed variables,
420 | ;; so here we'll replace anything we know about with the renamed
421 | ;; version
422 | (define-method (collect-temporaries (<local-reference> ref)
423 |                                     (<with-temp-function-definition> f)
424 |                                     (<list> r))
425 |   (let* ((var (:variable ref))
426 |          (v (assq var r)))
427 |     (if (pair? v) (make <local-reference> (cdr v)) ref)))
428 | 
429 | ;; Box read and writes include the reference, so will be rewritten as
430 | ;; above. But box creation just refers to the variable, so we need to
431 | ;; rewrite that if it's named.
432 | (define-method (collect-temporaries (<box-creation> box)
433 |                                     (<with-temp-function-definition> f)
434 |                                     (<list> r))
435 |   (let* ((var (:variable box))
436 |          (v (assq var r)))
437 |     (if (pair? v) (make <box-creation> (cdr v)) box)))
438 | 
439 | (define-method (collect-temporaries (<fix-let> fix)
440 |                                     (<with-temp-function-definition> f)
441 |                                     (<list> r))
442 |   (let* ((args (collect-temporaries (:arguments fix) f r))
443 |          (newvars (map new-renamed-variable (:variables fix)))
444 |          (newr (append (map cons (:variables fix) newvars) r)))
445 |     (adjoin-temp-variables! f newvars)
446 |     (make <fix-let> newvars args
447 |           (collect-temporaries (:body fix) f newr))))
448 | 
449 | ;; Add any new temporaries to the function definition
450 | (define (adjoin-temp-variables! f r)
451 |   (let adjoin ((temps (:temporaries f))
452 |                (vars r))
453 |     (if (pair? vars)
454 |         (if (memq (car vars) temps)
455 |             (adjoin temps (cdr vars))
456 |             (adjoin (cons (car vars) temps) (cdr vars)))
457 |         (:temporaries! f temps))))
458 | 
459 | (define-class (<renamed-variable> <local-variable>)
460 |   (index :index :index!))
461 | (define-method (initialize (<renamed-variable> self)
462 |                            (<symbol> name)
463 |                            (<number> index))
464 |   (init* self :name! name :index! index))
465 | 
466 | ;; We need new names, so give them a serial number
467 | (define *renamed-variable-index* 0)
468 | (define (new-renamed-variable var)
469 |   (set! *renamed-variable-index* (+ 1 *renamed-variable-index*))
470 |   (make <renamed-variable> (:name var) *renamed-variable-index*))
471 | 
472 | ;; === All the transformations
473 | 
474 | (define (transform p)
475 |   (-> p identity
476 |         insert-boxes
477 |         lambda-lift
478 |         extract-things
479 |         thunkify-main
480 |         gather-temporaries))
481 | 
482 | ;; test hook for this stage
483 | 
484 | (define (eval-expr e)
485 |   (let* ((evaler   (create-evaluator #f))
486 |          (txformed (transform ((:expand evaler) e))))
487 |     (evaluate e sg.predef)))
488 | 
489 | ;; We have to supply a few more implementations of evaluate to be able
490 | ;; to evaluate transformed programs. (Which is only useful for sanity
491 | ;; checking, really.)
492 | 
493 | (define *boxes* '())
494 | 
495 | ;; Treat boxes like variable references
496 | (define-method (evaluate (<box-read> r) (<list> sr))
497 |   (let ((box (assq (:variable (:reference r)) *boxes*)))
498 |     (cdr box)))
499 | (define-method (evaluate (<box-write> w) (<list> sr))
500 |   (let ((box (assq (:variable (:reference w)) *boxes*))
501 |         (val (evaluate (:form w) sr)))
502 |     (set-cdr! box val)))
503 | (define-method (evaluate (<box-creation> box) (<list> sr))
504 |   (set! *boxes* (cons (cons (:variable box) undefined-value) *boxes*)))
505 | 
506 | ;; For the sake of simplicity, I'm just going to put the function defs
507 | ;; and quotations into vectors.
508 | (define *functions* (make-vector 100))
509 | (define *quotations* (make-vector 100))
510 | 
511 | (define-method (evaluate (<quotation-reference> ref) (<list> sr))
512 |       (vector-ref *quotations* (-> ref :variable :name)))
513 | 
514 | (define-method (evaluate (<quotation-variable> q) (<list> sr))
515 |   (vector-set! *quotations* (:name q) (:value q)))
516 | 
517 | (define-method (evaluate (<function-definition> f) (<list> sr))
518 |   (vector-set! *functions* (:index f) f))
519 | 
520 | ;; Here we have to create an invokable object, given a function
521 | ;; definition and the activation stack. A <runtime-procedure> will do
522 | ;; fine. Now normally, we might rely on the free variables used in the
523 | ;; definition being present in the activation stack; however, we may
524 | ;; have renamed some of them, if they are introduced in a fix-let. So,
525 | ;; we need to collect the free variables from the closure-creation
526 | ;; and substitute them for those the definition is expecting.
527 | ;; (The book eventually does this, in chap10{c,d}.scm)
528 | (define-method (evaluate (<closure-creation> c) (<list> sr))
529 |   (let ((func (vector-ref *functions* (:index c))))
530 |     (let loop ((sr* sr)
531 |                (free* (:free c))
532 |                (var* (:free func)))
533 |       (if (instance-of? free* <no-free>) ;; assume free* and var* have
534 |                                         ;; same arity
535 |           (make <runtime-procedure> (:body func) (:variables func) sr*)
536 |           (let ((val (evaluate (:first free*) sr)))
537 |             (loop (sr-extend sr (car var*) val)
538 |                   (:others free*) (cdr var*)))))))
539 | 
540 | (define-method (evaluate (<flat-program> p) (<list> sr))
541 |   (let ((ev (lambda (e) (evaluate e sr))))
542 |     (map ev (:quotations p))
543 |     (map ev (:definitions p))
544 |     (ev (:form p))))
545 | 
546 | ;; This won't be doing much more than the eval in chapter9.ss
547 | (define (eval-expr e)
548 |   (set! *boxes* '())
549 |   (let* ((ev (create-evaluator #f))
550 |          (expanded ((:expand ev) e))
551 |          (_ (enrich-with-new-global-variables! ev))
552 |          (sg (:runtime ev)))
553 |     (-> expanded transform (evaluate sg))))
554 | 
555 | ;; === Support for ->sexpr
556 | 
557 | (load "sexpr.ss")
558 | 
559 | (define (function-def-name index)
560 |   (string->symbol (string-append "func_" (number->string index))))
561 | 
562 | (define (quotation-name index)
563 |   (string->symbol (string-append "constant_" (number->string index))))
564 | 
565 | (define-methods ->sexpr
566 |   ([(<box-read> r)]
567 |    (->sexpr (:reference r)))
568 |   ([(<box-write> w)]
569 |    `(set! ,(->sexpr (:reference w))
570 |           ,(->sexpr (:form w))))
571 |   ([(<box-creation> c)] '())
572 |   ([(<flat-function> f)]
573 |    `(lambda ,(map ->sexpr (append (:variables f) (:free f)))
574 |       ,(->sexpr (:body f))))
575 |   ([(<some-free> f)]
576 |    (cons (->sexpr (:first f)) (->sexpr (:others f))))
577 |   ([(<no-free> nf)] '())
578 |   ([(<flat-program> p)]
579 |    (append (map (lambda (q) `(define ,(quotation-name (:name q))
580 |                                ,(:value q))) (:quotations p))
581 |            (map (lambda (f) `(define ,(function-def-name (:index f))
582 |                                ,(->sexpr f))) (:definitions p))
583 |            (list (->sexpr (:form p)))))
584 |   ([(<quotation-variable> c)]
585 |    (quotation-name (:name c)))
586 |   ([(<closure-creation> cc)]
587 |    `(lambda ,(->sexpr (:free cc))
588 |       (,(function-def-name (:index cc))
589 |        ,(append (map ->sexpr (:variables cc)) (->sexpr (:free cc))))))
590 | )
591 | 


--------------------------------------------------------------------------------
/chapter3.ss:
--------------------------------------------------------------------------------
  1 | ;; Outside world
  2 | 
  3 | (define ($wrong . args)
  4 |   (error args))
  5 | 
  6 | ;; Roughly equivalent to CLOS (based on tinyclos?)
  7 | ;; http://sisc-scheme.org/manual/html/ch07.html#GenericProcedures
  8 | 
  9 | (load "prelude.ss")
 10 | 
 11 | (import type-system)
 12 | (import generic-procedures)
 13 | (import oo)
 14 | 
 15 | ;; Just to keep it compact. These are the drivers.
 16 | (define-generics
 17 |   $evaluate ;; expression environment continuation
 18 |   $invoke ;; function values environment continuation
 19 |   $resume ;; continuation values
 20 |   $lookup ;; environment name continuation
 21 |   $update!) ;; environment name value continuation
 22 | 
 23 | ;; For now I want to keep the convenient s-expression as code, but I
 24 | ;; want to mark where it's used as a distinct type.
 25 | (define <expression> <value>)
 26 | 
 27 | ;; For $lookup and $update! to dispatch on. This lets us use dispatch
 28 | ;; to distinguish among different states of environment (empty, not
 29 | ;; empty, basically). In principal it also lets us supply a different
 30 | ;; implementation of environment, using e.g., setprop/getprop or
 31 | ;; thread locals.
 32 | (define-class (<environment>))
 33 | 
 34 | ;; A superclass for things that are invokable, so I can be specific in
 35 | ;; type signatures.
 36 | (define-class (<invokable>))
 37 | 
 38 | ;; (SISC makes us declare accessors and mutators, so there will be a
 39 | ;; lot of these.)
 40 | (define-generics :k :k!)
 41 | 
 42 | (define (init* self . fields)
 43 |   (define (init1 fields)
 44 |     (if (pair? fields)
 45 |         (if (pair? (cdr fields))
 46 |             (begin
 47 |               ((car fields) self (cadr fields))
 48 |               (init1 (cddr fields)))
 49 |             (error "Field spec not in format (:mutator! value ...)" fields))))
 50 |   (init1 fields))
 51 | 
 52 | ;; For dispatching on 'what happens next'. This could just be a
 53 | ;; closure, resumed by applying it to the value.  This will also serve
 54 | ;; as our 'outermost' continuation (bottom-continuation in the book),
 55 | ;; if given a native procedure.
 56 | (define-class (<continuation> <invokable>) (k :k :k!))
 57 | (define-method (initialize (<continuation> self)
 58 |                            (<procedure> k))
 59 |   (init* self :k! k))
 60 | (define-method ($resume (<continuation> self) (<value> val))
 61 |   ((:k self) val))
 62 | 
 63 | ;; For the proper error
 64 | (define-method ($invoke (<value> v)
 65 |                         (<list> _args)
 66 |                         (<environment> _env)
 67 |                         (<continuation> _k))
 68 |   ($wrong "Attempt to invoke non-function" v))
 69 | 
 70 | ;; Environments
 71 | 
 72 | (define-generics :value :value! :name :name! :others :others!)
 73 | 
 74 | (define-class (<null-env> <environment>))
 75 | 
 76 | (define-class (<full-env> <environment>)
 77 |   (others :others :others!)
 78 |   (name :name :name!))
 79 | (define-method (initialize (<full-env> env)
 80 |                            (<environment> others)
 81 |                            (<symbol> name))
 82 |   (init* env :others! others
 83 |              :name! name))
 84 | 
 85 | (define-class (<var-env> <full-env>)
 86 |   (value :value :value!))
 87 | (define-method (initialize (<var-env> env)
 88 |                            (<environment> others)
 89 |                            (<symbol> name)
 90 |                            (<value> value))
 91 |   (init* env :others! others :name! name :value! value))
 92 | 
 93 | (define (extend-env env names values)
 94 |   (cond ((and (pair? names) (pair? values))
 95 |          (make <var-env> (extend-env env (cdr names) (cdr values))
 96 |                (car names) (car values)))
 97 |         ((and (null? names) (null? values)) env)
 98 |         ((symbol? names) (make <var-env> env names values))
 99 |         (else ($wrong "Arity mismatch" names values))))
100 | 
101 | ;; Really not sure why there's full-env and var-env, with a different
102 | ;; defn of lookup or update! for full-env -- when will they be
103 | ;; invoked?
104 | 
105 | (define-method ($lookup (<null-env> _empty)
106 |                         (<symbol> name)
107 |                         (<continuation> k))
108 |   ($wrong "Unknown variable" name))
109 | (define-method ($lookup (<full-env> env)
110 |                         (<symbol> name)
111 |                         (<continuation> k))
112 |   ($lookup (:others env) name k))
113 | (define-method ($lookup (<var-env> env)
114 |                         (<symbol> name)
115 |                         (<continuation> k))
116 |   (if (eqv? (:name env) name)
117 |       ($resume k (:value env))
118 |       ($lookup (:others env) name k)))
119 | 
120 | (define-method ($update! (<null-env> env)
121 |                          (<symbol> name)
122 |                          (<value> value)
123 |                          (<continuation> k))
124 |   ($wrong "Unknown variable" name value k))
125 | (define-method ($update! (<full-env> env)
126 |                          (<symbol> name)
127 |                          (<value> value)
128 |                          (<continuation> k))
129 |   ($update! (:others env) name value k))
130 | (define-method ($update! (<var-env> env)
131 |                          (<symbol> name)
132 |                          (<value> value)
133 |                          (<continuation> k))
134 |   (if (eqv? name (:name env))
135 |       (begin
136 |         (:value! env value)
137 |         ($resume k value))
138 |       ($update! (:others env) name value k)))
139 | 
140 | ;; Interpreter 'loop'
141 | 
142 | ;; For now, don't specialise on the type of expression.
143 | (define-method ($evaluate (<expression> e)
144 |                           (<environment> env)
145 |                           (<continuation> k))
146 |   (if (pair? e)
147 |       (case (car e)
148 |         ((quote) (evaluate-quote (cadr e) env k))
149 |         ((if) (evaluate-if (cadr e) (caddr e) (cadddr e) env k))
150 |         ((begin) (evaluate-begin (cdr e) env k))
151 |         ((set!) (evaluate-set! (cadr e) (caddr e) env k))
152 |         ((lambda) (evaluate-lambda (cadr e) (cddr e) env k))
153 |         (else (evaluate-apply (car e) (cdr e) env k)))
154 |       
155 |       (cond ((symbol? e) (evaluate-variable e env k))
156 |             (else (evaluate-quote e env k)))))
157 | 
158 | ;; quoted or literal
159 | 
160 | (define (evaluate-quote v env k)
161 |   ($resume k v))
162 | 
163 | ;; variable ref
164 | (define (evaluate-variable name env k)
165 |   ($lookup env name k))
166 | 
167 | ;; If
168 | 
169 | (define-generics :s-exp :s-exp! :f-exp :f-exp! :env :env!)
170 | 
171 | (define-class (<if-k> <continuation>)
172 |   (s-exp :s-exp :s-exp!)
173 |   (f-exp :f-exp :f-exp!)
174 |   (env :env :env!))
175 | (define-method (initialize (<if-k> self)
176 |                            (<continuation> k)
177 |                            (<expression> success)
178 |                            (<expression> fail)
179 |                            (<environment> env))
180 |   (init* self :k! k
181 |               :s-exp! success
182 |               :f-exp! fail
183 |               :env! env))
184 | 
185 | (define (evaluate-if c-exp s-exp f-exp env k)
186 |   ($evaluate c-exp env (make <if-k> k s-exp f-exp env)))
187 | 
188 | (define-method ($resume (<if-k> k) (<value> v))
189 |   ($evaluate (if v (:s-exp k) (:f-exp k))
190 |              (:env k)
191 |              (:k k)))
192 | 
193 | ;; Begin
194 | 
195 | (define-generics :exprs :exprs!)
196 | 
197 | (define-class (<begin-k> <continuation>)
198 |   (env :env :env!)
199 |   (exprs :exprs :exprs!))
200 | (define-method (initialize (<begin-k> self)
201 |                            (<continuation> k)
202 |                            (<list> exprs)
203 |                            (<environment> env))
204 |   (init* self :k! k :exprs! exprs :env! env))
205 | 
206 | (define (evaluate-begin exprs env k)
207 |   (if (pair? exprs)
208 |       (if (pair? (cdr exprs))
209 |           ;; not tail call
210 |           ($evaluate (car exprs) env (make <begin-k> k exprs env))
211 |           ($evaluate (car exprs) env k))
212 |       ;; nothing to do here. walk on.
213 |       ($resume k $undef)))
214 | 
215 | (define-method ($resume (<begin-k> k) (<value> v))
216 |   (evaluate-begin (cdr (:exprs k)) (:env k) (:k k)))
217 | 
218 | ;; set!
219 | 
220 | (define-class (<set-k> <continuation>)
221 |   (name :name :name!)
222 |   (env :env :env!))
223 | (define-method (initialize (<set-k> self)
224 |                            (<continuation> k)
225 |                            (<symbol> name)
226 |                            (<environment> env))
227 |   (init* self :k! k :name! name :env! env))
228 | 
229 | (define-method ($resume (<set-k> k) (<value> v))
230 |   ($update! (:env k) (:name k) v (:k k)))
231 | 
232 | (define (evaluate-set! name expr env k)
233 |   ($evaluate expr env (make <set-k> k name env)))
234 | 
235 | ;; lambda
236 | 
237 | (define-generics :variables :variables!)
238 | 
239 | ;; NB It's <procedure> that's predefined in SISC's type system, so
240 | ;; we're not shadowing anything. Also: <object> <= <value>, and we're
241 | ;; punning object-level values with meta-level values (e.g.,
242 | ;; object-level numbers are represented with meta-level numbers).
243 | (define-class (<function> <invokable>)
244 |   (variables :variables :variables!)
245 |   (exprs :exprs :exprs!)
246 |   (env :env :env!))
247 | (define-method (initialize (<function> self)
248 |                            (<list> variables)
249 |                            (<list> exprs)
250 |                            (<environment> env))
251 |   (init* self :variables! variables
252 |               :exprs! exprs
253 |               :env! env))
254 | 
255 | (define (evaluate-lambda variables body env k)
256 |   ($resume k (make <function> variables body env)))
257 | 
258 | (define-method ($invoke (<function> f)
259 |                         (<list> values)
260 |                         (<environment> env)
261 |                         (<continuation> k))
262 |   (let ((env1 (extend-env (:env f) (:variables f) values)))
263 |     (evaluate-begin (:exprs f) env1 k)))
264 | 
265 | ;; Here is where the fun starts.
266 | 
267 | ;; There are a number of continuations here:
268 | 
269 | ;; This is a cheat so we only have to define the init once.
270 | (define-class (<fun-k> <continuation>)
271 |   (exprs :exprs :exprs!)
272 |   (env :env :env!))
273 | (define-method (initialize (<fun-k> self)
274 |                            (<continuation> k)
275 |                            (<list> exprs)
276 |                            (<environment> env))
277 |   (init* self :k! k :exprs! exprs :env! env))
278 | 
279 | ;; Evaluated the head, let's get the args
280 | (define-class (<fun-head-k> <fun-k>))
281 | 
282 | ;; Evaluating an argument
283 | (define-class (<arg-k> <fun-k>))
284 | 
285 | (define-class (<cons-k> <continuation>)
286 |   (value :value :value!))
287 | (define-method (initialize (<cons-k> self)
288 |                            (<continuation> k)
289 |                            (<value> value))
290 |   (init* self :k! k :value! value))
291 | 
292 | ;; Head and args evaluated, ready to apply
293 | (define-class (<apply-k> <continuation>)
294 |   (value :value :value!) ;; the function to apply
295 |   (env :env :env!))
296 | (define-method (initialize (<apply-k> self)
297 |                            (<continuation> k)
298 |                            (<invokable> fun)
299 |                            (<environment> env))
300 |   (init* self :k! k :value! fun :env! env))
301 | 
302 | ;; Here's where we might also check if the head is invokable.
303 | (define-method ($resume (<fun-head-k> k)
304 |                         (<invokable> fn))
305 |   (evaluate-args (:exprs k) (:env k)
306 |                       (make <apply-k> (:k k) fn (:env k))))
307 | 
308 | (define-method ($resume (<arg-k> k)
309 |                         (<value> v))
310 |   (evaluate-args (cdr (:exprs k)) (:env k)
311 |                       (make <cons-k> (:k k) v)))
312 | 
313 | (define-method ($resume (<cons-k> k) (<list> vs))
314 |   ($resume (:k k) (cons (:value k) vs)))
315 | 
316 | (define-method ($resume (<apply-k> k) (<list> args))
317 |   ($invoke (:value k) args (:env k) (:k k)))
318 | 
319 | (define (evaluate-apply head body env k)
320 |   ($evaluate head env (make <fun-head-k> k body env)))
321 | 
322 | (define (evaluate-args exprs env k)
323 |   (if (pair? exprs)
324 |       ($evaluate (car exprs) env (make <arg-k> k exprs env))
325 |       ($resume k '())))
326 | 
327 | ;; Wowsers, that's it for the interpreter. Now for some prims.
328 | 
329 | (define-class (<primitive> <function>)
330 |   (name :name :name!)
331 |   (value :value :value!))
332 | (define-method (initialize (<primitive> self)
333 |                            (<symbol> name)
334 |                            (<procedure> fn))
335 |   (init* self :name! name :value! fn))
336 | 
337 | (define-method ($invoke (<primitive> p)
338 |                         (<list> args)
339 |                         (<environment> env)
340 |                         (<continuation> k))
341 |   ((:value p) args env k))
342 | 
343 | (define (prim fn)
344 |   (lambda (vs env k)
345 |     ($resume k (apply fn vs))))
346 | 
347 | (define env.global (make <null-env>))
348 | 
349 | (set! env.global
350 |   (let ((fns '(+ - < >)))
351 |     (extend-env env.global
352 |                 fns
353 |                 (map (lambda (fn)
354 |                        (make <primitive> fn (prim (eval fn))))
355 |                      fns))))
356 | 
357 | (set! env.global
358 |   (extend-env env.global '(call/cc)
359 |               (list (make <primitive> 'call/cc
360 |                           (lambda (vs env k)
361 |                             ($invoke (car vs) (list k) env k))))))
362 | 
363 | (define-method ($invoke (<continuation> fn)
364 |                         (<list> args)
365 |                         (<environment> env)
366 |                         (<continuation> k))
367 |   ($resume fn (car args)))
368 | 


--------------------------------------------------------------------------------
/chapter4.ss:
--------------------------------------------------------------------------------
  1 | ;; This interpreter retreats from using generic procedures and
  2 | ;; classes, instead using closures and message passing to represent
  3 | ;; pretty much everything. The heap is explicit: every value is
  4 | ;; allocated (given a location) and the environment maps variable
  5 | ;; names to locations. (Obviously this is in preparation for
  6 | ;; allocation *really* being explicit). Procedures and continuations
  7 | ;; are also closures, but not invoked directly. The interpreter still
  8 | ;; implicitly CPS-transforms expressions.
  9 | 
 10 | ;; By now there's little confusion between meta- and object-level, so
 11 | ;; I'm giving up on the $ prefix.
 12 | 
 13 | ;; Standard defn.
 14 | (define (wrong . args)
 15 |   (error args))
 16 | 
 17 | ;; Memory: this is threaded through the interpreter control flow, as
 18 | ;; an argument to each (interpreting) procedure.
 19 | 
 20 | ;; Memory and envs will use the same implementation: a procedure that
 21 | ;; looks up the address or name given.
 22 | 
 23 | (define (update s a v)
 24 |   (lambda (aa)
 25 |     (if (eqv? a aa)
 26 |         v
 27 |         (s aa))))
 28 | 
 29 | ;; Convenience for multiple assignments
 30 | (define (update* s a* v*)
 31 |   (if (pair? a*)
 32 |       (update* (update s (car a*) (car v*))
 33 |                (cdr a*) (cdr v*))
 34 |       s))
 35 | 
 36 | ;; Interface for other procedures.
 37 | ;; args: number of addresses to allocate, current memory, (meta-level)
 38 | ;; continuation to call with the new memory and list of allocated addresses.
 39 | (define (allocate n s q)
 40 |   (if (> n 0)
 41 |       (let ((a (new-location s)))
 42 |         (allocate (- n 1)
 43 |                   (expand-store a s)
 44 |                   (lambda (a* ss)
 45 |                     (q (cons a a*) ss))))
 46 |       (q '() s)))
 47 | 
 48 | ;; Reserve an address. This just uses the first memory location as a
 49 | ;; high water mark; as such, it's coupled with new-location and init
 50 | (define (expand-store high-location s)
 51 |   (update s 0 high-location))
 52 | 
 53 | (define (new-location s)
 54 |   (+ 1 (s 0)))
 55 | 
 56 | (define (initial-s)
 57 |   (expand-store 0 (lambda _ ($wrong "No such address"))))
 58 | 
 59 | ;; Values. This is the first 'message passing' style abstraction.
 60 | ;; There's two messages all values respond to: 'type and 'boolify.
 61 | 
 62 | ;; boolify returns one of these
 63 | (define TRUE (lambda (x y) x))
 64 | (define FALSE (lambda (x y) y))
 65 | 
 66 | ;; '() is a singleton
 67 | (define NULL
 68 |   (lambda (msg)
 69 |     (case msg
 70 |       ((type) 'null)
 71 |       ((boolify) TRUE))))
 72 | 
 73 | (define (create-boolean v)
 74 |   (let ((bool (if v TRUE FALSE)))
 75 |     (lambda (msg)
 76 |       (case msg
 77 |         ((type) 'boolean)
 78 |         ((boolify) bool)))))
 79 | 
 80 | ;; symbols can be asked for their name
 81 | (define (create-symbol s)
 82 |   (lambda (msg)
 83 |     (case msg
 84 |       ((type) 'symbol)
 85 |       ((boolify) TRUE)
 86 |       ((name) s))))
 87 | 
 88 | (define (create-number n)
 89 |   (lambda (msg)
 90 |     (case msg
 91 |       ((type) 'number)
 92 |       ((boolify) TRUE)
 93 |       ((value) n))))
 94 | 
 95 | (define (create-string s)
 96 |   (lambda (msg)
 97 |     (case msg
 98 |       ((type) 'string)
 99 |       ((boolify) TRUE)
100 |       ((value) s))))
101 | 
102 | (define (create-function tag behaviour)
103 |   (lambda (msg)
104 |     (case msg
105 |       ((type) 'function)
106 |       ((boolify) TRUE)
107 |       ((tag) tag)
108 |       ((behaviour) behaviour))))
109 | 
110 | 
111 | ;; These may be mutated; thus set-car and set-cdr are functions that
112 | ;; transform a memory.
113 | (define (create-pair a d)
114 |   (lambda (msg)
115 |     (case msg
116 |       ((type) 'pair)
117 |       ((boolify) TRUE)
118 |       ((set-car) (lambda (s v) (update s a v)))
119 |       ((set-cdr) (lambda (s v) (update s d v)))
120 |       ((car) a)
121 |       ((cdr) d))))
122 | 
123 | ;; As with $allocate above, must be given a continuation. In this case
124 | ;; it will be given the pair value and the new memory.
125 | (define (allocate-pair a d s q)
126 |   (allocate 2 s
127 |             (lambda (ad ss)
128 |               (q (create-pair (car ad) (cadr ad))
129 |                  (update* ss ad (list a d))))))
130 | 
131 | ;; In this case the supplied continuation gets the head of the list
132 | ;; and the new memory.
133 | (define (allocate-list v* s q)
134 |   ;; This creates a chain of continuations that will allocate the
135 |   ;; pairs; this starts unwinding when the condition fails, where
136 |   ;; starts with the initial memory state.
137 |   (define (consify vs qq)
138 |     (if (pair? vs)
139 |         (consify (cdr vs) (lambda (v ss)
140 |                             (allocate-pair (car vs) v ss qq)))
141 |         (qq NULL s)))
142 |   (consify v* q))
143 | 
144 | ;; Environment
145 | 
146 | ;; update and update* already suffice
147 | 
148 | (define (initial-env)
149 |   (lambda (n) (wrong "No binding for name" n)))
150 | 
151 | ;; Evaluate
152 | 
153 | ;; Now we take an extra arg for the memory. Note, however, that all of
154 | ;; the continuations dealt with in evaluate-* functions don't have an
155 | ;; argument for the env. That's because only function application can
156 | ;; introduce new names, and that recurses via evaluate. Mutation is
157 | ;; dealt with by 'updating' (constructing a new) memory, which *is* an
158 | ;; argument to continuations.
159 | (define (evaluate expr env mem k)
160 |   (if (pair? expr)
161 |       (case (car expr)
162 |         ((quote) (evaluate-quote (cadr expr) env mem k))
163 |         ((if) (evaluate-if (cadr expr) (caddr expr) (cadddr expr) env mem k))
164 |         ((begin) (evaluate-begin (cdr expr) env mem k))
165 |         ((set!) (evaluate-set (cadr expr) (caddr expr) env mem k))
166 |         ((lambda) (evaluate-lambda (cadr expr) (cddr expr) env mem k))
167 |         (else (evaluate-apply (car expr) (cdr expr) env mem k))))
168 | 
169 |       (if (symbol? expr) (evaluate-var expr env mem k)
170 |           (evaluate-quote expr env mem k)))
171 | 
172 | ;; We now have to translate between our meta-level representations of
173 | ;; values and the object-level representations.
174 | (define (evaluate-quote value env mem k)
175 |   (meta->object value mem k))
176 | 
177 | (define (meta->object value mem q)
178 |   (cond
179 |     ((null? value) (q NULL mem))
180 |     ((boolean? value) (q (create-boolean value) mem))
181 |     ((symbol? value) (q (create-symbol value) mem))
182 |     ((string? value) (q (create-string value) mem))
183 |     ((number? value) (q (create-number value) mem))
184 |     ((pair? value)
185 |      (meta->object (car value) mem
186 |                    (lambda (head mem1)
187 |                      (meta->object (cdr value) mem1
188 |                                    (lambda (tail mem2)
189 |                                      (allocate-pair head tail mem2 q))))))))
190 | 
191 | ;; For symmetry's sake, and e.g., to present evaluated values back again.
192 | 
193 | (define (object->meta value mem)
194 |   (case (value 'type)
195 |     ((null) '())
196 |     ((boolean) ((value 'boolify) #t #f))
197 |     ((symbol) ((value 'name)))
198 |     ((string number) (value 'value))
199 |     ((function) value) ;; hmm, better to return "opaque" rep?
200 |     ((pair) (cons (object->meta (mem (value 'car)) mem)
201 |                   (object->meta (mem (value 'cdr)) mem)))
202 |     (else (wrong "Unknown object-level type" (value 'type)))))
203 | 
204 | ;; If
205 | 
206 | (define (evaluate-if c t f env mem k)
207 |   (evaluate c env mem
208 |             (lambda (v mem1)
209 |               (evaluate (if (v 'boolify) t f) env mem1 k))))
210 | 
211 | ;; Begin
212 | 
213 | (define (evaluate-begin e* env mem k)
214 |   (if (pair? (cdr e*))
215 |       (evaluate (car e*) env mem
216 |                 (lambda (_ mem1)
217 |                   (evaluate-begin (cdr e*) env mem1 k)))
218 |       (evaluate (car e*) env mem k)))
219 | 
220 | ;; variable ref
221 | 
222 | (define (evaluate-var name env mem k)
223 |   (k (mem (env name)) mem))
224 | 
225 | ;; set!
226 | 
227 | (define (evaluate-set name v-expr env mem k)
228 |   (evaluate v-expr env mem
229 |             (lambda (val mem1)
230 |               (k val (update mem1 (env name) val)))))
231 | 
232 | ;; lambda
233 | 
234 | ;; When invoked, a function ('s behaviour) allocates space for each
235 | ;; argument, and updates the environment with the appropriate
236 | ;; bindings.
237 | 
238 | ;; NB1 Following the book, this allocates space for the function and
239 | ;; uses that as its 'tag', but does not update memory to reflect
240 | ;; this. Presumably this anticipates further modification. (A: No,
241 | ;; it's so procedures can be compared)
242 | 
243 | ;; Updated in exercise 4.7 to handle improper lists of arguments, and
244 | ;; an extension: handle a symbol meaning the entire list of args.
245 | 
246 | (define (evaluate-lambda names body env mem k)
247 |   (let ((arity (arg-length names)))
248 |     (allocate
249 |      1 mem
250 |      (lambda (a* mem')
251 |        (k (create-function
252 |            (car a*)
253 |            (lambda (vals mem1 k)
254 |              (allocate arity mem1
255 |                        (lambda (as mem1')
256 |                          (evaluate-begin body
257 |                                          (update-env-args env names as)
258 |                                          (update-store-args mem1' as vals names)
259 |                                          k))))) mem')))))
260 | 
261 | ;; Update the env according to the list of addresses. Since the
262 | ;; addresses have been allocated according to the arity of the
263 | ;; argument list, we can rely on it having the right number of
264 | ;; addresses.
265 | (define (update-store-args s as vs names)
266 |   (cond ((pair? names)
267 |          (update-store-args (update s (car as) (car vs))
268 |                             (cdr as) (cdr vs) (cdr names)))
269 |         ((null? names) s)
270 |         (else
271 |           (allocate-list vs s (lambda (head ss)
272 |                                 (update ss (car as) head))))))
273 | 
274 | ;; Again, trust the addresses to have the correct arity
275 | (define (update-env-args env names as)
276 |   (cond ((pair? names)
277 |          (update-env-args (update env (car names) (car as))
278 |                           (cdr names) (cdr as)))
279 |         ((null? names) env)
280 |         (else
281 |           (update env names (car as)))))
282 | 
283 | ;; this may not tell the whole story about whether an argument list is
284 | ;; the correcy arity
285 | (define (arg-length names)
286 |   (define (arg-length1 names n)
287 |     (cond
288 |       ((pair? names) (arg-length1 (cdr names) (+ 1 n)))
289 |       ((null? names) n)
290 |       (else (+ 1 n))))
291 |   (cond
292 |     ((pair? names) (arg-length1 (cdr names) 1))
293 |     (else 1)))
294 | 
295 | ;; (the book has it this way; technically it doesn't need to pass the
296 | ;; env to eval-args; maybe it's to allow modification in an exercise
297 | ;; later)
298 | (define (evaluate-apply head args env mem k)
299 |   (define (eval-args args env mem k)
300 |     (if (pair? args)
301 |         (evaluate (car args) env mem
302 |                   (lambda (v mem1)
303 |                     (eval-args (cdr args) env mem1
304 |                                (lambda (vs mem2)
305 |                                  (k (cons v vs) mem2)))))
306 |         (k '() mem)))
307 |   (evaluate head env mem
308 |             (lambda (fn mem1)
309 |               (if (eq? 'function (fn 'type))
310 |                   (eval-args args env mem1
311 |                              (lambda (allargs mem2)
312 |                                ((fn 'behaviour) allargs mem2 k)))
313 |                   (wrong "Attempted to apply a non-function" fn)))))
314 | 
315 | 
316 | ;; Toplevel
317 | 
318 | (define r.global (initial-env))
319 | (define s.global (initial-s))
320 | (define bottom-k (lambda (v) v))
321 | 
322 | ;; The macros in the book have an egregious error: the second allocate
323 | ;; (inside the expansion of def-primitive) is basically a no-op, since
324 | ;; it's overwritten by the outer set!
325 | 
326 | (define (initial name value)
327 |   (allocate 1 s.global
328 |             (lambda (a* mem)
329 |               (set! r.global (update r.global name (car a*)))
330 |               (set! s.global (update mem (car a*) value)))))
331 | 
332 | (define (primitive name value)
333 |   (initial name (create-function (new-location s.global) ;; I'm next here
334 |                                  value)))
335 | 
336 | (initial 't (create-boolean #t))
337 | (initial 'f (create-boolean #f))
338 | (initial 'nil NULL)
339 | 
340 | (primitive '<=
341 |            (lambda (args s k)
342 |              (k (create-boolean
343 |                  (<= ((car args) 'value) ((cadr args) 'value))) s)))
344 | (primitive '*
345 |            (lambda (args s k)
346 |              (k (create-number
347 |                  (apply * (map (lambda (v) (v 'value)) args)))
348 |                 s)))
349 | 
350 | (primitive 'eqv?
351 |            (lambda (args s k)
352 |              (k (create-boolean
353 |                  (let ((a (car args)) (b (cadr args)))
354 |                    (if (eq? (a 'type) (b 'type))
355 |                        (case (a 'type)
356 |                          ((null) #t)
357 |                          ((boolean)
358 |                           ((a 'boolify)
359 |                            ((b 'boolify) #t #f)
360 |                            ((b 'boolify) #f #t)))
361 |                          ((symbol) (eq? (a 'name) (b 'name)))
362 |                          ((string number)
363 |                           (eq? (a 'value) (b 'value)))
364 |                          ((pair)
365 |                           (and (= (a 'car) (b 'car))
366 |                                (= (a 'cdr) (b 'cdr))))
367 |                          ((function)
368 |                           (= (a 'tag) (b 'tab)))
369 |                          (else #f))
370 |                        #f))))))
371 | 
372 | ;; Interesting! So, here, I get an object-level list of object-level
373 | ;; values as one of my arguments; to be able to apply the function I
374 | ;; have to have a meta-level list of object-level values, just like I
375 | ;; have in evaluate-apply.
376 | 
377 | (define (deref-list head s)
378 |   (case (head 'type)
379 |     ((null) '())
380 |     ((pair)
381 |      (cons (s (head 'car)) (deref-list (s (head 'cdr)) s)))))
382 | 
383 | (primitive 'apply
384 |            (lambda (args s k)
385 |              (let ((f (car args))
386 |                    (head (cadr args)))
387 |                ((f 'behaviour) (deref-list head s) s k))))
388 | 
389 | (primitive 'call/cc
390 |            (lambda (args s k)
391 |              (allocate
392 |               1 s
393 |               (lambda (a* ss)
394 |                 (let* ((addr (car a*))
395 |                        (cc (create-function addr
396 |                                             (lambda (argv s' _k)
397 |                                               (k (car argv) s')))) ;; unwind mem?
398 |                        (fn (car args)))
399 |                   ((fn 'behaviour) (list cc) ss k))))))
400 | 
401 |                         
402 | (define (repl)
403 |   (let loop ((mem s.global))
404 |     (evaluate (read) r.global mem
405 |               (lambda (v mem')
406 |                 (display (object->meta v mem'))(newline)
407 |                 (loop mem')))))
408 | 


--------------------------------------------------------------------------------
/chapter6.3.ss:
--------------------------------------------------------------------------------
  1 | ;; This interpreter is adapted from the one in chapter6.ss.
  2 | ;;
  3 | ;; In §6.2 (which I'm skipping), the interpreter from §6.1 is changed
  4 | ;; to use a global register for its environment and to treat tail
  5 | ;; calls differently (since they need not restore the environment,
  6 | ;; thus keeping constant stack).
  7 | ;;
  8 | ;; In the §6.3 interpreter we'll remove the continuation-passing from
  9 | ;; the interpreter, and instead use call/cc in the host language to
 10 | ;; implement call/cc in the interpreted language. The combination of a
 11 | ;; register for the environment and direct style means forms are now
 12 | ;; compiled -- sorry, pretreated -- to thunks, moving towards a more
 13 | ;; VM-like result (do some stuff to registers, jump).
 14 | 
 15 | (load "prelude.ss")
 16 | (load "env.ss")
 17 | (load "closure.ss")
 18 | 
 19 | ;; Closures are a lambda and the closed-over environment
 20 | (define-method (initialize (<closure> self)
 21 |                            (<procedure> code)
 22 |                            (<activation> closed))
 23 |   (:code! self code)
 24 |   (:closed-env! self closed))
 25 | 
 26 | ;; closures are invoked with an activation frame of the arguments
 27 | (define-method (invoke (<closure> f)
 28 |                        (<activation> v*))
 29 |   ((:code f) v* (:closed-env f)))
 30 | 
 31 | ;; Frame pointer
 32 | (define *env* undefined-value)
 33 | 
 34 | ;; Right then. Combinators.
 35 | 
 36 | (define (CONSTANT v)
 37 |   (lambda () v))
 38 | 
 39 | (define (SHALLOW-ARGUMENT-REF index)
 40 |   (lambda () (:argument *env* index)))
 41 | 
 42 | (define (DEEP-ARGUMENT-REF level index)
 43 |   (lambda () (deep-fetch *env* level index)))
 44 | 
 45 | (define (CHECKED-GLOBAL-REF index)
 46 |   (lambda ()
 47 |     (let ((v (global-fetch index)))
 48 |       (if (eq? v undefined-value)
 49 |           (runtime-error "Uninitialised variable")
 50 |           v))))
 51 | 
 52 | (define (PREDEFINED index)
 53 |   (lambda () (predef-fetch index)))
 54 | 
 55 | (define (ALTERNATIVE mc mt mf)
 56 |   (lambda () (if (mc) (mt) (mf))))
 57 | 
 58 | (define (SHALLOW-ASSIGNMENT index m)
 59 |   (lambda () (:argument! *env* index (m))))
 60 | 
 61 | (define (DEEP-ASSIGNMENT level index m)
 62 |   (lambda () (deep-update! *env* level index (m))))
 63 | 
 64 | (define (GLOBAL-SET! index m)
 65 |   (lambda () (global-update! index (m))))
 66 | 
 67 | (define (SEQUENCE m m+)
 68 |   (lambda () (m) (m+)))
 69 | 
 70 | (define (FIX-CLOSURE m+ arity)
 71 |   (let ((arity+1 (+ arity 1)))
 72 |     (lambda ()
 73 |       ;; The book defines a named procedure here instead of inlining a
 74 |       ;; lambda. As I'm intrigued by this, I'm going to do it too.
 75 |       (define (the-function v* sr) ;; sr = closed-over environment
 76 |         ;; the v* here will have been freshly consed for this invocation,
 77 |         ;; so we can happily mutate it
 78 |         (if (= (:length v*) arity+1)
 79 |             (begin (set! *env* (extend sr v*))
 80 |                    (m+))
 81 |             (runtime-error "Incorrect arity for procedure"
 82 |                            "expected" arity
 83 |                            "got" (- (:length v*) 1))))
 84 |       (make <closure> the-function *env*))))
 85 | 
 86 | (define (NARY-CLOSURE m+ arity)
 87 |   (let ((arity+1 (+ arity 1)))
 88 |     (lambda ()
 89 |       (define (the-function v* sr)
 90 |         (if (>= (:length v*) arity+1)
 91 |             (begin
 92 |               (listify! v* arity)
 93 |               (set! *env* (extend sr v*))
 94 |               (m+))
 95 |             (runtime-error "Incorrect arity"
 96 |                            "expected at least" arity
 97 |                            "got" (- (:length v*) 1))))
 98 |       (make <closure> the-function *env*))))
 99 | 
100 | 
101 | (define (TR-REGULAR-CALL m m*)
102 |   (lambda ()
103 |     (invoke (m) (m*))))
104 | 
105 | (define (REGULAR-CALL m m*)
106 |   (lambda ()
107 |     (let* ((f (m))
108 |            (v* (m*))
109 |            (sr *env*) ;; get the env
110 |            (result (invoke f v*))) ;; do the call
111 |       (set! *env* sr) ;; restore the env
112 |       result)))
113 | 
114 | (define (STORE-ARGUMENT m m* index)
115 |   (lambda ()
116 |     (let ((v (m))
117 |           (v* (m*)))
118 |       (:argument! v* index v)
119 |       v*)))
120 | 
121 | (define (ALLOCATE-FRAME size)
122 |   (let ((size+1 (+ size 1)))
123 |     (lambda () (make <activation> size+1))))
124 | 
125 | (define (TR-FIX-LET m* m+)
126 |   (lambda ()
127 |     (set! *env* (extend *env* (m*)))
128 |     (m+)))
129 | 
130 | (define (FIX-LET m* m+)
131 |   (lambda ()
132 |     (set! *env* (extend *env* (m*)))
133 |     (let ((result (m+)))
134 |       (set! *env* (:next *env*))
135 |       result)))
136 | 
137 | (define (CONS-ARGUMENT m m* arity)
138 |   (lambda ()
139 |     (let ((v (m))
140 |           (v* (m*)))
141 |       (:argument! v* arity (cons v (:argument v* arity)))
142 |       v*)))
143 | 
144 | ;; Because it's a dotted lambda, we know to pre-load the last argument
145 | ;; slot with an empty list, for the rest args.
146 | (define (ALLOCATE-DOTTED-FRAME arity)
147 |   (let ((arity+1 (+ arity 1)))
148 |     (lambda ()
149 |       (let ((v* (make <activation> arity+1)))
150 |         (:argument! v* arity '())
151 |         v*))))
152 | 
153 | (define (CALL0 address)
154 |   (lambda () (address)))
155 | 
156 | (define (CALL1 address m1)
157 |   (lambda () (address (m1))))
158 | 
159 | (define (CALL2 address m1 m2)
160 |   (lambda ()
161 |     (address (m1) (m2))))
162 | 
163 | (define (CALL3 address m1 m2 m3)
164 |   (lambda ()
165 |     ;; The book uses a let* here to ensure left-to-right evaluation, I
166 |     ;; guess because otherwise it's undefined? I'm not so fussed,
167 |     ;; anyway.
168 |     (address (m1) (m2) (m3))))
169 | 
170 | 
171 | ;; Now the pretreater, which is common to chapter 6 and 7 I think
172 | (load "pretreat.ss")
173 | 
174 | ;; This is more along the lines of the book, just translating into a
175 | ;; procedure rather than a macro (which I think is
176 | ;; unnecessary). Goodness there's a lot of repitition.
177 | (define (define-primitive name underlying arity)
178 |   (let ((arity+1 (+ arity 1)))
179 |     (case arity
180 |       ((0)
181 |        (define-initial name
182 |          (let ((behaviour
183 |                 (lambda (v* sr)
184 |                   (if (= (:length v*) arity+1)
185 |                       (underlying)
186 |                       (runtime-error "Wrong number of arguments"
187 |                                      "expected" 0
188 |                                      "got" (- (:length v*) 1))))))
189 |            (description-extend!
190 |             name `(function ,underlying ,arity))
191 |            (make <closure> behaviour sr.init))))
192 |       ((1)
193 |        (define-initial name
194 |          (let ((behaviour
195 |                 (lambda (v* sr)
196 |                   (if (= (:length v*) arity+1)
197 |                       (underlying (:argument v* 0))
198 |                       (runtime-error "Wrong number of arguments"
199 |                                      "expected" 1
200 |                                      "got" (- (:length v*) 1))))))
201 |            (description-extend!
202 |             name `(function ,underlying ,arity))
203 |            (make <closure> behaviour sr.init))))
204 |       ((2)
205 |        (define-initial name
206 |          (let ((behaviour
207 |                 (lambda (v* sr)
208 |                   (if (= (:length v*) arity+1)
209 |                       (underlying (:argument v* 0)
210 |                                   (:argument v* 1))
211 |                       (runtime-error "Wrong number of arguments"
212 |                                      "expected" 2
213 |                                      "got" (- (:length v*) 1))))))
214 |            (description-extend!
215 |             name `(function ,underlying ,arity))
216 |            (make <closure> behaviour sr.init))))
217 |       ((3)
218 |        (define-initial name
219 |          (let ((behaviour
220 |                 (lambda (v* sr)
221 |                   (if (= (:length v*) arity+1)
222 |                       (underlying (:argument v* 0)
223 |                                   (:argument v* 1)
224 |                                   (:argument v* 2))
225 |                       (runtime-error "Wrong number of arguments"
226 |                                      "expected" 3
227 |                                      "got" (- (:length v*) 1))))))
228 |            (description-extend!
229 |             name `(function ,underlying ,arity))
230 |            (make <closure> behaviour sr.init)))))))
231 | 
232 | ;; We can now define apply and call/cc, both as initial variables
233 | ;; rather than primitives, so they get better access to the underlying
234 | ;; machinery.
235 | 
236 | (define-initial 'apply
237 |   (let ((arity 2)
238 |         (arity+1 3))
239 |     (make <closure>
240 |           (lambda (v* sr)
241 |             ;; `apply` has a weird definition:
242 |             ;; http://www.schemers.org/Documents/Standards/R5RS/HTML/
243 |             ;; This is why we have to shuffle things around here,
244 |             ;; rather than just expecting `(apply f args)`
245 |             (if (>= (:length v*) arity+1)
246 |                 ;; Why does the book have `- 2` here? Because it's not
247 |                 ;; a varargs we're looking for, it's the last argument
248 |                 ;; supplied -- really, last-arg is
249 |                 ;; 'last-non-list-arg'. It's sort of a reverse
250 |                 ;; varargs.
251 |                 (let* ((f (:argument v* 0))
252 |                        (last-arg-index (- (:length v*) 2))
253 |                        (last-arg (:argument v* last-arg-index))
254 |                        (size (+ last-arg-index (length last-arg)))
255 |                        (frame (make <activation> size)))
256 |                   (do ((i 1 (+ i 1)))
257 |                       ((= i last-arg-index))
258 |                     (:argument! frame (- i 1) (:argument v* i)))
259 |                   (do ((i (- last-arg-index 1) (+ i 1))
260 |                        (last-arg last-arg (cdr last-arg)))
261 |                       ((null? last-arg))
262 |                     (:argument! frame i (car last-arg)))
263 |                   (invoke f frame))
264 |                 (runtime-error "Wrong number of arguments to apply"
265 |                                "expected at least 2")))
266 |           sr.init)))
267 | 
268 | (define-initial 'call/cc
269 |   (let ((arity 1)
270 |         (arity+1 2))
271 |     (make <closure>
272 |           (lambda (v* sr) ;; = (<f> to call with k, toplevel env)
273 |             (if (= arity+1 (:length v*))
274 |                 (call/cc
275 |                  (lambda (metak)
276 |                    (let ((f (:argument v* 0))
277 |                          ;; Make an activation frame for f, which
278 |                          ;; we'll fill in presently
279 |                          (frame (make <activation> 2)))
280 |                      (:argument!
281 |                       frame 0
282 |                       (make <closure>
283 |                             (lambda (v* _sr)
284 |                               (if (= 2 (:length v*))
285 |                                   (metak (:argument v* 0))
286 |                                   (runtime-error
287 |                                    "Wrong number of args"
288 |                                    "to continuation")))
289 |                             sr.init))
290 |                      (invoke f frame))))
291 |                 (runtime-error "Wrong number of args"
292 |                                "to call/cc")))
293 |           sr.init)))
294 | 
295 | ;; Finally, our repl
296 | 
297 | (define (repl)
298 |   (define (toplevel)
299 |     (set! *env* sr.init)
300 |     (display "> ")
301 |     (display ((meaning (read) r.init #t)))(newline)
302 |     (toplevel))
303 |   (toplevel))
304 | 
305 | ;; For the smoketest
306 | (define (eval-expr e)
307 |   (set! *env* sr.init)
308 |   ((meaning e r.init #t)))
309 | 
310 | (define-primitive '+ + 2)
311 | (define-primitive '- - 2)
312 | 
313 | ;; Exercise 6.2
314 | ;;
315 | ;; NB that NARY-CLOSURE uses the *env* register, so we need to give
316 | ;; that a value before we can invoke the constructed value.
317 | (set! *env* sr.init)
318 | (define-initial 'list ((NARY-CLOSURE (SHALLOW-ARGUMENT-REF 0) 0)))
319 | 
320 | ;; Exercise 6.4 might be interesting to come back to ..
321 | 


--------------------------------------------------------------------------------
/chapter6.ss:
--------------------------------------------------------------------------------
  1 | ;; In this interpreter, the static part of a program is explicitly
  2 | ;; separated from the dynamic. Broadly speaking, the static are the
  3 | ;; lexical environment and instructions, and the dynamic the
  4 | ;; activation frames and continuation.
  5 | ;;
  6 | ;; Activation frames represent memory: they store values against
  7 | ;; addresses. The environment maps names to those addresses,
  8 | ;; abstractly -- that is, we determine which activation frame will
  9 | ;; have the memory address while compiling, and look it up at
 10 | ;; runtime. The only representations of memory kept in this
 11 | ;; interpreter are the activation records and the memory for globals.
 12 | 
 13 | (load "prelude.ss")
 14 | 
 15 | (define (compiler-error . bobbins)
 16 |   (error bobbins))
 17 | 
 18 | (define (runtime-error . bobbins)
 19 |   (error bobbins))
 20 | 
 21 | (import type-system)
 22 | (import generic-procedures)
 23 | (import oo)
 24 | 
 25 | ;; Environments and activation records. Both contain maps, and
 26 | ;; activation records contain a link to the next record. Below we'll
 27 | ;; actually use assoc lists for lexical environments, so having two
 28 | ;; classes is overegging it, but it's what the book does.
 29 | 
 30 | (define-generics :next :next! :args :args! :argument :argument!)
 31 | 
 32 | (define-class (<environment>)
 33 |   (next :next :next!))
 34 | 
 35 | (define-class (<activation> <environment>)
 36 |   (args :args :args!))
 37 | 
 38 | (define-method (initialize (<activation> self)
 39 |                            (<number> size))
 40 |   (:args! self (make-vector size)))
 41 | 
 42 | (define-method (:argument (<activation> frame)
 43 |                           (<number> index))
 44 |   (vector-ref (:args frame) index))
 45 | 
 46 | (define-method (:argument! (<activation> frame)
 47 |                           (<number> index)
 48 |                           (<value> value))
 49 |   (vector-set! (:args frame) index value))
 50 | 
 51 | 
 52 | ;; Extend the activation frame (working memory)
 53 | (define (sr-extend* sr v*)
 54 |   (:next! v* sr)
 55 |   v*)
 56 | 
 57 | ;; Extend the environment. This works slightly differently to the
 58 | ;; activation records -- it's just a list of assoc lists. (Why?
 59 | ;; Because we only do lookups in the environment while pretreating
 60 | ;; expressions, resulting in *references to locations* in activation
 61 | ;; frames)
 62 | (define (r-extend* r n*)
 63 |   (cons n* r))
 64 | 
 65 | ;; See if the given name is a local variable in the given environment
 66 | (define (local-variable? r i n)
 67 |   (and (pair? r)
 68 |        (let scan ((names (car r))
 69 |                   (j 0))
 70 |          (cond ((pair? names)
 71 |                 (if (eq? n (car names))
 72 |                     `(local ,i . ,j)
 73 |                     (scan (cdr names) (+ j 1))))
 74 |                ((null? names)
 75 |                 (local-variable? (cdr r) (+ i 1) n))
 76 |                ;; Don't think I understand this clause -- why would
 77 |                ;; these be improper? A convenience perhaps
 78 |                ((eq? n names) `(local ,i . ,j))))))
 79 | 
 80 | ;; When we compile expressions, we replace variable references with
 81 | ;; lookups into the activation records (that's i for the number of
 82 | ;; frames up, and j for the slot). This is going to go retrieve the
 83 | ;; values for us.
 84 | (define (deep-fetch sr i j)
 85 |   (if (= i 0)
 86 |       (:argument sr j)
 87 |       (deep-fetch (:next sr) (- i 1) j)))
 88 | 
 89 | ;; Likewise for set!
 90 | (define (deep-update! sr i j value)
 91 |   (if (= i 0)
 92 |       (:argument! sr j value)
 93 |       (deep-update! (:next sr) (- i 1) j value)))
 94 | 
 95 | ;; Global (top-level) variables: these are in two varieties, mutable
 96 | ;; (defined by the program) and immutable (primitives). They can be
 97 | ;; shadowed of course, and we know this at interpretation time, so we
 98 | ;; can insert the correct lookup.
 99 | 
100 | ;; Global envs are just a list of (name (kind . addr)) i.e., an
101 | ;; assoc list. The addr is a vector index into our 'memory'.
102 | 
103 | ;; Mutable globals
104 | (define g.current '())
105 | ;; Predefined globals
106 | (define g.init '())
107 | 
108 | ;; And global memory is just a vector.
109 | (define sg.current (make-vector 100))
110 | (define sg.init (make-vector 100))
111 | 
112 | (define (g.current-extend! n)
113 |   (let ((level (length g.current)))
114 |     (set! g.current (cons (cons n `(global . ,level)) g.current))
115 |     level))
116 | 
117 | (define (g.init-extend! n)
118 |   (let ((level (length g.init)))
119 |     (set! g.init (cons (cons n `(predefined . ,level)) g.init))
120 |     level))
121 | 
122 | (define (compute-kind r n)
123 |   (or (local-variable? r 0 n)
124 |       (global-variable? g.current n)
125 |       (global-variable? g.init n)))
126 | 
127 | (define (global-variable? g n)
128 |   (let ((var (assq n g)))
129 |     (and (pair? var) (cdr var))))
130 | 
131 | (define (global-fetch i)
132 |   (vector-ref sg.current i))
133 | (define (predef-fetch i)
134 |   (vector-ref sg.init i))
135 | 
136 | (define (global-update! i v)
137 |   (vector-set! sg.current i v))
138 | 
139 | ;; OK now for real stuff.
140 | 
141 | ;; `meaning` is the compilation or (as per the book) pretreatment
142 | ;; step. The idea is to create a lambda that, given the store
143 | ;; (activation records) and the continuation, will execute the
144 | ;; program. While we're pretreating expressions, we maintain a lexical
145 | ;; environment so we know where to look to dereference variables.
146 | 
147 | ;; I'm finally going to cede to the book way of naming variables, in
148 | ;; particular environments 'r'. (Presumably r for \rho from chapter 5)
149 | 
150 | (define (meaning e r)
151 |   (if (pair? e)
152 |       (case (car e)
153 |         ((quote) (meaning-quotation (cadr e) r))
154 |         ((lambda) (meaning-abstraction (cadr e) (cddr e) r))
155 |         ((if) (meaning-alternative (cadr e) (caddr e) (cadddr e) r))
156 |         ((begin) (meaning-sequence (cdr e) r))
157 |         ((set!) (meaning-assignment (cadr e) (caddr e) r))
158 |         (else (meaning-application (car e) (cdr e) r)))
159 |       (if (symbol? e)
160 |           (meaning-deref e r)
161 |           (meaning-quotation e r))))
162 | 
163 | (define (meaning-quotation v r)
164 |   (lambda (sr k) (k v)))
165 | 
166 | (define (meaning-alternative e1 e2 e3 r)
167 |   (let ((m1 (meaning e1 r))
168 |         (m2 (meaning e2 r))
169 |         (m3 (meaning e3 r)))
170 |     (lambda (sr k)
171 |       (m1 sr (lambda (v)
172 |                ((if v m2 m3) sr k))))))
173 | 
174 | (define (meaning-sequence e+ r)
175 |   (if (pair? e+)
176 |       (if (pair? (cdr e+))
177 |           (meaning*-multiple-sequence (car e+) (cdr e+) r)
178 |           (meaning*-single-sequence (car e+) r))
179 |       (compiler-error "Empty begin")))
180 | 
181 | (define (meaning*-multiple-sequence e1 e+ r)
182 |   (let ((m1 (meaning e1))
183 |         (m+ (meaning-sequence e+ r)))
184 |     (lambda (sr k)
185 |       (m1 sr (lambda (v) (m+ sr k))))))
186 | (define (meaning*-single-sequence e r)
187 |   (meaning e r))
188 | 
189 | 
190 | ;; First tricky one: application. This makes us determine how
191 | ;; procedures are represented. (As per book, I'll just use a closure).
192 | ;; NB the book has some static checks for native procedures in here;
193 | ;; I've moved these to meaning-primitive-application.
194 | 
195 | (define (meaning-application e e* r)
196 |   (cond
197 |     ;; NB relies on the single-expression variety of cond clause
198 |     ((and (symbol? e)
199 |           (let ((kind (compute-kind r e)))
200 |             (and (pair? kind)
201 |                  (eq? 'predefined (car kind)))
202 |             ;; I've moved the arity checking into
203 |             ;; meaning-primitive-application, since we already have to
204 |             ;; do the description lookup there.
205 |             (meaning-primitive-application e e* r))))
206 |     ((and (pair? e)
207 |           (eq? 'lambda (car e)))
208 |      (meaning-closed-application e e* r))
209 |     (else
210 |       (meaning-regular-application e e* r))))
211 | 
212 | (define (meaning-regular-application e e* r)
213 |   (let* ((m (meaning e r))
214 |          (m* (meaning* e* r (length e*)))) ;; pass length for size of
215 |                                            ;; activation rec
216 |     (lambda (sr k)
217 |       (m sr (lambda (fn)
218 |               (if (procedure? fn) ;; object-procedure = meta-procedure
219 |                   (m* sr (lambda (v*)
220 |                            (fn v* k)))
221 |                   (runtime-error "Not a function" fn)))))))
222 | 
223 | ;; "left left lambda"
224 | (define (meaning-closed-application e ee* r)
225 |   (let ((nn* (cadr e)))
226 |     (let parse ((n* nn*)
227 |                 (e* ee*)
228 |                 (regular '()))
229 |       (cond
230 |         ((pair? n*)
231 |          (if (pair? e*)
232 |              (parse (cdr n*) (cdr e*) (cons (car n*) regular))
233 |              (compiler-error "Too few arguments: need" e "got" ee*)))
234 |         ((null? n*)
235 |          (if (null? e*)
236 |              (meaning-fix-closed-application nn* (cddr e) ee* r)
237 |              (compiler-error "Too many arguments: need" e "got" ee*)))
238 |         (else ;; augh, rest args in a let-ish form ..
239 |           (meaning-dotted-closed-application
240 |            (reverse regular) n* (cddr e) ee* r))))))
241 | 
242 | (define (meaning-fix-closed-application n* body e* r)
243 |   (let* ((m* (meaning* e* r (length e*)))
244 |          (r2 (r-extend* r n*))
245 |          (m+ (meaning-sequence body r2)))
246 |     (lambda (sr k)
247 |       (m* sr (lambda (v*)
248 |                (m+ (sr-extend* sr v*) k))))))
249 | 
250 | (define (meaning-dotted-closed-application n* n body e* r)
251 |   (let* ((m* (meaning-dotted* e* r (length e*) (length n*)))
252 |          (r2 (r-extend* r (append n* (list n))))
253 |          (m+ (meaning-sequence body r2)))
254 |     (lambda (sr k)
255 |       (m* sr (lambda (v*)
256 |                (m+ (sr-extend* sr v*) k))))))
257 | 
258 | ;; As the book says, because we know the number of arguments being
259 | ;; supplied, we can build the rest list as we go; essentially a
260 | ;; transformation of the 'excess' argument expressions from
261 | ;; r1 .. r2 .. r3 to (cons r1 (cons r2 (cons r3 '())))
262 | 
263 | (define (meaning-dotted* e* r size arity)
264 |   (if (pair? e*)
265 |       (meaning-some-dotted-args (car e*) (cdr e*) r size arity)
266 |       (meaning-no-dotted-arg r size arity)))
267 | 
268 | (define (meaning-some-dotted-args e e* r size arity)
269 |   (let ((m (meaning e r))
270 |         (m* (meaning-dotted* e* r size arity))
271 |         (rank (- size (length e*) 1)))
272 |     (if (< rank arity) ;; if still in 'obligatory' arguments
273 |         (lambda (sr k)
274 |           (m sr (lambda (v)
275 |                   (m* sr (lambda (v*)
276 |                            (:argument! v* rank v)
277 |                            (k v*))))))
278 |         ;; else we're in rest args
279 |         (lambda (sr k)
280 |           (m sr (lambda (v)
281 |                   (m* sr (lambda (v*)
282 |                            (:argument! v* arity (cons v (:argument v* arity)))
283 |                            (k v*)))))))))
284 | 
285 | (define (meaning-no-dotted-arg r size arity)
286 |   (let ((arity+1 (+ arity 1)))
287 |     (lambda (sr k)
288 |       (let ((v* (make <activation> arity+1)))
289 |         (:argument! v* arity '())
290 |         (k v*)))))
291 | 
292 | ;; Compile (a fixed number of) arguments. The continuation gets the
293 | ;; activation frame.
294 | (define (meaning* e* r size)
295 |   (if (pair? e*)
296 |       (meaning-some-args (car e*) (cdr e*) r size)
297 |       (meaning-no-args r size)))
298 | 
299 | ;; Make an activation frame for each invocation (see book for
300 | ;; discussion)
301 | (define (meaning-no-args r size)
302 |   (let ((size+1 (+ 1 size)))
303 |     (lambda (sr k)
304 |       (let ((v* (make <activation> size+1)))
305 |         (k v*)))))
306 | 
307 | (define (meaning-some-args e e* r size)
308 |   (let ((m1 (meaning e r))
309 |         (m* (meaning* e* r size))
310 |         (index (- size (length e*) 1)))
311 |     (lambda (sr k)
312 |       (m1 sr (lambda (v)
313 |                (m* sr (lambda (v*)
314 |                         (:argument! v* index v)
315 |                         (k v*))))))))
316 | 
317 | ;; All the environment stuff above is now useful for compiling -- I
318 | ;; mean pretreating -- variable references and assignment.
319 | 
320 | (define (meaning-deref n r)
321 |   (let ((kind (compute-kind r n)))
322 |     (if kind
323 |         (case (car kind)
324 |           ((local)
325 |            (let ((i (cadr kind))
326 |                  (j (cddr kind)))
327 |              (if (= i 0)
328 |                  (lambda (sr k)
329 |                    (k (:argument sr j)))
330 |                  (lambda (sr k)
331 |                    (k (deep-fetch sr i j))))))
332 |           ((global)
333 |            (let ((i (cdr kind)))
334 |              ;; This is of dubious utility -- only check later if it's
335 |              ;; undefined now
336 |              (if (eq? (global-fetch i) UNDEFINED)
337 |                  (lambda (sr k)
338 |                    (let ((value (global-fetch i)))
339 |                      (if (eq? value UNDEFINED)
340 |                          (runtime-error "variable not defined" n))))
341 |                  (lambda (sr k) (k (global-fetch i))))))
342 |           ((predefined)
343 |            (let* ((i (cdr kind))
344 |                   (value (predef-fetch i)))
345 |              (lambda (sr k)
346 |                (k value)))))
347 |         (compiler-error "No such variable:" n))))
348 | 
349 | (define (meaning-assignment n e r)
350 |   (let ((m (meaning e r))
351 |         (kind (compute-kind r n)))
352 |     (if kind
353 |         (case (car kind)
354 |           ((local)
355 |            (let ((i (cadr kind))
356 |                  (j (cddr kind)))
357 |              (if (= i 0)
358 |                  (lambda (sr k)
359 |                    (m sr (lambda (val)
360 |                            (k (:argument! sr j val)))))
361 |                  (lambda (sr k)
362 |                    (m sr (lambda (val)
363 |                            (k (deep-update! sr i j val))))))))
364 |           ((global)
365 |            (let ((i (cdr kind)))
366 |              (lambda (sr k)
367 |                (m sr (lambda (v)
368 |                        (k (global-update! i v)))))))
369 |           ((predefined)
370 |            (compiler-error "Assignment to immutable variable:" n)))
371 |         (compiler-error "No such variable:" n))))
372 | 
373 | ;; Lambdas
374 | 
375 | ;; arity+1, and size+1 above, because we may have to collect up extra
376 | ;; arguments into a list when we do the application.
377 | 
378 | (define (meaning-fix-abstraction n* e+ r)
379 |   (let* ((arity (length n*))
380 |          (arity+1 (+ 1 arity))
381 |          (r2 (r-extend* r n*))
382 |          (m+ (meaning-sequence e+ r2)))
383 |     (lambda (sr k)
384 |       (k (lambda (v* k1)
385 |            (if (= (vector-length (:args v*)) arity+1)
386 |                (m+ (sr-extend* sr v*) k1)
387 |                (runtime-error "Incorrect arity:" arity
388 |                               "; expected:"
389 |                               (vector-length (:args v*)))))))))
390 | 
391 | (define (meaning-dotted-abstraction n* n e+ r)
392 |   (let* ((arity (length n*))
393 |          (arity+1 (+ 1 arity))
394 |          (r2 (r-extend* r (append n* (list n))))
395 |          (m+ (meaning-sequence e+ r2)))
396 |     (lambda (sr k)
397 |       (k (lambda (v* k1)
398 |            (if (>= (vector-length (:args v*)) arity+1)
399 |                (begin (listify! v* arity)
400 |                       (m+ (sr-extend* sr v*) k1))
401 |                (runtime-error "Insufficient args:" v*
402 |                               "; expected: " arity)))))))
403 | 
404 | ;; Takes rest args, conses them into a list, and pops them into the
405 | ;; magical extra activation frame slot. Interesting point from Tony:
406 | ;; when `apply`ing a procedure, you don't want to be taking the list
407 | ;; or arguments apart just to put it back together, so it's worth
408 | ;; having a different entry point for `apply`. Extra for experts ..
409 | (define (listify! v* arity)
410 |   (let loop ((index (- (:length v*) 1))
411 |              (result '()))
412 |     (if (= arity index)
413 |         (:argument! v* arity result)
414 |         (loop (- index 1)
415 |               (cons (:argument v* (- index 1)) result)))))
416 | 
417 | (define (meaning-abstraction nn* e+ r)
418 |   (let parse ((n* nn*)
419 |               (regular '()))
420 |     (cond
421 |       ((pair? n*) (parse (cdr n*) (cons (car n*) regular)))
422 |       ((null? n*) (meaning-fix-abstraction nn* e+ r))
423 |       (else (meaning-dotted-abstraction (reverse regular) n* e+ r)))))
424 | 
425 | ;; === Now for the repl
426 | 
427 | ;; Initial env
428 | (define r.init '())
429 | ;; Initial memory
430 | (define sr.init (make <activation> 0))
431 | 
432 | ;; Redefine or initialise a global variable (either predef'd or user).
433 | ;; This ties the global environments earlier to our top-level
434 | ;; environment and store.
435 | 
436 | (define UNDEFINED '(constant . undefined))
437 | 
438 | (define (g.current-init! name)
439 |   ;; I don't know why r.init is here, since it doesn't contain
440 |   ;; anything; possibly for generality, in case something does get
441 |   ;; added to it? I guess something has to go in that argument
442 |   ;; position, and if I change the representation of envs, r.init
443 |   ;; will change with it.
444 |   (let ((kind (compute-kind r.init name)))
445 |     (if kind
446 |         (case (car kind)
447 |           ((global)
448 |            (global-update! (cdr kind) UNDEFINED))
449 |           (else
450 |             (compiler-error "Bad redefinition" name kind)))
451 |         (let ((index (g.current-extend! name)))
452 |           (global-update! index UNDEFINED))))
453 |   name)
454 | 
455 | (define (g.init-init! name value)
456 |   ;; As above, not sure why r.init is here
457 |   (let ((kind (compute-kind r.init name)))
458 |     (if kind
459 |         (case (car kind)
460 |           ((predefined)
461 |            (vector-set! sg.init (cdr kind) value))
462 |           (else (compiler-error "Bad redefinition" name kind)))
463 |         (let ((index (g.init-extend! name)))
464 |           (vector-set! sg.init index value))))
465 |   name)
466 | 
467 | 
468 | ;; Primitives, definition of. The book has a separate environment for
469 | ;; the definitions of primitives, used only during pretreatment when
470 | ;; the name refers directly to the primitive (and so will I).
471 | (define desc.init '())
472 | (define (description-extend! name description)
473 |   (set! desc.init (cons (cons name description) desc.init))
474 |   name)
475 | (define (get-description name)
476 |   (let ((d (assq name desc.init)))
477 |     (and (pair? d) (cdr d))))
478 | 
479 | ;; I.e., a predefined. This isn't actually given in the book
480 | (define (define-initial name value)
481 |   (g.init-init! name value))
482 | 
483 | ;; The book has here syntax, and below a (case ...) expression,
484 | ;; testing the arity or number of arguments given, with an else clause
485 | ;; resorting to regular application. This can only be an optimisation,
486 | ;; for when the procedure is named and applied in the same place. So:
487 | ;; the underlying procedure (just taking arguments) ends up in the
488 | ;; description for static application; while the behaviour (taking an
489 | ;; activation frame) ends up in the environment, for regular
490 | ;; application. Note that I don't record a list of variables, just the
491 | ;; arity.
492 | (define (define-primitive name underlying arity)
493 | 
494 |   ;; Nicked from http://srfi.schemers.org/srfi-1/srfi-1-reference.scm
495 |   (define (take lis k)
496 |     (let recur ((lis lis) (k k))
497 |       (if (zero? k) '()
498 |           (cons (car lis)
499 |                 (recur (cdr lis) (- k 1))))))
500 |   
501 |   (define-initial name
502 |     ;; not sure why it's a letrec in the book
503 |     (let* ((arity+1 (+ arity 1))
504 |            ;; behaviour is called with the activation record
505 |            (behaviour (lambda (v* k)
506 |                         (let* ((args (:args v*))
507 |                                (numargs (vector-length args))) 
508 |                           (if (= arity+1 numargs)
509 |                               (k (apply underlying
510 |                                         (take (vector->list args) arity)))
511 |                               (runtime-error "Wrong arity" arity numargs))))))
512 |       (description-extend! name `(function ,underlying ,arity))
513 |       behaviour)))
514 | 
515 | ;; Here is where my laziness above wrt arity makes things tricky;
516 | ;; instead of having clauses for the different arities, I have to do a
517 | ;; kind of CPS fold over the expressions.  I have moved some of the
518 | ;; checking of the description here from meaning-application, to avoid
519 | ;; getting the description twice. As in the book, if the expression is
520 | ;; statically known to be predefined (which is why we're here), but
521 | ;; the description is not present (um, why?), we fall through to
522 | ;; regular application.
523 | (define (meaning-primitive-application e e* r)
524 |   (let ((desc (get-description e)))
525 |     (and desc
526 |          (eq? 'function (car desc))
527 |          (if (= (caddr desc) (length e*))
528 |              (let ((addr (cadr desc))
529 |                    (m*
530 |                     (let loop ((m* '())
531 |                                (e* e*))
532 |                       (if (null? e*)
533 |                           (reverse m*)
534 |                           (loop (cons (meaning (car e*) r) m*) (cdr e*))))))
535 |                ;; Now I have all the meanings, that is procedures that
536 |                ;; take an activation frame and a continuation, where
537 |                ;; the continuation takes a value.  I want to chain
538 |                ;; them together, making the continuation of the first
539 |                ;; call the second, and so on:
540 |                ;; (m1 sr (lambda (v1) (m2 sr (lambda (v2) ...))))
541 |                (if (null? m*)
542 |                    (lambda (sr k) (k (addr)))
543 |                    (lambda (sr k)
544 |                      (let loop ((vs '())
545 |                                 (m* m*))
546 |                        (let ((m (car m*))
547 |                              (ms (cdr m*)))
548 |                          (if (null? ms)
549 |                              (m sr (lambda (v)
550 |                                      (k (apply addr (reverse (cons v vs))))))
551 |                              (m sr (lambda (v)
552 |                                      (loop (cons v vs) ms)))))))))
553 |              (compiler-error "Wrong arity for procedure" e
554 |                              "expected" (caddr desc)
555 |                              "given" (length e*))))))
556 | 
557 | 
558 | 
559 | (define (repl)
560 |   (define (toplevel)
561 |     (display "> ")
562 |     ((meaning (read) r.init) sr.init display)(newline)
563 |     (toplevel))
564 |   (toplevel))
565 | 
566 | ;; For the smoketest
567 | (define (eval-expr e)
568 |   (call/cc (lambda (k)
569 |              ((meaning e r.init) sr.init k))))
570 | 
571 | ;; Things to play with
572 | (define-primitive '+ + 2)
573 | (define-primitive '- - 2)
574 | 
575 | ;; The book doesn't go on to detail apply and call/cc until §6.3, by
576 | ;; which time the interpreter has changed significantly. In the
577 | ;; interests of moving on, I'll leave them aside too.
578 | 


--------------------------------------------------------------------------------
/chapter7.4.ss:
--------------------------------------------------------------------------------
  1 | ;; Follows on from the first chapter 7 compiler by compiling to byte
  2 | ;; codes, which can be more readily serialised to files.
  3 | 
  4 | (load "prelude.ss")
  5 | (load "env.ss")
  6 | (load "closure.ss")
  7 | 
  8 | 
  9 | ;; Registers
 10 | (define *env* undefined-value)
 11 | (define *val* undefined-value)
 12 | (define *stack* undefined-value)
 13 | 
 14 | (define (stack-new) '())
 15 | 
 16 | (define (stack-push v)
 17 |   (set! *stack* (cons v *stack*)))
 18 | 
 19 | (define (stack-pop)
 20 |   (let ((v (car *stack*)))
 21 |     (set! *stack* (cdr *stack*))
 22 |     v))
 23 | 
 24 | (define (stack-save)
 25 |   *stack*)
 26 | 
 27 | (define (stack-restore s)
 28 |   (set! *stack* s))
 29 | 
 30 | (define *fun* undefined-value)
 31 | 
 32 | (define *arg1* undefined-value)
 33 | (define *arg2* undefined-value)
 34 | 
 35 | (define *pc* undefined-value)
 36 | 
 37 | ;; An extra register for literals in a program
 38 | (define *constants* (make-vector 100))
 39 | 
 40 | ;; And one to hold our eventual escape procedure
 41 | (define *exit* 'blowup)
 42 | 
 43 | ;; OK registers and stack done. Now, a means to define our opcodes.
 44 | ;; Taken straight from the book.
 45 | 
 46 | (define (fetch-byte)
 47 |   (let ((byte (car *pc*)))
 48 |     (set! *pc* (cdr *pc*))
 49 |     byte))
 50 | 
 51 | (define-syntax define-instruction-set
 52 |   (syntax-rules (define-instruction)
 53 |     ((define-instruction-set
 54 |        step instruction-size instruction-decode
 55 |        (define-instruction (name . args) opcode . body)
 56 |        ...)
 57 |      (begin
 58 |        ;; I'd rather have a stepper here
 59 |        (define (step)
 60 |          (let ((instruction (fetch-byte)))
 61 |            (case instruction
 62 |              ((opcode) (run-clause args body))
 63 |              ...)))
 64 | 
 65 |        ;; In my compiler, the program counter is a cons cell, so it
 66 |        ;; represents both the program code and an instruction or
 67 |        ;; argument
 68 |        (define (instruction-size pc)
 69 |          (case (car pc)
 70 |            ((opcode) (size-of-clause args))
 71 |             ...))
 72 |        (define (instruction-decode pc)
 73 |          ;; Renamed, this is confusing in the book
 74 |          (define (local-fetch-byte)
 75 |            (let ((byte (car pc)))
 76 |              (set! pc (cdr pc))
 77 |              byte))
 78 |          
 79 |          (let-syntax
 80 |              ((decode-clause
 81 |                (syntax-rules ()
 82 |                  ((decode-clause instruction ()) '(instruction))
 83 |                  ((decode-clause instruction (a))
 84 |                   (let ((a (local-fetch-byte))) `(instruction ,a)))
 85 |                  ((decode-clause instruction (a b))
 86 |                   (let* ((a (local-fetch-byte))
 87 |                          (b (local-fetch-byte))) `(instruction ,a ,b))))))
 88 |            (let ((instruction (local-fetch-byte)))
 89 |              (case instruction
 90 |                ((opcode) (decode-clause name args))
 91 |                ...))))))))
 92 | 
 93 | (define-syntax run-clause
 94 |   (syntax-rules ()
 95 |     ((run-clause () body) (begin . body))
 96 |     ((run-clause (a) body)
 97 |      (let ((a (fetch-byte))) . body))
 98 |     ((run-clause (a b) body)
 99 |      (let* ((a (fetch-byte)) (b (fetch-byte)))
100 |        . body))))
101 | 
102 | (define-syntax size-of-clause
103 |   (syntax-rules ()
104 |     ((size-clause ())    1)
105 |     ((size-clause (a))   2)
106 |     ((size-clause (a b)) 3)))
107 | 
108 | ;; Phew! All done with the macros. Now we have to actually specify the
109 | ;; combinators and instructions!
110 | 
111 | ;; verify that the proposed operand is indeed a byte
112 | (define (check-byte i)
113 |   (unless (and (>= i 0) (< i 256))
114 |     (compiler-error "This number does not fit in a byte!" i)))
115 | 
116 | (define (SHALLOW-ARGUMENT-REF index) (list 5 index))
117 |   
118 | ;; In the previous compiler I wasn't sure why this and
119 | ;; SET-SHALLOW-ARGUMENT! had been separated. Now the answer is clear:
120 | ;; this is a combinator, and SET-SHALLOW-ARGUMENT! is an instruction.
121 | (define (SHALLOW-ASSIGNMENT! j m)
122 |   (append m (SET-SHALLOW-ARGUMENT! j)))
123 | 
124 | (define (SET-SHALLOW-ARGUMENT! j) (list 25 j))
125 | 
126 | (define (DEEP-ARGUMENT-REF level index) (list 6 level index))
127 | 
128 | (define (DEEP-ASSIGNMENT! i j m)
129 |   (append m (SET-DEEP-ARGUMENT! i j)))
130 | 
131 | (define (SET-DEEP-ARGUMENT! i j) (list 26 i j))
132 | 
133 | (define (GLOBAL-SET! i m)
134 |   (append m (SET-GLOBAL! i)))
135 | (define (SET-GLOBAL! i) (list 27 i))
136 | 
137 | ;; This changes significantly, since we can sprinkle opcodes around
138 | ;; freely.
139 | (define (PREDEFINED i)
140 |   (check-byte i)
141 |   (case i
142 |     ((0 1 2 3 4 5 6 7 8) (list (+ 10 i))) ;; i.e., our opcodes for hard-wired
143 |                                    ;; predefines start at 10
144 |     (else (list 19 i)))) ;; and the generic instruction is straight after
145 | 
146 | ;; This is used during compilation, to collect literals. When running
147 | ;; code, the quotations are put in the register *constants*.
148 | (define *quotations* '())
149 | 
150 | ;; As with predefined variables, common quotations are given their own
151 | ;; opcodes; some are reused from the predefines
152 | (define (CONSTANT v)
153 |   (cond
154 |     ((eq? v #t)    (list 10))
155 |     ((eq? v #f)    (list 11))
156 |     ((eq? v '())   (list 12))
157 |     ;; some allegedly commonly-used integers get their own opcodes
158 |     ((equal? v -1) (list 80))
159 |     ((equal? v 0)  (list 81))
160 |     ((equal? v 1)  (list 82))
161 |     ((equal? v 2)  (list 83))
162 |     ((equal? v 3)  (list 84))
163 |     ;; other integers up to 255 get an opcode and an operand of the
164 |     ;; number itself
165 |     ((and (integer? v) (<= 0 v) (< v 256)) ;; book has 255 here?
166 |      (list 79 v))
167 |     (else (EXPLICIT-CONSTANT v))))
168 | 
169 | ;; NB no attempt to dedup constants
170 | (define (EXPLICIT-CONSTANT v)
171 |   (set! *quotations* (append *quotations* (list v)))
172 |   (list 9 (- (length *quotations*) 1)))
173 | 
174 | ;; Conditional and unconditional jumps
175 | (define (JUMP-FALSE offset)
176 |   (cond
177 |     ((< offset 256) (list 31 offset)) ;; book has < 255??
178 |     ((< offset (* 256 256))
179 |      (let ((lower  (modulo offset 256))
180 |            (higher (quotient offset 256)))
181 |        (list 29 lower higher))) ;; NB little-endian
182 |     (else (compiler-error "Jump too large" offset))))
183 | 
184 | (define (GOTO offset)
185 |   (cond
186 |     ((< offset 256) (list 30 offset)) ;; book has < 255??
187 |     ((< offset (* 256 256))
188 |      (let ((lower  (modulo offset 256))
189 |            (higher (quotient offset 256)))
190 |        (list 28 lower higher))) ;; NB little-endian
191 |     (else (compiler-error "Jump too large" offset))))
192 | 
193 | (define (ALTERNATIVE m1 m2 m3)
194 |   ;; GOTO can be different lengths now, so we have to do it first
195 |   (let ((mm2 (append m2 (GOTO (length m3)))))
196 |     (append m1 ;; result of test clause to *val*
197 |             (JUMP-FALSE (length mm2)) ;; jump over success k (and goto)
198 |             mm2 ;; success k, including GOTO
199 |             m3)))
200 | 
201 | ;; A bunch of simple ops
202 | (define (EXTEND-ENV) (list 32))
203 | (define (UNLINK-ENV) (list 33))
204 | (define (PUSH-VALUE) (list 34))
205 | (define (POP-ARG1) (list 35))
206 | (define (POP-2ARG) (list 36))
207 | (define (PRESERVE-ENV) (list 37))
208 | (define (RESTORE-ENV) (list 38))
209 | (define (POP-FUNCTION) (list 39))
210 | (define (CREATE-CLOSURE offset) (list 40 offset))
211 | (define (RETURN) (list 43))
212 | (define (PACK-FRAME! arity) (list 44 arity))
213 | (define (FUNCTION-INVOKE) (list 45))
214 | (define (FUNCTION-GOTO) (list 46))
215 | (define (POP-FRAME! rank) (list 64 rank))
216 | (define (POP-CONS-FRAME! arity) (list 47 arity))
217 | (define (ALLOCATE-FRAME size) (list 55 (+ size 1)))
218 | (define (ALLOCATE-DOTTED-FRAME arity) (list 56 (+ arity 1)))
219 | (define (ARITY>=? arity+1) (list 78 arity+1))
220 | (define (ARITY=? n) (list 75 (+ n 1)))
221 | 
222 | 
223 | ;; These are "just" combinators
224 | 
225 | (define (NARY-CLOSURE m+ arity)
226 |   (define the-function
227 |     (append (ARITY>=? (+ arity 1)) ;; bail if not enough arguments
228 |             (PACK-FRAME! arity) ;; collect varargs
229 |             (EXTEND-ENV) ;; extend *env* with arguments
230 |             m+ ;; execute the forms
231 |             (RETURN)))
232 |   (append (CREATE-CLOSURE 1) ;; make a closure that starts at pc+1
233 |           (GOTO (length the-function)) ;; skip the definition
234 |           the-function))
235 | 
236 | (define (SEQUENCE m m+)
237 |   (append m m+))
238 | 
239 | (define (TR-FIX-LET m* m+)
240 |   (append m* (EXTEND-ENV) m+))
241 | (define (FIX-LET m* m+)
242 |   (append m* (EXTEND-ENV) m+ (UNLINK-ENV)))
243 | 
244 | ;; The CALL* opcodes are used when the head of a function is a symbol
245 | ;; resolving to a primitive. An opcode is reserved for each primitive,
246 | ;; effectively hard-wiring its definition into the byte-code
247 | ;; intepreter. This, CALL puts the arguments onto the stack, and
248 | ;; INVOKE calls the respective opcode.  (NB this means all the
249 | ;; primitives mentioned here must be declared as such, below)
250 | (define (CALL0 address)
251 |   (INVOKE0 address))
252 | 
253 | ;; In the book it's assumed that (case ..) will work with procedures;
254 | ;; however, in SISC, native procedures do not have a repr of their
255 | ;; name, so they are not eqv? to their respective symbol. So, I have
256 | ;; to use cond and eq?.
257 | 
258 | (define (INVOKE0 address)
259 |   (cond
260 |     ((eq? address read)    (list 89))
261 |     ((eq? address newline) (list 88))
262 |     (else (compiler-error "Unknown primitive" address))))
263 | 
264 | (define (CALL1 address m1)
265 |   (append m1 (INVOKE1 address)))
266 | 
267 | (define (INVOKE1 address)
268 |   (cond
269 |     ((eq? address car)     (list 90))
270 |     ((eq? address cdr)     (list 91))
271 |     ((eq? address pair?)   (list 92))
272 |     ((eq? address symbol?) (list 93))
273 |     ;; omit some ...
274 |     (else (compile-error "Unknown primitive" address))))
275 | 
276 | (define (CALL2 address m1 m2)
277 |   (append m1 ;; m1 -> *val*
278 |           (PUSH-VALUE) ;; m1 -> stack
279 |           m2 ;; m2 -> *val*
280 |           (POP-ARG1) ;; m1 -> *arg1*
281 |           (INVOKE2 address)))
282 | 
283 | (define (INVOKE2 address)
284 |   (cond
285 |     ((eq? address cons) (list 100))
286 |     ((eq? address eq?)  (list 101))
287 |     ;; no setcar!, no set-cdr!
288 |     ((eq? address +)    (list 104))
289 |     ((eq? address -)    (list 105))
290 |     ((eq? address =)    (list 106))
291 |     ((eq? address <)    (list 107))
292 |     ((eq? address >)    (list 108))
293 |     ((eq? address *)    (list 109))
294 |     ((eq? address <=)   (list 110))
295 |     ((eq? address >=)   (list 111))
296 |     ;; remainder? who uses remainder?
297 |     (else (compiler-error "Unknown primitive" address))))
298 | 
299 | (define (CALL3 address m1 m2 m3)
300 |   (append m1 (PUSH-VALUE)
301 |           m2 (PUSH-VALUE)
302 |           m3
303 |           (POP-2ARG)
304 |           (INVOKE3 address)))
305 | 
306 | (define (INVOKE3 address)
307 |   (compiler-error "No known primitives of 3 arguments"))
308 | 
309 | (define (FIX-CLOSURE m+ arity)
310 |   (define the-function
311 |     (append (ARITY=? arity)
312 |             (EXTEND-ENV)
313 |             m+
314 |             (RETURN)))
315 |   (let ((goto (GOTO (length the-function))))
316 |     (append (CREATE-CLOSURE (length goto))
317 |             goto
318 |             the-function)))
319 | 
320 | (define (REGULAR-CALL m m*)
321 |   (append m (PUSH-VALUE)
322 |           m*
323 |           (POP-FUNCTION)
324 |           (PRESERVE-ENV) (FUNCTION-INVOKE) (RESTORE-ENV)))
325 | 
326 | (define (TR-REGULAR-CALL m m*)
327 |   (append m (PUSH-VALUE)
328 |           m* (POP-FUNCTION)
329 |           (FUNCTION-GOTO)))
330 | 
331 | (define (STORE-ARGUMENT m m* rank)
332 |   (append m (PUSH-VALUE) m* (POP-FRAME! rank)))
333 | 
334 | (define (CONS-ARGUMENT m m* arity)
335 |   (append m (PUSH-VALUE) m* (POP-CONS-FRAME! arity)))
336 | 
337 | (define (FINISH) (list 20))
338 | 
339 | ;; Define closures, and an invoke that is told whether it's a tail
340 | ;; call or not
341 | (define-method (initialize (<closure> self)
342 |                            (<list> code)
343 |                            (<activation> closed))
344 |   (init* self 
345 |          :code! code
346 |          :closed-env! closed))
347 | 
348 | (define-method (invoke (<closure> f) (<boolean> tail?))
349 |   (unless tail? (stack-push *pc*))
350 |   (set! *env* (:closed-env f))
351 |   (set! *pc* (:code f)))
352 | 
353 | ;; Now our instructions
354 | 
355 | (define-instruction-set step instruction-size instruction-decode
356 | 
357 |   ;; Nothing in 0, it's bad luck!
358 |   
359 |   ;; The book expands this and set-shallow-argument into 0, 1, 2, 3
360 |   ;; variations. I'm happy with just these for the minute.
361 |   (define-instruction (SHALLOW-ARGUMENT-REF index)    5
362 |     (set! *val* (:argument *env* index)))
363 | 
364 |   (define-instruction (DEEP-ARGUMENT-REF level index) 6
365 |     (set! *val* (deep-fetch *env* level index)))
366 | 
367 |   (define-instruction (GLOBAL-REF index)              7
368 |     (set! *val* (global-fetch index)))
369 |   
370 |   (define-instruction (CHECKED-GLOBAL-REF index)      8
371 |     (let ((v (global-fetch index)))
372 |       (if (eq? v undefined-value)
373 |           (runtime-error "Uninitialised variable")
374 |           ;; %% patch GLOBAL-REF into *pc*
375 |           (set! *val* v))))
376 |   
377 |   (define-instruction (CONSTANT i)                    9
378 |     (set! *val* (vector-ref *constants* i)))
379 |   
380 |   (define-instruction (PREDEFINED_HASHT)              10
381 |     (set! *val* #t))
382 |   (define-instruction (PREDEFINED_HASHF)              11
383 |     (set! *val* #f))
384 |   (define-instruction (PREDEFINED_NIL)                12
385 |     (set! *val* '()))
386 |   (define-instruction (PREDEFINED_CONS)               13
387 |     (set! *val* (predef-fetch 3)))
388 |   (define-instruction (PREDEFINED_CAR)                14
389 |     (set! *val* (predef-fetch 4)))
390 |   (define-instruction (PREDEFINED_CDR)                15
391 |     (set! *val* (predef-fetch 5)))
392 |   (define-instruction (PREDEFINED_PAIR?)              16
393 |     (set! *val* (predef-fetch 6)))
394 |   (define-instruction (PREDEFINED_SYMBOL?)            17
395 |     (set! *val* (predef-fetch 7)))
396 |   (define-instruction (PREDEFINED_EQ?)                18
397 |     (set! *val* (predef-fetch 8)))
398 | 
399 |   (define-instruction (PREDEFINED j)                  19
400 |     (set! *val* (predef-fetch j)))
401 | 
402 |   ;; Call the elsehwre-defined exit handler
403 |   (define-instruction (FINISH)                        20
404 |     (*exit* *val*))
405 |   
406 |   ;; %% SET-SHALLOW-ARGUMENT!0 through 3 start at 21
407 |   
408 |   (define-instruction (SET-SHALLOW-ARGUMENT! j)       25
409 |     (:argument! *env* j *val*))
410 | 
411 |   (define-instruction (SET-DEEP-ARGUMENT! i j)        26
412 |     (deep-update! *env* i j *val*))
413 | 
414 |   (define-instruction (SET-GLOBAL! i)                 27
415 |     (global-update! i *val*))
416 | 
417 |   ;; ... and this is why the stack is a vector ..
418 |   (define-instruction (LONG-GOTO lower higher)        28
419 |     (let ((offset (+ (* higher 256) lower)))
420 |       (set! *pc* (list-tail *pc* offset))))
421 |   (define-instruction (LONG-JUMP lower higher)        29
422 |     (if (not *val*)
423 |         (let ((offset (+ (* higher 256) lower)))
424 |           (set! *pc* (list-tail *pc* offset)))))
425 | 
426 |   (define-instruction (SHORT-GOTO offset)             30
427 |     (set! *pc* (list-tail *pc* offset)))
428 |   (define-instruction (SHORT-JUMP-FALSE offset)       31
429 |     (if (not *val*)
430 |         (set! *pc* (list-tail *pc* offset))))
431 | 
432 |   (define-instruction (EXTEND-ENV)                    32
433 |     (set! *env* (extend *env* *val*)))
434 |   (define-instruction (UNLINK-ENV)                    33
435 |     (set! *env* (:next *env*)))
436 | 
437 |   (define-instruction (PUSH-VALUE)                    34
438 |     (stack-push *val*))
439 |   (define-instruction (POP-ARG1)                      35
440 |     (set! *arg1* (stack-pop)))
441 |   ;; NB here I differ from the book, this pops both arg registers, in
442 |   ;; the same opcode
443 |   (define-instruction (POP-2ARG)                      36
444 |     (begin (set! *arg2* (stack-pop))
445 |            (set! *arg1* (stack-pop))))
446 |   (define-instruction (PRESERVE-ENV)                  37
447 |     (stack-push *env*))
448 |   (define-instruction (RESTORE-ENV)                   38
449 |     (set! *env* (stack-pop)))
450 |   (define-instruction (POP-FUNCTION)                  39
451 |     (set! *fun* (stack-pop)))
452 | 
453 |   (define-instruction (CREATE-CLOSURE offset)         40
454 |     (set! *val*
455 |       (make <closure>
456 |             (list-tail *pc* offset) *env*)))
457 | 
458 |   ;; 41, 42 not present in the book (code). Maybe later?
459 |   
460 |   (define-instruction (RETURN)                        43
461 |     (set! *pc* (stack-pop)))
462 | 
463 |   (define-instruction (PACK-FRAME! arity)             44
464 |     (listify! *val* arity))
465 |   
466 |   (define-instruction (FUNCTION-INVOKE)               45
467 |     (invoke *fun* #f))
468 |   (define-instruction (FUNCTION-GOTO)                 46
469 |     (invoke *fun* #t))
470 | 
471 |   (define-instruction (POP-CONS-FRAME! arity)         47
472 |     (:argument! *val* arity
473 |                 (cons (stack-pop)
474 |                       (:argument *val* arity))))
475 | 
476 |   ;; 48, 49 free
477 |   
478 |   ;; %% ALLOCATE-FRAME of sizes 1-5 start at 50
479 |   (define-instruction (ALLOCATE-FRAME size+1)         55
480 |     (set! *val* (make <activation> size+1)))
481 | 
482 |   (define-instruction (ALLOCATE-DOTTED-FRAME arity+1) 56
483 |     (let ((v* (make <activation> arity+1)))
484 |       (:argument! v* (- arity+1 1) '())
485 |       (set! *val* v*)))
486 | 
487 |   ;; 57, 58, 59 free
488 |   
489 |   ;; %% 60-63 specialised versions of pop-frame
490 |   (define-instruction (POP-FRAME! rank)               64
491 |     (:argument! *val* rank (stack-pop)))
492 | 
493 |   ;; 65-69 free
494 |   
495 |   ;; %% 70-74 ARITY=? from 0-4
496 | 
497 |   (define-instruction (ARITY=? arity+1)               75
498 |     (unless (= (:length *val*) arity+1)
499 |       (runtime-error "Expected " (- arity+1 1)
500 |                      "arguments; got "
501 |                      (- (:length *val*) 1))))
502 | 
503 |   ;; 76, 77 free
504 |   
505 |   ;; No specialisations, since these are used for dotted lambdas.
506 |   (define-instruction (ARITY>=? arity+1)              78
507 |     (if (< (:length *val*) arity+1)
508 |         (runtime-error "Too few arguments")))
509 |   
510 |   ;; integer 0 <= i < 256
511 |   (define-instruction (INT i)                         79
512 |     (set! *val* i))
513 |   
514 |   (define-instruction (INT_NEG1)                      80
515 |     (set! *val* -1))
516 |   (define-instruction (INT_0)                         81
517 |     (set! *val* 0))
518 |   (define-instruction (INT_1)                         82
519 |     (set! *val* 1))
520 |   (define-instruction (INT_2)                         83
521 |     (set! *val* 2))
522 |   (define-instruction (INT_3)                         84
523 |     (set! *val* 3))
524 | 
525 |   ;; inlined primitives
526 |   (define-instruction (CALL0-newline)                 88
527 |     (newline))
528 |   (define-instruction (CALL0-read)                    89
529 |     (set! *val* (read)))
530 | 
531 |   (define-instruction (CALL1-car)                     90
532 |     (set! *val* (car *val*)))
533 |   (define-instruction (CALL1-cdr)                     91
534 |     (set! *val* (cdr *val*)))
535 |   (define-instruction (CALL1-pair?)                   92
536 |     (set! *val* (car *val*)))
537 |   (define-instruction (CALL1-symbol?)                 93
538 |     (set! *val* (car *val*)))
539 |   ;; omitted: display
540 | 
541 |   (define-instruction (CALL2-cons)                    100
542 |     (set! *val* (cons *arg1* *val*)))
543 |   (define-instruction (CALL2-eq?)                     101
544 |     (set! *val* (eq? *arg1* *val*)))
545 |   (define-instruction (CALL2-PLUS)                    104
546 |     (set! *val* (+ *arg1* *val*)))
547 |   (define-instruction (CALL2-MINUS)                   105
548 |     (set! *val* (- *arg1* *val*)))
549 |   (define-instruction (CALL2-EQUAL)                   106
550 |     (set! *val* (= *arg1* *val*)))
551 |   (define-instruction (CALL2-LT)                      107
552 |     (set! *val* (< *arg1* *val*)))
553 |   (define-instruction (CALL2-GT)                      108
554 |     (set! *val* (> *arg1* *val*)))
555 |   (define-instruction (CALL2-TIMES)                   109
556 |     (set! *val* (* *arg1* *val*)))
557 |   (define-instruction (CALL2-LTE)                     110
558 |     (set! *val* (<= *arg1* *val*)))
559 |   (define-instruction (CALL2-GTE)                     111
560 |     (set! *val* (>= *arg1* *val*)))
561 |   
562 |   ) ;; end of define-instruction-set
563 | 
564 | (load "pretreat.ss")
565 | 
566 | ;; Execution
567 | 
568 | (define (compile/standalone expression)
569 |   (set! *quotations* '())
570 |   (let* ((m (meaning expression r.init #t))
571 |          (finish-pc (code-epilogue))
572 |          (start-pc (append m (RETURN)))
573 |          (global-names (map car (reverse g.current)))
574 |          (constants (apply vector *quotations*)))
575 |     (lambda ()
576 |       (run-machine start-pc finish-pc constants global-names))))
577 | 
578 | (define (disassemble pc)
579 |   (let loop ((pc pc)
580 |              (instructions '()))
581 |     (cond
582 |       ((null? pc) (reverse instructions))
583 |       (else (loop (list-tail pc (instruction-size pc))
584 |                   (cons (instruction-decode pc) instructions))))))
585 | 
586 | (define *debug* #f)
587 | 
588 | (define (run)
589 |   (step) (run))
590 | 
591 | (define (display-vm-state)
592 |   (display "*val* ")(display (show *val*))(newline)
593 |   (display "*fun* ")(display (show *fun*))(newline)
594 |   (display "=== *stack* ===")(newline)
595 |   (display-stack *stack*)
596 |   (display "===============")(newline))
597 | 
598 | (define (display-stack sp)
599 |   (for-each (lambda (value) (display (show value))(newline))
600 |             sp))
601 | 
602 | (define-generics show)
603 | (define-method (show (<activation> frame))
604 |   (let ((out (open-output-string))) ;; SISC-specific
605 |     (with-output-to-port out
606 |       (lambda ()
607 |         (display "<frame")
608 |         (do ((i 0 (+ i 1)))
609 |             ((= i (:length frame)))
610 |           (display " ")
611 |           (display (show (:argument frame i))))
612 |         (display ">")))
613 |     (get-output-string out)))
614 | 
615 | (define-method (show (<value> val))
616 |   val)
617 | 
618 | (define (run-debug)
619 |   (display "=== vm state ===")(newline)
620 |   (display-vm-state)
621 |   (display "*pc* ")
622 |   (display (instruction-decode *pc*))(newline)
623 |   (step)(newline)
624 |   (run-debug))
625 | 
626 | ;; I do this as an epilogue rather than a prologue, so that the jump
627 | ;; is "forward". But it doesn't really matter, since it's floating in
628 | ;; spa-ha-hace ..
629 | (define (code-epilogue)
630 |   (FINISH))
631 | 
632 | (define (run-machine start finish constants global-names)
633 |   (set! *constants* constants)
634 |   (set! sg.current
635 |     (make-vector (length global-names) undefined-value))
636 |   ;; Not bothering with globals symbol table for the minute
637 |   (set! *env* sr.init)
638 |   (set! *stack* (stack-new))
639 |   (set! *val* undefined-value)
640 |   (set! *fun* undefined-value)
641 |   (set! *arg1* undefined-value)
642 |   (set! *arg2* undefined-value)
643 |   (stack-push finish)
644 |   (set! *pc* start)
645 |   ;; No code vector; the pc encodes it
646 |   (call/cc (lambda (k)
647 |              (set! *exit* k)
648 |              (if *debug* (run-debug) (run)))))
649 | 
650 | (define (compile+run expression)
651 |   ((compile/standalone expression)))
652 | 
653 | (define (repl)
654 |   (display "> ")
655 |   (let ((in (read)))
656 |     (display (compile+run in))(newline)
657 |     (repl)))
658 | 
659 | ;; For smoketest
660 | (define eval-expr compile+run)
661 | 
662 | ;; The book uses a class for primitives, because they don't have a
663 | ;; closed-over environment
664 | 
665 | (define-generics :address :address!)
666 | 
667 | (define-class (<primitive>)
668 |   (address :address :address!))
669 | 
670 | (define-method (initialize (<primitive> self)
671 |                            (<procedure> address))
672 |   (:address! self address))
673 | 
674 | (define-method (invoke (<primitive> f) (<boolean> tail?))
675 |   (unless tail? (stack-push *pc*))
676 |   ((:address f)))
677 | 
678 | (define (define-primitive name underlying arity)
679 |   (let ((arity+1 (+ arity 1)))
680 |     (case arity
681 |       ((0)
682 |        (define-initial name
683 |          (let ((behaviour
684 |                 (lambda ()
685 |                   (if (= (:length *val*) arity+1)
686 |                       (begin
687 |                         (set! *val* (underlying))
688 |                         (set! *pc* (stack-pop)))
689 |                       (runtime-error
690 |                        "Incorrect arity for" name
691 |                        "need:" arity
692 |                        "got: " (- (:length *val*) 1))))))
693 |            (description-extend!
694 |             name `(function ,underlying ,arity))
695 |            (make <primitive> behaviour))))
696 |       ((1)
697 |        (define-initial name
698 |          (let ((behaviour
699 |                 (lambda ()
700 |                   (if (= (:length *val*) arity+1)
701 |                       (begin
702 |                         (set! *val* (underlying (:argument *val* 0)))
703 |                         (set! *pc* (stack-pop)))
704 |                       (runtime-error
705 |                        "Incorrect arity for" name
706 |                        "need:" arity
707 |                        "got: " (- (:length *val*) 1))))))
708 |            (description-extend!
709 |             name `(function ,underlying ,arity))
710 |            (make <primitive> behaviour))))
711 |       ((2)
712 |        (define-initial name
713 |          (let ((behaviour
714 |                 (lambda ()
715 |                   (if (= (:length *val*) arity+1)
716 |                       (begin
717 |                         (set! *val*
718 |                           (underlying (:argument *val* 0)
719 |                                       (:argument *val* 1)))
720 |                         (set! *pc* (stack-pop)))
721 |                       (runtime-error
722 |                        "Incorrect arity for" name
723 |                        "need:" arity
724 |                        "got: " (- (:length *val*) 1))))))
725 |            (description-extend!
726 |             name `(function ,underlying ,arity))
727 |            (make <primitive> behaviour))))
728 |       ((3)
729 |        (define-initial name
730 |          (let ((behaviour
731 |                 (lambda ()
732 |                   (if (= (:length *val*) arity+1)
733 |                       (set! *val*
734 |                         (underlying (:argument *val* 0)
735 |                                     (:argument *val* 1)
736 |                                     (:argument *val* 2)))
737 |                       (runtime-error
738 |                        "Incorrect arity for" name
739 |                        "need:" arity
740 |                        "got: " (- (:length *val*) 1))))))
741 |            (description-extend!
742 |             name `(function ,underlying ,arity))
743 |            (make <primitive> behaviour)))))))
744 | 
745 | ;; We have to be careful that these match the hard-wired predefines
746 | (define-initial 't #t)
747 | (define-initial 'f #f)
748 | (define-initial 'nil '())
749 | (define-primitive 'cons cons 2)
750 | (define-primitive 'car car 1)
751 | (define-primitive 'cdr cdr 1)
752 | (define-primitive 'pair? pair? 1)
753 | (define-primitive 'symbol? symbol? 1)
754 | (define-primitive 'eq? eq? 2)
755 | 
756 | ;; From here on they can be in any order
757 | (define-primitive 'read read 0)
758 | (define-primitive 'newline newline 0)
759 | 
760 | (define-primitive 'car car 1)
761 | (define-primitive 'cdr cdr 1)
762 | (define-primitive 'pair? pair? 1)
763 | (define-primitive 'symbol? symbol? 1)
764 | 
765 | (define-primitive '+ + 2)
766 | (define-primitive '- - 2)
767 | (define-primitive '= = 2)
768 | (define-primitive '< < 2)
769 | (define-primitive '> > 2)
770 | (define-primitive '<= <= 2)
771 | (define-primitive '>= >= 2)
772 | (define-primitive '* * 2)
773 | 
774 | (define-initial 'apply
775 |   (let ((arity 2) (arity+1 3))
776 |     (make <primitive>
777 |           (lambda ()
778 |             (if (>= (:length *val*) arity+1)
779 |                 (let* ((f (:argument *val* 0)) ;; the function
780 |                        (last-arg-index (- (:length *val*) 2))
781 |                        (last-arg (:argument *val* last-arg-index))
782 |                        (size (+ last-arg-index (length last-arg)))
783 |                        (frame (make <activation> size)))
784 |                   (do ((i 1 (+ i 1)))
785 |                       ((= i last-arg-index))
786 |                     (:argument! frame (- i 1) (:argument v* i)))
787 |                   (do ((i (- last-arg-index 1) (+ i 1))
788 |                        (last-arg last-arg (cdr last-arg)))
789 |                       ((null? last-arg))
790 |                     (:argument! frame i (car last-arg)))
791 |                   (set! *val* frame)
792 |                   (set! *fun* f) ;; not strictly necessary, but
793 |                   ;; useful if we e.g., examine the
794 |                   ;; registers while debugging (trick
795 |                   ;; taken from the book code)
796 |                   (invoke f #t))
797 |                 (runtime-error
798 |                  "Incorrect arity for" name
799 |                  "need at least:" arity
800 |                  "got: " (- (:length *val*) 1)))))))
801 | 
802 | (define-initial 'list
803 |   (make <primitive>
804 |         (lambda ()
805 |           (let loop ((index (- (:length *val*) 2))
806 |                      (result '()))
807 |             (cond ((= index -1)
808 |                    (set! *val* result)
809 |                    (set! *pc* (stack-pop)))
810 |                   (else (loop (- index 1)
811 |                               (cons (:argument *val* index) result))))))))
812 | 
813 | ;; I didn't bother for the previous compiler, but for this one I'll
814 | ;; make a class for continuations
815 | 
816 | (define-generics :stack :stack!)
817 | 
818 | (define-class (<continuation>)
819 |   (stack :stack :stack!))
820 | 
821 | (define-method (initialize (<continuation> self)
822 |                            (<list> stack))
823 |   (:stack! self stack))
824 | 
825 | (define-method (invoke (<continuation> self)
826 |                        (<boolean> tail?))
827 |   (if (= (:length *val*) 2)
828 |       (begin
829 |         (set! *val* (:argument *val* 0))
830 |         (stack-restore (:stack self))
831 |         (set! *pc* (stack-pop)))
832 |       (runtime-error
833 |        "Expected one argument to continuation;"
834 |        "got " (- (:length *val*) 1))))
835 | 
836 | (define-method (show (<continuation> _self))
837 |   "Continuation (mysterious and otherwordly)")
838 | 
839 | 
840 | (define-initial 'call/cc
841 |   (make <primitive>
842 |         (lambda ()
843 |           (if (= (:length *val*) 2)
844 |               (let* ((f (:argument *val* 0))
845 |                      (frame (make <activation> 2)))
846 |                 (:argument! frame 0 (make <continuation> (stack-save)))
847 |                 (set! *val* frame)
848 |                 (set! *fun* f) ;; debug purposes
849 |                 (invoke f #t))
850 |               (runtime-error "Expected one argument, got "
851 |                              (- (:length *val*) 1))))))
852 | 


--------------------------------------------------------------------------------
/chapter7.ss:
--------------------------------------------------------------------------------
  1 | ;; This is a compiler, adapted from the "pretreating" interpreter of
  2 | ;; the previous chapter. It takes the conversion to combinators a step
  3 | ;; further by linearising them into lists of thunks operating entirely
  4 | ;; on registers and the stack.
  5 | 
  6 | (load "prelude.ss")
  7 | (load "env.ss")
  8 | (load "closure.ss")
  9 | 
 10 | ;; Byte code interpreter
 11 | 
 12 | ;; The environment register, as in the previous chapter.
 13 | (define *env* sr.init)
 14 | 
 15 | ;; The *val* register is used to store values for subsequent
 16 | ;; instructions to operate on
 17 | (define *val* undefined-value)
 18 | 
 19 | ;; We need a stack for ad-hoc registers. The book uses a vector and a
 20 | ;; stack pointer. I'm going to use a list, just to be different.
 21 | (define *stack* '())
 22 | 
 23 | (define (stack-push v)
 24 |   (set! *stack* (cons v *stack*)))
 25 | 
 26 | (define (stack-pop)
 27 |   (let ((v (car *stack*)))
 28 |     (set! *stack* (cdr *stack*))
 29 |     v))
 30 | 
 31 | ;; Using a list makes this a lot easier. Effectively, I'm using an
 32 | ;; entirely heap-allocated er, stack.
 33 | (define (stack-save)
 34 |   *stack*)
 35 | 
 36 | (define (stack-restore s)
 37 |   (set! *stack* s))
 38 | 
 39 | ;; When calling a function, we need to store the head as well as the
 40 | ;; arguments, so here's another register for that.
 41 | (define *fun* undefined-value)
 42 | 
 43 | ;; Since we support primitives with up to three arguments, we need
 44 | ;; registers to hold the first and second of those (the third can come
 45 | ;; straight from *val*).
 46 | (define *arg1* undefined-value)
 47 | (define *arg2* undefined-value)
 48 | 
 49 | ;; Finally, a register for the next instruction to execute.
 50 | (define *pc* undefined-value)
 51 | 
 52 | ;; OK, now there are sufficient registers (and a stack) so we can
 53 | ;; rewrite the combinators purely as operations on registers (and the
 54 | ;; stack). This means we can linearise programs, since they no longer
 55 | ;; need an implicit stack and variables. In this chapter, a program is
 56 | ;; a list of thunks; the program counter *pc* is a cons cell.
 57 | 
 58 | ;; The examples given in §7.1.1 and §7.1.2 don't fully linearise the
 59 | ;; instructions -- there's still a bit of recursion in evaluating
 60 | ;; sequences or arguments. I'll take up at §7.1.3, where the
 61 | ;; combinators start to be defined as lists of thunks.
 62 | 
 63 | (define (CONSTANT v)
 64 |   (list (lambda () (set! *val* v))))
 65 | 
 66 | ;; Not sure why this is now split into two similarly named
 67 | ;; combinators, but maybe that will become clear.
 68 | (define (SHALLOW-ASSIGNMENT! j m)
 69 |   (append m (SET-SHALLOW-ARGUMENT! j)))
 70 | (define (SET-SHALLOW-ARGUMENT! j)
 71 |   (list (lambda () (:argument! *env* j *val*))))
 72 | 
 73 | (define (SHALLOW-ARGUMENT-REF index)
 74 |   (list (lambda () (set! *val* (:argument *env* index)))))
 75 | 
 76 | (define (DEEP-ARGUMENT-REF level index)
 77 |   (list (lambda () (set! *val* (deep-fetch *env* level index)))))
 78 | 
 79 | (define (CHECKED-GLOBAL-REF index)
 80 |   (list (lambda ()
 81 |           (let ((v (global-fetch index)))
 82 |             (if (eq? v undefined-value)
 83 |                 (runtime-error "Uninitialised variable")
 84 |                 (set! *val* v))))))
 85 | 
 86 | (define (PREDEFINED i)
 87 |   (list (lambda () (set! *val* (predef-fetch i)))))
 88 | 
 89 | ;; Conditional and unconditional jumps
 90 | (define (JUMP-FALSE i)
 91 |   (list (lambda ()
 92 |           (if (not *val*)
 93 |               (set! *pc* (list-tail *pc* i))))))
 94 | 
 95 | (define (GOTO i)
 96 |   (list (lambda ()
 97 |           (set! *pc* (list-tail *pc* i)))))
 98 | 
 99 | (define (ALTERNATIVE m1 m2 m3)
100 |   (append m1 ;; result of test clause to *val*
101 |           (JUMP-FALSE (+ 1 (length m2))) ;; jump over success k (and goto)
102 |           m2 ;; success k
103 |           (GOTO (length m3)) ;; then jump past failure k
104 |           m3))
105 | 
106 | ;; Closures aren't invoked with an activation frame as in the last
107 | ;; chapter; the arguments are in the *val* register. The 'code' of a
108 | ;; closure is a program counter.
109 | 
110 | (define-method (initialize (<closure> self)
111 |                            (<list> code)
112 |                            (<activation> closed))
113 |   (init* self
114 |          :code! code
115 |          :closed-env! closed))
116 | 
117 | (define-method (invoke (<closure> f))
118 |   (stack-push *pc*)
119 |   (set! *env* (:closed-env f))
120 |   (set! *pc* (:code f)))
121 | 
122 | (define (REGULAR-CALL m m*)
123 |   (append m (PUSH-VALUE) ;; put *val* onto the stack
124 |           m* ;; collect the arguments, stack should end up where it is
125 |              ;; now
126 |           (POP-FUNCTION) ;; put the top of the stack in *fun*
127 |           (PRESERVE-ENV)
128 |           (FUNCTION-INVOKE)
129 |           (RESTORE-ENV)))
130 | 
131 | (define (PUSH-VALUE)
132 |   (list (lambda () (stack-push *val*))))
133 | (define (POP-FUNCTION)
134 |   (list (lambda () (set! *fun* (stack-pop)))))
135 | 
136 | ;; store the env on the stack
137 | (define (PRESERVE-ENV)
138 |   (list (lambda () (stack-push *env*))))
139 | (define (RESTORE-ENV)
140 |   (list (lambda () (set! *env* (stack-pop)))))
141 | 
142 | (define (FUNCTION-INVOKE)
143 |   (list (lambda () (invoke *fun*))))
144 | 
145 | (define (NARY-CLOSURE m+ arity)
146 |   (define the-function
147 |     (append (ARITY>=? (+ arity 1)) ;; bail if not enough arguments
148 |             (PACK-FRAME! arity) ;; collect varargs
149 |             (EXTEND-ENV) ;; extend *env* with arguments
150 |             m+ ;; execute the forms
151 |             (RETURN)))
152 |   (append (CREATE-CLOSURE 1) ;; make a closure that starts at pc+1
153 |           (GOTO (length the-function)) ;; skip the definition
154 |           the-function))
155 | 
156 | (define (CREATE-CLOSURE offset)
157 |   (list (lambda ()
158 |           (set! *val*
159 |             (make <closure> (list-tail *pc* offset) *env*)))))
160 | 
161 | ;; Get all the arguments after arity+1 and put them in a list, in the
162 | ;; arity+1th slot. This is for when we're calling a dotted
163 | ;; abstraction. Thought: at the expense of complicating closure code,
164 | ;; the closure could be the one to pop arguments as required (but it
165 | ;; would need to know how many are there I guess)
166 | (define (listify! v* arity)
167 |   (let loop ((index (- (vector-length (:args v*)) 1))
168 |              (result '()))
169 |     (if (= arity index)
170 |         (:argument! v* arity result)
171 |         (loop (- index 1)
172 |               (cons (:argument v* (- index 1)) result)))))
173 | 
174 | (define (PACK-FRAME! arity)
175 |   (list (lambda () (listify! *val* arity))))
176 | 
177 | (define (RETURN)
178 |   (list (lambda () (set! *pc* (stack-pop)))))
179 | 
180 | (define (DEEP-ASSIGNMENT! i j m)
181 |   (append m (SET-DEEP-ARGUMENT! i j)))
182 | (define (SET-DEEP-ARGUMENT! i j)
183 |   (list (lambda () (deep-update! *env* i j *val*))))
184 | 
185 | (define (GLOBAL-SET! i m)
186 |   (append m (SET-GLOBAL! i)))
187 | (define (SET-GLOBAL! i)
188 |   (list (lambda () (global-update! i *val*))))
189 | 
190 | (define (SEQUENCE m m+)
191 |   (append m m+))
192 | 
193 | (define (TR-FIX-LET m* m+)
194 |   (append m* (EXTEND-ENV) m+))
195 | (define (FIX-LET m* m+)
196 |   (append m* (EXTEND-ENV) m+ (UNLINK-ENV)))
197 | 
198 | (define (EXTEND-ENV)
199 |   (list (lambda () (set! *env* (extend *env* *val*)))))
200 | 
201 | ;; If we're not tail-calling, we need to restore the environment;
202 | ;; luckily, it'll always be the next pointer of the current
203 | ;; environment
204 | (define (UNLINK-ENV)
205 |   (list (lambda () (set! *env* (:next *env*)))))
206 | 
207 | (define (CALL0 address)
208 |   (list (lambda () (INVOKE0 address))))
209 | 
210 | (define (INVOKE0 address)
211 |   (list (lambda ()
212 |           (set! *val* (address)))))
213 | 
214 | (define (CALL1 address m1)
215 |   (append m1 (INVOKE1 address)))
216 | 
217 | (define (INVOKE1 address)
218 |   (list (lambda ()
219 |           (set! *val* (address *val*)))))
220 | 
221 | (define (CALL2 address m1 m2)
222 |   (append m1 ;; m1 -> *val*
223 |           (PUSH-VALUE) ;; *val* -> stack
224 |           m2 ;; m2 -> *val*
225 |           (POP-ARG1) ;; stack -> *arg1*
226 |           (INVOKE2 address)))
227 | 
228 | (define (INVOKE2 address)
229 |   (list (lambda () (set! *val* (address *arg1* *val*)))))
230 | 
231 | (define (PUSH-VALUE)
232 |   (list (lambda () (stack-push *val*))))
233 | 
234 | (define (POP-ARG1)
235 |   (list (lambda () (set! *arg1* (stack-pop)))))
236 | 
237 | ;; We only ever pop just arg1 or both arg1 and arg2, so instead of pop-arg2 I have pop-2arg
238 | (define (POP-2ARG)
239 |   (list (lambda ()
240 |           (set! *arg2* (stack-pop))
241 |           (set! *arg1* (stack-pop)))))
242 | 
243 | (define (CALL3 address m1 m2 m3)
244 |   (append m1 (PUSH-VALUE)
245 |           m2 (PUSH-VALUE)
246 |           m3
247 |           (POP-2ARG)
248 |           (INVOKE3 address)))
249 | 
250 | (define (INVOKE3 address)
251 |   (list (lambda () (set! *val* (address *arg1* *arg2* *val*)))))
252 | 
253 | (define (FIX-CLOSURE m+ arity)
254 |   (define the-function
255 |     (append (ARITY=? arity)
256 |             (EXTEND-ENV)
257 |             m+
258 |             (RETURN)))
259 |   (append (CREATE-CLOSURE 1)
260 |           (GOTO (length the-function))
261 |           the-function))
262 | 
263 | (define (REGULAR-CALL m m*)
264 |   (append m (PUSH-VALUE)
265 |           m* (POP-FUNCTION)
266 |           (PRESERVE-ENV) (FUNCTION-INVOKE) (RESTORE-ENV)))
267 | 
268 | (define (TR-REGULAR-CALL m m*)
269 |   (append m (PUSH-VALUE)
270 |           m* (POP-FUNCTION)
271 |           (FUNCTION-INVOKE)))
272 | 
273 | (define (STORE-ARGUMENT m m* rank)
274 |   (append m (PUSH-VALUE) m* (POP-FRAME! rank)))
275 | 
276 | (define (CONS-ARGUMENT m m* arity)
277 |   (append m (PUSH-VALUE) m* (POP-CONS-FRAME! arity)))
278 | 
279 | ;; put the top-most value in the stack into the given frame slot;
280 | ;; used to build activation frames of arguments. Calls end up being:
281 | ;; push argument ...
282 | ;; make frame
283 | ;; set popped argument ...
284 | (define (POP-FRAME! rank)
285 |   (list (lambda ()
286 |           (:argument! *val* rank (stack-pop)))))
287 | 
288 | ;; cons the top-most value 
289 | (define (POP-CONS-FRAME! arity)
290 |   (list (lambda ()
291 |           (:argument! *val* arity (cons (stack-pop)
292 |                                         (:argument *val* arity))))))
293 | 
294 | (define (ALLOCATE-FRAME size)
295 |   (let ((arity+1 (+ size 1)))
296 |     (list (lambda ()
297 |             (set! *val* (make <activation> arity+1))))))
298 | 
299 | (define (ALLOCATE-DOTTED-FRAME arity)
300 |   (let ((arity+1 (+ arity 1)))
301 |     (list (lambda ()
302 |             (set! *val* (let ((v* (make <activation> arity+1)))
303 |                           (:argument! v* arity '())
304 |                           v*))))))
305 | 
306 | ;; Check the number of args and bail if no good
307 | (define (ARITY>=? n)
308 |   (let ((arity+1 (+ n 1)))
309 |     (list (lambda () (if (< (:length *val*) arity+1)
310 |                          (runtime-error "Too few arguments"))))))
311 | 
312 | (define (ARITY=? n)
313 |   (let ((arity+1 (+ n 1)))
314 |     (list (lambda () (if (not (= (:length *val*) arity+1))
315 |                          (runtime-error "Wrong number of arguments"
316 |                                         n (- (:length *val*) 1)))))))
317 | 
318 | ;; That's the combinators, now linearising to a list of thunks
319 | ;; operating on registers and a stack. The pretreatment remains the
320 | ;; same:
321 | (load "pretreat.ss")
322 | 
323 | ;; Here's our executor
324 | (define (step)
325 |   (let ((instruction (car *pc*)))
326 |     (set! *pc* (cdr *pc*))
327 |     (instruction)))
328 | 
329 | (define (run)
330 |   (cond ((null? *pc*) *val*)
331 |         (else (begin (step) (run)))))
332 | 
333 | (define (compile expression)
334 |   (meaning expression sr.init #t))
335 | 
336 | (define (compile+run expression)
337 |   (set! *pc* (compile expression))
338 |   (run))
339 | 
340 | (define (repl)
341 |   (display "> ")
342 |   (let ((in (read)))
343 |     (display (compile+run in))(newline)
344 |     (repl)))
345 | 
346 | ;; For smoketest
347 | (define eval-expr compile+run)
348 | 
349 | 
350 | ;; The book uses a class for primitives, because they don't have a
351 | ;; closed-over environment
352 | 
353 | (define-generics :address :address!)
354 | 
355 | (define-class (<primitive>)
356 |   (address :address :address!))
357 | 
358 | (define-method (initialize (<primitive> self)
359 |                            (<procedure> address))
360 |   (:address! self address))
361 | 
362 | (define-method (invoke (<primitive> f))
363 |   (stack-push *pc*)
364 |   ((:address f)))
365 | 
366 | (define (define-primitive name underlying arity)
367 |   (let ((arity+1 (+ arity 1)))
368 |     (case arity
369 |       ((0)
370 |        (define-initial name
371 |          (let ((behaviour
372 |                 (lambda ()
373 |                   (if (= (:length *val*) arity+1)
374 |                       (begin
375 |                         (set! *val* (underlying))
376 |                         (set! *pc* (stack-pop)))
377 |                       (runtime-error
378 |                        "Incorrect arity for" name
379 |                        "need:" arity
380 |                        "got: " (- (:length *val*) 1))))))
381 |            (description-extend!
382 |             name `(function ,underlying ,arity))
383 |            (make <primitive> behaviour))))
384 |       ((1)
385 |        (define-initial name
386 |          (let ((behaviour
387 |                 (lambda ()
388 |                   (if (= (:length *val*) arity+1)
389 |                       (begin
390 |                         (set! *val* (underlying (:argument *val* 0)))
391 |                         (set! *pc* (stack-pop)))
392 |                       (runtime-error
393 |                        "Incorrect arity for" name
394 |                        "need:" arity
395 |                        "got: " (- (:length *val*) 1))))))
396 |            (description-extend!
397 |             name `(function ,underlying ,arity))
398 |            (make <primitive> behaviour))))
399 |       ((2)
400 |        (define-initial name
401 |          (let ((behaviour
402 |                 (lambda ()
403 |                   (if (= (:length *val*) arity+1)
404 |                       (begin
405 |                         (set! *val*
406 |                           (underlying (:argument *val* 0)
407 |                                       (:argument *val* 1)))
408 |                         (set! *pc* (stack-pop)))
409 |                       (runtime-error
410 |                        "Incorrect arity for" name
411 |                        "need:" arity
412 |                        "got: " (- (:length *val*) 1))))))
413 |            (description-extend!
414 |             name `(function ,underlying ,arity))
415 |            (make <primitive> behaviour))))
416 |       ((3)
417 |        (define-initial name
418 |          (let ((behaviour
419 |                 (lambda ()
420 |                   (if (= (:length *val*) arity+1)
421 |                       (set! *val*
422 |                         (underlying (:argument *val* 0)
423 |                                     (:argument *val* 1)
424 |                                     (:argument *val* 2)))
425 |                       (runtime-error
426 |                        "Incorrect arity for" name
427 |                        "need:" arity
428 |                        "got: " (- (:length *val*) 1))))))
429 |            (description-extend!
430 |             name `(function ,underlying ,arity))
431 |            (make <primitive> behaviour)))))))
432 | 
433 | (define-primitive '+ + 2)
434 | 
435 | (define-initial 'apply
436 |   (let ((arity 2) (arity+1 3))
437 |     (make <primitive>
438 |           (lambda ()
439 |             (if (>= (:length *val*) arity+1)
440 |                 (let* ((f (:argument *val* 0)) ;; the function
441 |                        (last-arg-index (- (:length *val*) 2))
442 |                        (last-arg (:argument *val* last-arg-index))
443 |                        (size (+ last-arg-index (length last-arg)))
444 |                        (frame (make <activation> size)))
445 |                   (do ((i 1 (+ i 1)))
446 |                       ((= i last-arg-index))
447 |                     (:argument! frame (- i 1) (:argument v* i)))
448 |                   (do ((i (- last-arg-index 1) (+ i 1))
449 |                        (last-arg last-arg (cdr last-arg)))
450 |                       ((null? last-arg))
451 |                     (:argument! frame i (car last-arg)))
452 |                   (set! *val* frame)
453 |                   (set! *fun* f) ;; not strictly necessary, but
454 |                   ;; useful if we e.g., examine the
455 |                   ;; registers while debugging (trick
456 |                   ;; taken from the book code)
457 |                   (invoke f))
458 |                 (runtime-error
459 |                  "Incorrect arity for" name
460 |                  "need at least:" arity
461 |                  "got: " (- (:length *val*) 1)))))))
462 | 
463 | (define-initial 'list
464 |   (make <primitive>
465 |         (lambda ()
466 |           (let loop ((index (- (:length *val*) 2))
467 |                      (result '()))
468 |             (cond ((= index -1)
469 |                    (set! *val* result)
470 |                    (set! *pc* (stack-pop)))
471 |                   (else (loop (- index 1)
472 |                               (cons (:argument *val* index) result))))))))
473 | 
474 | (define-initial 'call/cc
475 |   (make <primitive>
476 |         (lambda ()
477 |           (if (= (:length *val*) 2)
478 |               (let* ((f (:argument *val* 0))
479 |                      (s (stack-save))
480 |                      (k (lambda ()
481 |                           (if (= (:length *val*) 2)
482 |                               (begin
483 |                                 (set! *val* (:argument *val* 0))
484 |                                 (stack-restore s)
485 |                                 (set! *pc* (stack-pop)))
486 |                               (runtime-error
487 |                                "Expected one argument to continuation;"
488 |                                "got " (- (:length *val*) 1)))))
489 |                      (frame (make <activation> 2)))
490 |                 (:argument! frame 0 (make <primitive> k))
491 |                 (set! *val* frame)
492 |                 (set! *fun* f) ;; debug purposes
493 |                 (invoke f))
494 |               (runtime-error "Expected one argument, got "
495 |                              (- (:length *val*) 1))))))
496 | 


--------------------------------------------------------------------------------
/closure.ss:
--------------------------------------------------------------------------------
 1 | ;; OO definition of closures, used starting with chapter 6.
 2 | 
 3 | ;; Closures are back to being objects rather than erm, closures.
 4 | 
 5 | (define-generics :code :code! :closed-env :closed-env!)
 6 | 
 7 | (define-class (<closure>)
 8 |   (code :code :code!)
 9 |   (closed-env :closed-env :closed-env!))
10 | 
11 | ;; I'm going to use a generic procedure here, as well, again for the
12 | ;; effect of checking the type of argument it's given.
13 | (define-generics invoke)
14 | 


--------------------------------------------------------------------------------
/env.ss:
--------------------------------------------------------------------------------
  1 | (import type-system)
  2 | (import generic-procedures)
  3 | (import oo)
  4 | 
  5 | ;; Activation records: I'm collapsing the frankly profligate two
  6 | ;; classes (environment, not used qua itself, and activation) from the
  7 | ;; chapter5 interpreter into just the one. We're still using the
  8 | ;; nested environments.
  9 | 
 10 | ;; I'm exercising the type system a little more than the book does,
 11 | ;; just by defining some procedures as generic procedures for the
 12 | ;; effect of checking the arguments passed match the signature given.
 13 | 
 14 | (define-generics
 15 |   :next :next!
 16 |   :args :args!
 17 |   :argument :argument!
 18 |   :length
 19 |   extend ;; sr-extend* in the book
 20 |   deep-fetch deep-update!)
 21 | 
 22 | (define-class (<activation>)
 23 |   (next :next :next!)
 24 |   (args :args :args!))
 25 | 
 26 | (define-method (initialize (<activation> self)
 27 |                            (<number> size))
 28 |   (:args! self (make-vector size)))
 29 | 
 30 | (define-method (:argument (<activation> frame)
 31 |                           (<number> index))
 32 |   (vector-ref (:args frame) index))
 33 | 
 34 | (define-method (:argument! (<activation> frame)
 35 |                            (<number> index)
 36 |                            (<value> value))
 37 |   (vector-set! (:args frame) index value))
 38 | 
 39 | (define-method (:length (<activation> self))
 40 |   (vector-length (:args self)))
 41 | 
 42 | (define-method (extend (<activation> parent)
 43 |                        (<activation> child))
 44 |   (:next! child parent)
 45 |   child)
 46 | 
 47 | (define-method (deep-fetch (<activation> sr)
 48 |                            (<number> level)
 49 |                            (<number> index))
 50 |   (if (= level 0)
 51 |       (:argument sr index)
 52 |       (deep-fetch (:next sr) (- level 1) index)))
 53 | 
 54 | (define-method (deep-update! (<activation> sr)
 55 |                              (<number> level)
 56 |                              (<number> index)
 57 |                              (<value> value))
 58 |   (if (= level 0)
 59 |       (:argument! sr index value)
 60 |       (deep-update! (:next sr) (- level 1) index value)))
 61 | 
 62 | 
 63 | ;; Helper that collects values after arity+1 and puts them in a list
 64 | ;; in arity+1th argument slot. Used for dotted applications.
 65 | (define (listify! v* arity)
 66 |   (let loop ((index (- (:length v*) 1))
 67 |              (result '()))
 68 |     (if (= arity index)
 69 |         (:argument! v* arity result)
 70 |         (loop (- index 1)
 71 |               (cons (:argument v* (- index 1)) result)))))
 72 | 
 73 | 
 74 | ;; Lexical environment: exactly as it was previously
 75 | 
 76 | (define (r-extend* r n*)
 77 |   (cons n* r))
 78 | 
 79 | ;; See if the given name is a local variable in the given environment
 80 | (define (local-variable? r i n)
 81 |   (and (pair? r)
 82 |        (let scan ((names (car r))
 83 |                   (j 0))
 84 |          (cond ((pair? names)
 85 |                 (if (eq? n (car names))
 86 |                     `(local ,i . ,j)
 87 |                     (scan (cdr names) (+ j 1))))
 88 |                ((null? names)
 89 |                 (local-variable? (cdr r) (+ i 1) n))
 90 |                ;; Don't think I understand this clause -- why would
 91 |                ;; these be improper? A convenience perhaps
 92 |                ((eq? n names) `(local ,i . ,j))))))
 93 | 
 94 | 
 95 | ;; Names of mutable globals
 96 | (define g.current '())
 97 | ;; Names of predefined globals
 98 | (define g.init '())
 99 | 
100 | ;; Mutable globals
101 | (define sg.current (make-vector 100))
102 | ;; Predefined globals
103 | (define sg.init (make-vector 100))
104 | 
105 | ;; Initial env
106 | (define r.init '())
107 | ;; Initial memory
108 | (define sr.init (make <activation> 0))
109 | 
110 | (define (g.current-extend! n)
111 |   (let ((level (length g.current)))
112 |     (set! g.current (cons (cons n `(global . ,level)) g.current))
113 |     level))
114 | 
115 | (define (g.init-extend! n)
116 |   (let ((level (length g.init)))
117 |     (set! g.init (cons (cons n `(predefined . ,level)) g.init))
118 |     level))
119 | 
120 | (define (compute-kind r n)
121 |   (or (local-variable? r 0 n)
122 |       (global-variable? g.current n)
123 |       (global-variable? g.init n)))
124 | 
125 | (define (global-variable? g n)
126 |   (let ((var (assq n g)))
127 |     (and (pair? var) (cdr var))))
128 | 
129 | (define (global-fetch i)
130 |   (vector-ref sg.current i))
131 | (define (predef-fetch i)
132 |   (vector-ref sg.init i))
133 | 
134 | (define (global-update! i v)
135 |   (vector-set! sg.current i v))
136 | 
137 | (define (g.current-init! name)
138 |   (let ((kind (compute-kind r.init name)))
139 |     (if kind
140 |         (case (car kind)
141 |           ((global)
142 |            (global-update! (cdr kind) UNDEFINED))
143 |           (else
144 |             (compiler-error "Bad redefinition" name kind)))
145 |         (let ((index (g.current-extend! name)))
146 |           (global-update! index UNDEFINED))))
147 |   name)
148 | 
149 | (define (g.init-init! name value)
150 |   (let ((kind (compute-kind r.init name)))
151 |     (if kind
152 |         (case (car kind)
153 |           ((predefined)
154 |            (vector-set! sg.init (cdr kind) value))
155 |           (else (compiler-error "Bad redefinition" name kind)))
156 |         (let ((index (g.init-extend! name)))
157 |           (vector-set! sg.init index value))))
158 |   name)
159 | 
160 | (define (define-initial name value)
161 |   (g.init-init! name value))
162 | 
163 | ;; Primitives
164 | 
165 | (define desc.init '())
166 | 
167 | (define (description-extend! name description)
168 |   (set! desc.init (cons (cons name description) desc.init))
169 |   name)
170 | 
171 | (define (get-description name)
172 |   (let ((d (assq name desc.init)))
173 |     (and (pair? d) (cdr d))))
174 | 


--------------------------------------------------------------------------------
/null-eval.scm:
--------------------------------------------------------------------------------
1 | (define eval-expr eval)
2 | 


--------------------------------------------------------------------------------
/prelude.ss:
--------------------------------------------------------------------------------
 1 | ;; Our by-now usual prelude.
 2 | 
 3 | (define (compiler-error . bobbins)
 4 |   (error bobbins))
 5 | 
 6 | (define (runtime-error . bobbins)
 7 |   (error bobbins))
 8 | 
 9 | ;; A unique value for uninitialised variables.
10 | (define undefined-value '(constant . undefined))
11 | 
12 | (define (init* self . fields)
13 |   (define (init1 fields)
14 |     (if (pair? fields)
15 |         (if (pair? (cdr fields))
16 |             (begin
17 |               ((car fields) self (cadr fields))
18 |               (init1 (cddr fields)))
19 |             (error "Field spec not in format (:mutator! value ...)" fields))))
20 |   (init1 fields))
21 | 
22 | (define-macro (-> value . rest)
23 |   (cond
24 |    ((null? rest)
25 |     value)
26 |    ((pair? rest)
27 |     (let ((next (car rest)))
28 |       (if (pair? next)
29 |           `(-> (,(car next) ,value ,@(cdr next)) ,@(cdr rest))
30 |           `(-> (,next ,value) ,@(cdr rest)))))))
31 | 
32 | ;; A working implementation of compose, since it seems to be missing from SISC
33 | (define (compose . procs)
34 |   (if (null? procs)
35 |       (lambda (v) v)
36 |       (lambda (v) ((car procs) ((apply compose (cdr procs)) v)))))
37 | 


--------------------------------------------------------------------------------
/pretreat.ss:
--------------------------------------------------------------------------------
  1 | ;; The core 'meaning' procedures that get used from chapter 6 & 7
  2 | ;; Requires prelude.ss, env.ss to be loaded
  3 | 
  4 | ;; This actually comes from the previous section §6.2, and isn't
  5 | ;; changed in §6.3. All the procedures to which it delegates do
  6 | ;; change, of course.
  7 | (define (meaning e r tail?)
  8 |   (if (pair? e)
  9 |       (case (car e)
 10 |         ((quote) (meaning-quotation (cadr e) r tail?))
 11 |         ((lambda) (meaning-abstraction (cadr e) (cddr e) r tail?))
 12 |         ((if) (meaning-alternative (cadr e) (caddr e) (cadddr e)
 13 |                                    r tail?))
 14 |         ((begin) (meaning-sequence (cdr e) r tail?))
 15 |         ((set!) (meaning-assignment (cadr e) (caddr e) r tail?))
 16 |         (else (meaning-application (car e) (cdr e) r tail?)))
 17 |       (if (symbol? e)
 18 |           (meaning-deref e r tail?)
 19 |           (meaning-quotation e r tail?))))
 20 | 
 21 | ;; Literal values and quotations
 22 | 
 23 | (define (meaning-quotation v r tail?)
 24 |   (CONSTANT v))
 25 | 
 26 | ;; Variable references
 27 | 
 28 | (define (meaning-deref n r tail?)
 29 |   (let ((kind (compute-kind r n)))
 30 |     (if kind
 31 |         (case (car kind)
 32 |           ((local)
 33 |            (let ((level (cadr kind))
 34 |                  (index (cddr kind)))
 35 |              (if (= level 0)
 36 |                  (SHALLOW-ARGUMENT-REF index)
 37 |                  (DEEP-ARGUMENT-REF level index))))
 38 |           ((global)
 39 |            (let ((index (cdr kind)))
 40 |              (CHECKED-GLOBAL-REF index)))
 41 |           ((predefined)
 42 |            (let ((index (cdr kind)))
 43 |              (PREDEFINED index))))
 44 |         (compiler-error "No such variable" n))))
 45 | 
 46 | ;; Conditional
 47 | 
 48 | (define (meaning-alternative ec et ef r tail?)
 49 |   (let ((mc (meaning ec r #f))
 50 |         (mt (meaning et r tail?))
 51 |         (mf (meaning ef r tail?)))
 52 |     (ALTERNATIVE mc mt mf)))
 53 | 
 54 | ;; Assignment
 55 | 
 56 | (define (meaning-assignment n e r tail?)
 57 |   (let ((m (meaning e r #f))
 58 |         (kind (compute-kind r n)))
 59 |     (if kind
 60 |         (case (car kind)
 61 |           ((local)
 62 |            (let ((level (cadr kind))
 63 |                  (index (cddr kind)))
 64 |              (if (= level 0)
 65 |                  (SHALLOW-ASSIGNMENT! index m)
 66 |                  (DEEP-ASSIGNMENT! level index m))))
 67 |           ((global)
 68 |            (let ((index (cdr kind)))
 69 |              (GLOBAL-SET! index m)))
 70 |           ((predefined)
 71 |            (compiler-error
 72 |             "Attempted to assign to immutable variable" n)))
 73 |         (compiler-error "Unknown variable" n))))
 74 | 
 75 | ;; Begin
 76 | 
 77 | (define (meaning-sequence e+ r tail?)
 78 |   (if (pair? e+)
 79 |       (if (pair? (cdr e+))
 80 |           (meaning*-multiple-sequence (car e+) (cdr e+) r tail?)
 81 |           (meaning*-single-sequence (car e+) r tail?))
 82 |       (compiler-error "Illegal form (begin)")))
 83 | 
 84 | (define (meaning*-single-sequence e r tail?)
 85 |   (meaning e r tail?))
 86 | 
 87 | (define (meaning*-multiple-sequence e e* r tail?)
 88 |   (let ((m (meaning e r #f))
 89 |         (m+ (meaning-sequence e* r tail?)))
 90 |     (SEQUENCE m m+)))
 91 | 
 92 | ;; OK now the slightly harder bits. Starting with
 93 | 
 94 | ;; Abstraction
 95 | 
 96 | (define (meaning-abstraction nn* e+ r tail?)
 97 |   (let parse ((n* nn*)
 98 |               (regular '()))
 99 |     (cond ((pair? n*) (parse (cdr n*) (cons (car n*) regular)))
100 |           ;; We ran through them all and no dot!
101 |           ;; Use nn* to avoid having to reverse `regular`
102 |           ((null? n*) (meaning-fix-abstraction nn* e+ r tail?))
103 |           (else (meaning-dotted-abstraction
104 |                  (reverse regular) n* e+ r tail?)))))
105 | 
106 | (define (meaning-fix-abstraction n* e+ r tail?)
107 |   (let* ((arity (length n*))
108 |          (r2 (r-extend* r n*))
109 |          (m+ (meaning-sequence e+ r2 #t)))
110 |     (FIX-CLOSURE m+ arity)))
111 | 
112 | (define (meaning-dotted-abstraction n* n e+ r tail?)
113 |   (let* ((arity (length n*))
114 |          (r2 (r-extend* r (append n* (list n))))
115 |          (m+ (meaning-sequence e+ r2 #t)))
116 |     (NARY-CLOSURE m+ arity)))
117 | 
118 | ;; The most fun of all, application
119 | 
120 | (define (meaning-application e e* r tail?)
121 |   (cond ((and (symbol? e)
122 |               (let ((kind (compute-kind r e)))
123 |                 (and (pair? kind)
124 |                      (eq? 'predefined (car kind))
125 |                      ;; As before I move the checking into
126 |                      ;; meaning-primitive-application; it just gets to
127 |                      ;; messy here.
128 |                      (meaning-primitive-application e e* r tail?)))))
129 |         ((and (pair? e)
130 |               (eq? 'lambda (car e)))
131 |          (meaning-closed-application e e* r tail?))
132 |         (else (meaning-regular-application e e* r tail?))))
133 | 
134 | (define (meaning-regular-application e e* r tail?)
135 |   (let ((m (meaning e r #f))
136 |         (m* (meaning* e* r (length e*) #f)))
137 |     (if tail?
138 |         (TR-REGULAR-CALL m m*)
139 |         (REGULAR-CALL m m*))))
140 | 
141 | (define (meaning* e* r size tail?)
142 |   (if (pair? e*)
143 |       (meaning-some-args (car e*) (cdr e*) r size tail?)
144 |       (meaning-no-arg r size tail?)))
145 | 
146 | (define (meaning-no-arg r size tail?)
147 |   (ALLOCATE-FRAME size))
148 | 
149 | (define (meaning-some-args e e* r size tail?)
150 |   (let ((m (meaning e r tail?))
151 |         (m* (meaning* e* r size tail?))
152 |         (index (- size (+ (length e*) 1))))
153 |     (STORE-ARGUMENT m m* index)))
154 | 
155 | ;; left-left-lambda
156 | ;; ((lambda (n*...) body) ee*...)
157 | (define (meaning-closed-application e ee* r tail?)
158 |   (let parse ((n* (cadr e))
159 |               (e* ee*)
160 |               (regular '()))
161 |     (cond
162 |       ((pair? n*)
163 |        (if (pair? e*)
164 |            (parse (cdr n*) (cdr e*) (cons (car n*) regular))
165 |            (compiler-error "Too few arguments: need" (cadr e)
166 |                            "got" ee*)))
167 |       ((null? n*)
168 |        (if (null? e*)
169 |            (meaning-fix-closed-application
170 |             (cadr e) (cddr e) ee* r tail?)
171 |            (compiler-error "Too many arguments: need" (cadr e)
172 |                            "got" ee*)))
173 |       (else
174 |         (meaning-dotted-closed-application
175 |          (reverse regular) n* (cddr e) ee* r tail?)))))
176 | 
177 | ;; ((lambda (a b) (+ a b)) 1 2)
178 | (define (meaning-fix-closed-application n* body e* r tail?)
179 |   (let* ((m* (meaning* e* r (length e*) #f))
180 |          (r2 (r-extend* r n*))
181 |          (m+ (meaning-sequence body r2 tail?)))
182 |     (if tail?
183 |         (TR-FIX-LET m* m+)
184 |         (FIX-LET m* m+))))
185 | 
186 | ;; ((lambda as (apply + as)) 1 2 3)
187 | (define (meaning-dotted-closed-application n* n body e* r tail?)
188 |   (let* ((m* (meaning-dotted* e* r (length e*) (length n*) #f))
189 |          (r2 (r-extend* r (append n* (list n))))
190 |          (m+ (meaning-sequence body r2 tail?)))
191 |     (if tail?
192 |         (TR-FIX-LET m* m+)
193 |         (FIX-LET m* m+))))
194 | 
195 | (define (meaning-dotted* e* r size arity tail?)
196 |   (if (pair? e*)
197 |       (meaning-some-dotted-args (car e*) (cdr e*)
198 |                                 r size arity tail?)
199 |       (meaning-no-dotted-arg r size arity tail?)))
200 | 
201 | (define (meaning-some-dotted-args e e* r size arity tail?)
202 |   (let ((m (meaning e r tail?))
203 |         (m* (meaning-dotted* e* r size arity tail?))
204 |         (index (- size (+ (length e*) 1))))
205 |     (if (< index arity)
206 |         (STORE-ARGUMENT m m* index)
207 |         (CONS-ARGUMENT m m* arity))))
208 | 
209 | (define (meaning-no-dotted-arg r size arity tail?)
210 |   (ALLOCATE-DOTTED-FRAME arity))
211 | 
212 | (define (meaning-primitive-application e e* r tail?)
213 |   (let ((desc (get-description e)))
214 |     (and desc ;; I don't know why it wouldn't be there, but anyway
215 |          ;; desc = (function address . arity)
216 |          (or (eq? 'function (car desc))
217 |              (compiler-error "Function expected"))
218 |          (let ((address (cadr desc))
219 |                (size (caddr desc)))
220 |            (and
221 |             ;; I did say I would check arity here
222 |             (or (= size (length e*))
223 |                 (compiler-error "Wrong arity for " e
224 |                                 "expected" size))
225 |             ;; This time I'll do it the book way; this sets up some of the VM
226 |             ;; instructions later on.
227 |             (case size
228 |               ((0) (CALL0 address))
229 |               ((1) (let ((m (meaning (car e*) r #f)))
230 |                      (CALL1 address m)))
231 |               ((2) (let ((m1 (meaning (car e*) r #f))
232 |                          (m2 (meaning (cadr e*) r #f)))
233 |                      (CALL2 address m1 m2)))
234 |               ((3) (let ((m1 (meaning (car e*) r #f))
235 |                          (m2 (meaning (cadr e*) r #f))
236 |                          (m3 (meaning (caddr e*) r #f)))
237 |                      (CALL3 address m1 m2 m3)))
238 |               (else
239 |                 (meaning-regular-application e e* r tail?))))))))
240 | 


--------------------------------------------------------------------------------
/primitives.c:
--------------------------------------------------------------------------------
  1 | /* Defines the globals and primitives in use. Most primitives will be
  2 |    defined as a C procedure to be called inlined, and a structure
  3 |    (referring to the procedure) to be used as a value. Some of the C
  4 |    procedures are wrappers around a macro, where the macro has been
  5 |    defined for convenience in C code.
  6 |  */
  7 | 
  8 | #include "scheme.h"
  9 | 
 10 | /* Globals */
 11 | 
 12 | SCM_DefineImmediateObject(SCM_nil_object,SCM_NULL_TAG);
 13 | SCM_DefineImmediateObject(SCM_true_object,SCM_BOOLEAN_TAG);
 14 | SCM_DefineImmediateObject(SCM_false_object,SCM_BOOLEAN_TAG);
 15 | SCM_DefineImmediateObject(SCM_undefined_object,SCM_UNDEFINED_TAG);
 16 | 
 17 | SCM_DefineInitializedGlobal(NIL, "NIL", &SCM_nil_object);
 18 | SCM_DefineInitializedGlobal(F, "F", &SCM_false_object);
 19 | SCM_DefineInitializedGlobal(T, "T", &SCM_true_object);
 20 | 
 21 | /* The structs representing predefined procedures used as values. The
 22 |    uppercase names are aliases given in Scheme->C-names-mapping */
 23 | 
 24 | SCM_PredefineFunctionVariable(EQNP,"=",2,SCM_eqnp);
 25 | SCM_PredefineFunctionVariable(EQP,"EQ?",2,SCM_eqp);
 26 | SCM_PredefineFunctionVariable(car,"CAR",1,SCM_car);
 27 | SCM_PredefineFunctionVariable(cdr,"CDR",1,SCM_cdr);
 28 | SCM_PredefineFunctionVariable(cons,"CONS",2,SCM_cons);
 29 | SCM_PredefineFunctionVariable(CONSP,"PAIR?",1,SCM_consp);
 30 | SCM_PredefineFunctionVariable(NULLP,"NULL?",1,SCM_nullp);
 31 | SCM_PredefineFunctionVariable(PLUS,"PLUS",2,SCM_plus);
 32 | 
 33 | SCM_PredefineFunctionVariable(list,"LIST",-1,SCM_list);
 34 | SCM_PredefineFunctionVariable(apply,"APPLY",-3,SCM_apply);
 35 | 
 36 | SCM_PredefineFunctionVariable(print,"PRINT",1,SCM_print);
 37 | 
 38 | /* Apply.
 39 | 
 40 | Reminder: (apply f [arg1 ...] args) requires args to be a list, and
 41 | calls the procedure f with arguments consisting of `arg1 ...` then the
 42 | elements of `args`.
 43 | */
 44 | 
 45 | SCM SCM_apply(unsigned long count, va_list arguments) {
 46 |   SCM args[31]; /* yes, an arbitrary limit on number of arguments
 47 |                    allowed */
 48 |   SCM f = va_arg(arguments, SCM);
 49 |   if (SCM_2tag(f) != SCM_CLOSURE_TAG &&
 50 |       SCM_2tag(f) != SCM_SUBR_TAG) {
 51 |     return SCM_error(SCM_ERR_CANNOT_APPLY);
 52 |   }
 53 | 
 54 |   unsigned long i;
 55 |   for (i = 0; i < count - 1; i++) {
 56 |     args[i] = va_arg(arguments,SCM);
 57 |   }
 58 |   SCM last = args[--i]; /* going to overwrite */
 59 | 
 60 |   while (SCM_PairP(last)) {
 61 |     args[i++] = SCM_Car(last);
 62 |     last = SCM_Cdr(last);
 63 |   }
 64 |   if (!SCM_NullP(last)) {
 65 |     return SCM_error(SCM_ERR_APPLY_ARG);
 66 |   }
 67 | 
 68 |   switch (i) {
 69 |   case 0: return SCM_invoke0(f);
 70 |   case 1: return SCM_invoke1(f,args[0]);
 71 |   case 2: return SCM_invoke2(f,args[0],args[1]);
 72 |   case 3: return SCM_invoke3(f,args[0],args[1],args[2]);
 73 |   case 4: return SCM_invoke(f,4,args[0],args[1],args[2],args[3]);
 74 |   case 5: return SCM_invoke(f,5,args[0],args[1],args[2],args[3],args[4]);
 75 |   case 6: return SCM_invoke(f,6,args[0],args[1],args[2],args[3],args[4],args[5]);
 76 |   default:
 77 |     return SCM_error(SCM_ERR_APPLY_SIZE);
 78 |   }
 79 | }
 80 | 
 81 | /* Runtime primitives based on macros (the functions rather than the
 82 |  * structs). The book code has a couple of shortcuts for these, which
 83 |  * I'll copy. */
 84 | 
 85 | #define DefDyadicFunction(name,macro) \
 86 | SCM name(SCM x, SCM y) {              \
 87 |   return macro(x, y);                 \
 88 | }
 89 | 
 90 | #define DefDyadicPred(name,macro) \
 91 | SCM name(SCM x, SCM y) {          \
 92 |   return (SCM_2bool(macro(x,y))); \
 93 | }
 94 | 
 95 | #define DefMonadicPred(name,macro) \
 96 | SCM name(SCM x) {                  \
 97 |   return (SCM_2bool(macro(x)));    \
 98 | }
 99 | 
100 | DefMonadicPred(SCM_nullp, SCM_NullP);
101 | DefMonadicPred(SCM_consp, SCM_PairP);
102 | DefMonadicPred(SCM_symbolp, SCM_SymbolP);
103 | DefMonadicPred(SCM_stringp, SCM_StringP);
104 | 
105 | DefDyadicPred(SCM_eqp, SCM_EqP);
106 | 
107 | DefDyadicFunction(SCM_plus, SCM_Plus)
108 | DefDyadicFunction(SCM_eqnp, SCM_EqnP)
109 | 


--------------------------------------------------------------------------------
/run-smoketest.scm:
--------------------------------------------------------------------------------
 1 | #! /usr/bin/env scheme-r5rs
 2 | 
 3 | ;; A test runner, effectively. Takes a file containing an interpreter
 4 | ;; and outputs the results of evaluating the expressions in
 5 | ;; "test-exprs.scm". Assumes a procedure `eval-exprs` which reads
 6 | ;; expressions and evaluates them until it reaches EOF, displaying the
 7 | ;; results to stdout.
 8 | 
 9 | ;; Probably only works with SISC (http://sisc-scheme.org/) or
10 | ;; something with the same module system and modules, so e.g.,
11 | ;; (import type-system) and so on work.
12 | 
13 | ;; Actually, other than those imports, it's all R5RS I think.
14 | 
15 | (load "prelude.ss")
16 | (load "show.ss")
17 | 
18 | (max-stack-trace-depth 16)
19 | #;(suppressed-stack-trace-source-kinds '())
20 | 
21 | (define (main arguments)
22 | 
23 |   (load (cadr arguments))
24 | 
25 |   (with-input-from-port (open-input-file "test-exprs.scm")
26 |     (lambda ()
27 |       (define (eval-exprs)
28 |         (let* ((desc (read))
29 |                (expr (read)))
30 |           (when (not (eq? #!eof desc))
31 |                 (display desc)(newline)
32 |                 (with-failure-continuation
33 |                  (lambda (e k)
34 |                    (display e)(newline)
35 |                    (eval-exprs))
36 |                  (lambda () (display (eval-expr expr))(newline)))
37 |                 (eval-exprs))))
38 |       (eval-exprs)))
39 |   0)
40 | 


--------------------------------------------------------------------------------
/scheme.c:
--------------------------------------------------------------------------------
  1 | 
  2 | #include "scheme.h"
  3 | #include <stdio.h>
  4 | 
  5 | /* Instantiate a closure */
  6 | 
  7 | SCM SCM_close (SCM (*Cfunction)(void),
  8 |                long arity, unsigned long size, ...) {
  9 |   /* sizeof(SCM_unwrapped_closure) gives enough room to put the
 10 |    * header, function pointer, arity, and one field. Each closure
 11 |    * struct has its own set of free variable fields, so we need to
 12 |    * make space for those as well (minus the one already there). See
 13 |    * SCM_DefineClosure in scheme.h */
 14 |   SCMref result = (SCMref) malloc(sizeof(struct SCM_unwrapped_closure) +
 15 |                                   (size - 1)*sizeof(SCM));
 16 |   unsigned long i;
 17 |   va_list args;
 18 |   if (result == (SCMref)NULL) SCM_error(SCM_ERR_CANT_ALLOC);
 19 |   result->closure.header.tag = SCM_CLOSURE_TAG;
 20 |   result->closure.behaviour = Cfunction;
 21 |   result->closure.arity = arity;
 22 |   va_start(args,size);
 23 |   for (i = 0; i < size; i++) {
 24 |     result->closure.environment[i] = va_arg(args,SCM);
 25 |   }
 26 |   va_end(args);
 27 |   return SCM_Wrap(result);
 28 | }
 29 | 
 30 | /* Boxeses */
 31 | 
 32 | /* As the book code notes, it is kind of ridiculous to malloc a
 33 |  * word. It would be better to allocate pools of boxes at a time,
 34 |  * perhaps. */
 35 | SCM SCM_allocate_box(SCM v) {
 36 |   SCM cell = (SCM) malloc(sizeof(struct SCM_box));
 37 |   if (cell == (SCM)NULL) SCM_error(SCM_ERR_CANT_ALLOC);
 38 |   cell->box.content = v;
 39 |   return cell;
 40 | }
 41 | 
 42 | /* Pairs */
 43 | 
 44 | SCM SCM_cons (SCM a, SCM d) {
 45 |   SCMref cell = (SCMref) malloc(sizeof(struct SCM_unwrapped_pair));
 46 |   if (cell == (SCMref)NULL) SCM_error(SCM_ERR_CANT_ALLOC);
 47 |   cell->pair.header.tag = SCM_PAIR_TAG;
 48 |   cell->pair.cdr = d;
 49 |   cell->pair.car = a;
 50 |   return SCM_Wrap(cell);
 51 | }
 52 | 
 53 | SCM SCM_car (SCM cell) {
 54 |   if (SCM_PairP(cell)) {
 55 |     return SCM_Car(cell);
 56 |   }
 57 |   else return SCM_error(SCM_ERR_CAR);
 58 | }
 59 | 
 60 | SCM SCM_cdr (SCM cell) {
 61 |   if (SCM_PairP(cell)) {
 62 |     return SCM_Cdr(cell);
 63 |   }
 64 |   else return SCM_error(SCM_ERR_CDR);
 65 | }
 66 | 
 67 | SCM SCM_set_cdr (SCM cell, SCM value) {
 68 |   if (SCM_PairP(cell)) {
 69 |     SCM_Unwrap(cell)->pair.cdr = value;
 70 |     return cell;
 71 |   }
 72 |   else return SCM_error(SCM_ERR_SET_CDR);
 73 | }
 74 | 
 75 | /* Just for fun, I'm going to take a different approach to the book
 76 |  * here, and allocate a list in an array in one go. */
 77 | SCM SCM_list(unsigned long count, va_list arguments) {
 78 |   if (count == 0) return SCM_nil;
 79 | 
 80 |   struct SCM_unwrapped_pair *cells =
 81 |     malloc(count * sizeof(struct SCM_unwrapped_pair));
 82 |   unsigned long i;
 83 |   for (i = 0; i < count; i++) {
 84 |     struct SCM_unwrapped_pair *cell = &cells[i];
 85 |     cell->header.tag = SCM_PAIR_TAG;
 86 |     cell->car = va_arg(arguments,SCM);
 87 |     if (i + 1 < count) {
 88 |       cell->cdr = SCM_Wrap(&cells[i+1]);
 89 |     }
 90 |     else {
 91 |       cell->cdr = SCM_nil;
 92 |     }
 93 |   }
 94 |   return SCM_Wrap(cells);
 95 | }
 96 | 
 97 | /* For debug, and main output */
 98 | SCM SCM_prin(SCM x);
 99 | 
100 | /* Prin a value in list position */
101 | void SCM_prin_list(SCM x) {
102 |   if (SCM_FixnumP(x)) {
103 |     fprintf(stdout, " . %ld", SCM_Fixnum2int(x));
104 |   }
105 |   else {
106 |     switch (SCM_2tag(x)) {
107 |     case SCM_NULL_TAG: {
108 |       break;
109 |     }
110 |     case SCM_PAIR_TAG: {
111 |       fprintf(stdout, " ");
112 |       SCM_prin(SCM_Car(x));
113 |       SCM_prin_list(SCM_Cdr(x));
114 |       break;
115 |     }
116 |     default: {
117 |       fprintf(stdout, " . ");
118 |       SCM_prin(x);
119 |       break;
120 |     }
121 |     }
122 |   }
123 | }
124 | 
125 | SCM SCM_prin(SCM x) {
126 |   if (SCM_FixnumP(x)) {
127 |     fprintf(stdout, "%ld", SCM_Fixnum2int(x));
128 |   }
129 |   else {
130 |     switch (SCM_2tag(x)) {
131 |     case SCM_NULL_TAG: {
132 |       fprintf(stdout, "()");
133 |       break;
134 |     }
135 |     case SCM_PAIR_TAG: {
136 |       fprintf(stdout, "(");
137 |       SCM_prin(SCM_Car(x));
138 |       SCM_prin_list(SCM_cdr(x));
139 |       fprintf(stdout, ")");
140 |       break;
141 |     }
142 |     case SCM_BOOLEAN_TAG: {
143 |       fprintf(stdout, "#%c", (SCM_EqP(x,SCM_true) ? 't' : 'f'));
144 |       break;
145 |     }
146 |     case SCM_UNDEFINED_TAG: {
147 |       fprintf(stdout, "#<undefined>");
148 |       break;
149 |     }
150 |     case SCM_SYMBOL_TAG: {
151 |       SCM str = SCM_Unwrap(x)->symbol.pname;
152 |       char *Cstring = SCM_Unwrap(str)->string.Cstring;
153 |       fprintf(stdout, "%s", Cstring);
154 |       break;
155 |     }
156 |     case SCM_STRING_TAG: {
157 |       char *Cstring = SCM_Unwrap(x)->string.Cstring;
158 |       fprintf(stdout,"\"%s\"", Cstring);
159 |       break;
160 |     }
161 |     case SCM_SUBR_TAG: {
162 |       fprintf(stdout, "#<procedure@%p>", (void *)(x));
163 |       break;
164 |     }
165 |     case SCM_CLOSURE_TAG: {
166 |       fprintf(stdout, "#<closure@%p>", (void *)(x));
167 |       break;
168 |     }
169 |     case SCM_ESCAPE_TAG: {
170 |       fprintf(stdout, "#<continuation@%p>", (void *)(x));
171 |       break;
172 |     }
173 |     default:
174 |       fprintf(stdout, "<something@%p>", (void *)(x));
175 |       break;
176 |     }
177 |   }
178 |   return (x);
179 | }
180 | 
181 | SCM SCM_print(SCM x) {
182 |   SCM_prin(x);
183 |   printf("\n");
184 |   return (x);
185 | }
186 | 
187 | SCM SCM_signal_error(unsigned long code, unsigned long line, char* file) {
188 |   fprintf(stdout, "Error %lu in %s:%lu\n", code, file, line);
189 |   exit(code);
190 | }
191 | 
192 | /* Now for the big one, invoke. */
193 | SCM SCM_invoke(SCM function, unsigned long number, ...) {
194 |   if (SCM_FixnumP(function)) {
195 |     return SCM_error(SCM_ERR_CANNOT_APPLY);
196 |   }
197 |   else {
198 |     switch (SCM_2tag(function)) {
199 |     case SCM_SUBR_TAG: {
200 |       SCM (*behaviour)(void) = (SCM_Unwrap(function)->subr).behaviour;
201 |       long arity = (SCM_Unwrap(function)->subr).arity;
202 |       SCM result;
203 |       if (arity >= 0) { // no varargs
204 |         if (arity != number) {
205 |           return SCM_error(SCM_ERR_WRONG_ARITY);
206 |         }
207 |         else {
208 |           if (arity == 0) {
209 |             result = behaviour();
210 |           }
211 |           else {
212 |             va_list args;
213 |             va_start(args, number);
214 |             /* ugly, but perhaps necessary */
215 |             SCM a0 = va_arg(args,SCM);
216 |             if (number == 1) {
217 |               result = ((SCM (*)(SCM))*behaviour)(a0);
218 |             }
219 |             else {
220 |               SCM a1 = va_arg(args,SCM);
221 |               if (number == 2) {
222 |                 result = ((SCM (*)(SCM,SCM))*behaviour)(a0, a1);
223 |               }
224 |               else {
225 |                 SCM a2 = va_arg(args,SCM);
226 |                 if (number == 3) {
227 |                   result = ((SCM (*)(SCM,SCM,SCM))*behaviour)(a0, a1, a2);
228 |                 }
229 |                 else {
230 |                   return SCM_error(SCM_ERR_INTERNAL);
231 |                 }
232 |               }
233 |             }
234 |             va_end(args);
235 |           }
236 |           return result;
237 |         }
238 |       }
239 |       else { /* varargs */
240 |         long min_arity = SCM_MinimalArity(arity);
241 |         if (number < min_arity) {
242 |           return SCM_error(SCM_ERR_WRONG_ARITY);
243 |         }
244 |         else {
245 |           va_list args;
246 |           SCM result;
247 |           va_start(args, number);
248 |           result = ((SCM (*)(unsigned long, va_list))
249 |                     *behaviour)(number, args);
250 |           va_end(args);
251 |           return result;
252 |         }
253 |       }
254 |     } /* case SCM_SUBR_TAG */
255 |     case SCM_CLOSURE_TAG: {
256 |       SCM (*behaviour)(void) = (SCM_Unwrap(function)->closure).behaviour;
257 |       long arity = (SCM_Unwrap(function)->closure).arity;
258 |       SCM result;
259 |       va_list args;
260 |       va_start(args,number);
261 |       if (arity >= 0) {
262 |         if (arity != number) {
263 |           return SCM_error(SCM_ERR_WRONG_ARITY);
264 |         }
265 |         else {
266 |           result = ((SCM (*)(SCM,unsigned long, va_list)) *behaviour)
267 |             (function, number, args);
268 |         }
269 |       }
270 |       else { /* varargs */
271 |         long min_arity = SCM_MinimalArity(arity);
272 |         if (number < min_arity) {
273 |           return SCM_error(SCM_ERR_WRONG_ARITY);
274 |         }
275 |         else {
276 |           result = ((SCM (*)(SCM,unsigned long, va_list)) *behaviour)
277 |             (function, number, args);
278 |         }
279 |       }
280 |       va_end(args);
281 |       return result;
282 |     } /* case SCM_CLOSURE_TAG */
283 |     default:
284 |       return SCM_error(SCM_ERR_CANNOT_APPLY);
285 |     }
286 |   }
287 | }
288 | 


--------------------------------------------------------------------------------
/scheme.h:
--------------------------------------------------------------------------------
  1 | 
  2 | #ifndef SCHEME_H
  3 | #define SCHEME_H
  4 | 
  5 | #include <stdarg.h>
  6 | #include <stdlib.h>
  7 | 
  8 | /* Values */
  9 | 
 10 | /* A Scheme value (SCM) is a pointer to the union SCM_object, OR a
 11 |  * fixnum */
 12 | typedef union SCM_object *SCM;
 13 | 
 14 | /* Fixnums are puns of the above, and have the lowest bit set.  All
 15 |    other values are pointers to SCM_object, and have the lowest bit
 16 |    unset. */
 17 | #define SCM_FixnumP(x)    ((unsigned long)(x) & (unsigned long)1)
 18 | #define SCM_Fixnum2int(x) ((long)(x) >> 1)
 19 | #define SCM_Int2fixnum(x) ((SCM)(((x)<<1) | 1))
 20 | 
 21 | /* Values that are pointed to ... */
 22 | union SCM_object {
 23 |   struct SCM_pair {
 24 |     SCM cdr;
 25 |     SCM car;
 26 |   } pair;
 27 |   struct SCM_string {
 28 |     char Cstring[8];
 29 |   } string;
 30 |   struct SCM_symbol {
 31 |     SCM pname;
 32 |   } symbol;
 33 |   struct SCM_box {
 34 |     SCM content;
 35 |   } box;
 36 |   struct SCM_subr {
 37 |     SCM (*behaviour)();
 38 |     long arity;
 39 |   } subr;
 40 |   /* See SCM_DefineClosure later */
 41 |   struct SCM_closure {
 42 |     SCM (*behaviour)();
 43 |     long arity;
 44 |     SCM environment[1];
 45 |   } closure;
 46 |   struct SCM_escape {
 47 |     struct SCM_jmp_buf *stack_address;
 48 |   } escape;
 49 | };
 50 | 
 51 | /* Each value has a tag that says what type of value it is. This is
 52 |  * put in the word *before* the pointer. In the book the value pointers
 53 |  * are called "wrapped", and word-behind-value pointers are called
 54 |  * "unwrapped". I'm not clear on when each is used .. */
 55 | 
 56 | /* These discriminate among the types in the union above. NB they
 57 |  * don't take a whole word. */
 58 | enum SCM_tag {
 59 |   SCM_NULL_TAG      = 0xaaa0,
 60 |   SCM_PAIR_TAG      = 0xaaa1,
 61 |   SCM_BOOLEAN_TAG   = 0xaaa2,
 62 |   SCM_UNDEFINED_TAG = 0xaaa3,
 63 |   SCM_SYMBOL_TAG    = 0xaaa4,
 64 |   SCM_STRING_TAG    = 0xaaa5,
 65 |   SCM_SUBR_TAG      = 0xaaa6,
 66 |   SCM_CLOSURE_TAG   = 0xaaa7,
 67 |   SCM_ESCAPE_TAG    = 0xaaa8
 68 | };
 69 | /* The union is just to guarantee that the header takes up a word */
 70 | union SCM_header {
 71 |   enum SCM_tag tag;
 72 |   SCM ignored;
 73 | };
 74 | 
 75 | /* These are what we'll actually use when creating values; it's the
 76 |  * same structs as the SCM_object but with the tag at the front. */
 77 | union SCM_unwrapped_object {
 78 |   /* .. Apart from this one, which is for things that are singletons,
 79 |    * e.g., NIL, true, false. */
 80 |   struct SCM_unwrapped_immediate_object {
 81 |     union SCM_header header;
 82 |   } object;
 83 | 
 84 |   struct SCM_unwrapped_pair {
 85 |     union SCM_header header;
 86 |     SCM cdr;
 87 |     SCM car;
 88 |   } pair;
 89 |   struct SCM_unwrapped_string {
 90 |     union SCM_header header;
 91 |     char Cstring[8];
 92 |   } string;
 93 |   struct SCM_unwrapped_symbol {
 94 |     union SCM_header header;
 95 |     SCM pname;
 96 |   } symbol;
 97 |   struct SCM_unwrapped_box {
 98 |     union SCM_header header;
 99 |     SCM content;
100 |   } box;
101 |   struct SCM_unwrapped_subr {
102 |     union SCM_header header;
103 |     SCM (*behaviour)();
104 |     long arity;
105 |   } subr;
106 |   struct SCM_unwrapped_closure {
107 |     union SCM_header header;
108 |     SCM (*behaviour)();
109 |     long arity;
110 |     SCM environment[1];
111 |   } closure;
112 |   struct SCM_unwrapped_escape {
113 |     union SCM_header header;
114 |     struct SCM_jmp_buf *stack_address;
115 |   } escape;
116 | };
117 | 
118 | typedef union SCM_unwrapped_object *SCMref;
119 | 
120 | #define SCM_Wrap(x)   ((SCM) (((union SCM_header *) x) + 1))
121 | #define SCM_Unwrap(x) ((SCMref) (((union SCM_header *) x) - 1))
122 | #define SCM_2tag(x)   ((SCM_Unwrap((SCM)x))->object.header.tag)
123 | 
124 | #define SCM_CfunctionAddress(Cfunction) ((SCM (*)(void)) Cfunction)
125 | 
126 | /* Defining values (quotations) */
127 | 
128 | #define SCM_DefinePair(pair, car, cdr) \
129 |   static struct SCM_unwrapped_pair = {{SCM_PAIR_TAG}, cdr, car}
130 | #define SCM_DefineSymbol(symbol, pname)      \
131 |   static struct SCM_unwrapped_symbol symbol = \
132 |     {{SCM_SYMBOL_TAG}, pname}
133 | /* To statically allocate a string, we have to define a data structure
134 |  * of the appropraite size first */
135 | #define SCM_DefineString(Cname,string) \
136 |   struct Cname##_struct {              \
137 |     union SCM_header header;           \
138 |     char CString[1 + sizeof(string)];  \
139 |   };                                   \
140 |   static struct Cname##_struct Cname = \
141 |     {{SCM_STRING_TAG},string}
142 | 
143 | #define SCM_DefineImmediateObject(name,tag)             \
144 |   struct SCM_unwrapped_immediate_object name = {{tag}}
145 | 
146 | /* These get used in the generated code, and given values in
147 |    primitives.c and scheme.c */
148 | extern struct SCM_unwrapped_immediate_object SCM_true_object;
149 | extern struct SCM_unwrapped_immediate_object SCM_false_object;
150 | extern struct SCM_unwrapped_immediate_object SCM_nil_object;
151 | extern struct SCM_unwrapped_immediate_object SCM_undefined_object;
152 | #define SCM_true  SCM_Wrap(&SCM_true_object)
153 | #define SCM_false SCM_Wrap(&SCM_false_object)
154 | #define SCM_nil   SCM_Wrap(&SCM_nil_object)
155 | #define SCM_undefined SCM_Wrap(&SCM_undefined_object)
156 | 
157 | /* Runtime procedures, defined in scheme.c or primitives.c */
158 | 
159 | extern SCM SCM_invoke(SCM fun, unsigned long number, ...);
160 | extern SCM SCM_close(SCM (*Cfunc)(void), long arity, unsigned long size, ...);
161 | extern SCM SCM_signal_error(unsigned long code, unsigned long line, char *file);
162 | extern SCM SCM_allocate_box(SCM v);
163 | /* extern SCM SCM_allocate_continuation (struct SCM_jmp_buf *address); */
164 | extern SCM SCM_prin(SCM x); /* not the primitive, though it uses this */
165 | 
166 | /* These are used as primitives, but only via their values (not called
167 |  * inline), because they're not fixed arity. */
168 | extern SCM SCM_list(unsigned long count, va_list arguments);
169 | extern SCM SCM_apply(unsigned long count, va_list arguments);
170 | 
171 | /* Handy macros for dealing with values from C */
172 | 
173 | #define SCM_2bool(x) ((x) ? SCM_true : SCM_false)
174 | 
175 | /* Unsafe pair ops */
176 | #define SCM_Car(x) (SCM_Unwrap(x)->pair.car)
177 | #define SCM_Cdr(x) (SCM_Unwrap(x)->pair.cdr)
178 | #define SCM_NullP(x) ((x) == SCM_nil)
179 | #define SCM_PairP(x) \
180 |   ((!SCM_FixnumP(x)) && (SCM_2tag(x) == SCM_PAIR_TAG))
181 | 
182 | /* Predicates */
183 | #define SCM_SymbolP(x) \
184 |   ((!SCM_FixnumP(x)) && (SCM_2tag(x) == SCM_SYMBOL_TAG))
185 | #define SCM_StringP(x) \
186 |   ((!SCM_FixnumP(x)) && (SCM_2tag(x) == SCM_STRING_TAG))
187 | 
188 | #define SCM_EqP(x,y) ((x)==(y))
189 | 
190 | #define SCM_EqnP(x,y) \
191 |   ((SCM_FixnumP(x) && SCM_FixnumP(y))                 \
192 |   ? SCM_2bool(SCM_Fixnum2int(x) == SCM_Fixnum2int(y)) \
193 |    : SCM_error(SCM_ERR_EQNP))
194 | 
195 | /* Operations as macros */
196 | 
197 | #define SCM_Plus(x,y) \
198 |   ((SCM_FixnumP(x) && SCM_FixnumP(y)) \
199 |   ? SCM_Int2fixnum(SCM_Fixnum2int(x) + SCM_Fixnum2int(y)) \
200 |   : SCM_error(SCM_ERR_PLUS))
201 | 
202 | #define SCM_GtP(x,y) \
203 |   ((SCM_FixnumP(x) && SCM_FixnumP(y)) \
204 |   ? SCM_2bool(SCM_Fixnum2int(x) > SCM_Fixnum2int(y)) \
205 |   : SCM_error(SCM_ERR_GTP))
206 | 
207 | /* ... TODO */
208 | 
209 | /* Global variables */
210 | 
211 | #define SCM_CheckedGlobal(Cname) \
212 |   ((Cname != SCM_undefined) \
213 |    ? Cname : SCM_error(SCM_ERR_UNINITIALIZED))
214 | 
215 | /* Oddly, used to initialize globals with an undefined value. But
216 |  * there you are. */
217 | #define SCM_DefineInitializedGlobal(Cname,string,value) \
218 |   SCM Cname = SCM_Wrap(value)
219 | 
220 | #define SCM_DefineGlobalVariable(Cname,string) \
221 |   SCM_DefineInitializedGlobal(Cname,string,&SCM_undefined_object)
222 | 
223 | /* Predefined functions */
224 | 
225 | #define SCM_PredefineFunctionVariable(subr,string,arity,Cfunction) \
226 |   static struct SCM_unwrapped_subr subr##_object = \
227 |     {{SCM_SUBR_TAG}, Cfunction, arity}; \
228 |   SCM_DefineInitializedGlobal(subr,string,&(subr##_object))
229 | 
230 | /* Boxen */
231 | 
232 | #define SCM_Content(e) ((e)->box.content)
233 | 
234 | /* Closures and runtime procedures */
235 | 
236 | /* Each closure has its own struct, with the code as a function
237 |  * pointer to a thunk, the arity, and the free variables. Note that
238 |  * the generated code ends up with the same name -- slightly
239 |  * confusing. */
240 | 
241 | /* NB: these are punned with SCM_closure, which has the same first two
242 |  * fields and a placeholder for the fields. When allocating a closure,
243 |  * the correct size is chosen and the full set of free variable fields
244 |  * written in. */
245 | 
246 | #define SCM_DefineClosure(struct_name,fields) \
247 |   struct struct_name {      \
248 |     SCM (*behaviour)(void); \
249 |     long arity;             \
250 |     fields }
251 | 
252 | /* A runtime procedure is given the closure struct (for free vars),
253 |  * the number of args actually passed, and an array of the
254 |  * arguments. (As the book notes, there's several ways to do
255 |  * invocation, and this is not necessarily the fastest) */
256 | 
257 | #define SCM_DeclareFunction(Cname) \
258 |   SCM Cname (struct Cname *self_, unsigned long size_, \
259 |              va_list arguments_)
260 | /* va_arg gets the next argument from a va_list, and advances the
261 |    pointer */
262 | #define SCM_DeclareVariable(Cname,rank) \
263 |   SCM Cname = va_arg(arguments_,SCM)
264 | /* Happily there is (will be) already a procedure for forming a list
265 |  * from an array of arguments -- it's just the C form of
266 |  *  (list . args) */
267 | #define SCM_DeclareDottedVariable(Cname,rank) \
268 |   SCM Cname = SCM_list(size_ - rank, arguments_)
269 | /* Free variables come from the closure struct fields */
270 | #define SCM_Free(Cname) ((*self_).Cname)
271 | 
272 | 
273 | /* Shorthands for invoke */
274 | 
275 | #define SCM_invoke0(f)       SCM_invoke(f, 0)
276 | #define SCM_invoke1(f,x)     SCM_invoke(f,1,x)
277 | #define SCM_invoke2(f,x,y)   SCM_invoke(f,2,x,y)
278 | #define SCM_invoke3(f,x,y,z) SCM_invoke(f,3,x,y,z)
279 | 
280 | /* Given a varargs procedure, figure out how many args are *required*
281 |  * to be given */
282 | #define SCM_MinimalArity(i) (-(i)-1)
283 | 
284 | /* Error reporting */
285 | #define SCM_error(num) SCM_signal_error(num,__LINE__,__FILE__)
286 | 
287 | /* May as well use the same scheme as the book */
288 | 
289 | #define SCM_ERR_PLUS           70
290 | #define SCM_ERR_GTP            75
291 | #define SCM_ERR_EQNP           77
292 | 
293 | #define SCM_ERR_CAR            60
294 | #define SCM_ERR_CDR            61
295 | #define SCM_ERR_SET_CAR        62
296 | #define SCM_ERR_SET_CDR        63
297 | 
298 | #define SCM_ERR_CANNOT_APPLY   50
299 | #define SCM_ERR_WRONG_ARITY    51
300 | #define SCM_ERR_INTERNAL       52
301 | #define SCM_ERR_MISSING_ARGS   53
302 | 
303 | #define SCM_ERR_APPLY_ARG      40
304 | #define SCM_ERR_APPLY_SIZE     41
305 | 
306 | #define SCM_ERR_CANT_ALLOC     100
307 | #define SCM_ERR_UNINITIALIZED  11
308 | 
309 | /* Finally, declare the rest of the primitives */
310 | 
311 | #define SCM_DeclareConstant(var) extern SCM var
312 | 
313 | #define SCM_DeclareSubr0(var,Cname) \
314 |   SCM_DeclareConstant(var); extern SCM Cname(void)
315 | #define SCM_DeclareSubr1(var,Cname) \
316 |   SCM_DeclareConstant(var); extern SCM Cname(SCM x)
317 | #define SCM_DeclareSubr2(var,Cname) \
318 |   SCM_DeclareConstant(var); extern SCM Cname(SCM x, SCM y)
319 | #define SCM_DeclareSubr3(var,Cname) \
320 |   SCM_DeclareConstant(var); extern SCM Cname(SCM x, SCM y, SCM z)
321 | 
322 | SCM_DeclareSubr2(EQNP,SCM_eqnp);
323 | SCM_DeclareSubr2(EQP,SCM_eqp);
324 | SCM_DeclareSubr1(car,SCM_car);
325 | SCM_DeclareSubr1(cdr,SCM_cdr);
326 | SCM_DeclareSubr2(cons,SCM_cons);
327 | SCM_DeclareSubr1(CONSP,SCM_consp);
328 | SCM_DeclareSubr1(NULLP,SCM_nullp);
329 | SCM_DeclareSubr2(PLUS,SCM_plus);
330 | 
331 | SCM_DeclareSubr1(print,SCM_print);
332 | 
333 | /* These aren't available to be called inline, so they just get the
334 |  * structs declared */
335 | SCM_DeclareConstant(list);
336 | SCM_DeclareConstant(apply);
337 | 
338 | #endif /* SCHEME_H */
339 | 


--------------------------------------------------------------------------------
/sexpr.ss:
--------------------------------------------------------------------------------
 1 | ;; Procedures to show the various states of transformation.  This
 2 | ;; covers the classes given in chapter9.ss; it is extended in
 3 | ;; chapter10.ss
 4 | 
 5 | (import generic-procedures)
 6 | 
 7 | (define-generics ->sexpr)
 8 | 
 9 | (define-methods ->sexpr
10 |   ;; Sometimes we're in an implicit list-of-expressions and we want to
11 |   ;; get something to cons to
12 |   ([(<program> p) (<boolean> listy)]
13 |    (if listy (list (->sexpr p)) (->sexpr p)))
14 | 
15 |   ([(<constant> c)] (:value c))
16 |   ([(<variable> v)] (:name v))
17 |   ([(<local-reference> r)] (-> r :variable ->sexpr))
18 |   ([(<global-reference> r)] (-> r :variable ->sexpr))
19 |   ([(<predefined-application> a)]
20 |    `(,(-> a :variable :name) ,@(->sexpr (:arguments a))))
21 |   ([(<predefined-reference> r)] (-> r :variable :name))
22 |   ([(<some-arguments> a)]
23 |    (cons (->sexpr (:first a)) (->sexpr (:others a))))
24 |   ([(<no-argument> a)] '())
25 |   ([(<fix-let> l)]
26 |    `(let (,@(map (lambda (var expr) `(,(:name var) ,expr))
27 |                  (:variables l) (->sexpr (:arguments l))))
28 |       ,@(->sexpr (:body l) #t)))
29 |   ([(<sequence> s)]
30 |    `(begin
31 |       ,(->sexpr (:first s))
32 |       ,@(->sexpr (:last s) #t)))
33 |   ([(<sequence> s) (<boolean> listy)]
34 |    (if listy (cons (->sexpr (:first s) #f) (->sexpr (:last s) #t))
35 |        (->sexpr s)))
36 |   ([(<function> f)]
37 |    `(lambda ,(map :name (:variables f))
38 |       ,@(->sexpr (:body f) #t)))
39 |   ([(<regular-application> a)]
40 |    `(,(->sexpr (:function a)) ,@(->sexpr (:arguments a))))
41 |   ([(<alternative> a)]
42 |    `(if ,(->sexpr (:condition a))
43 |         ,(->sexpr (:consequent a))
44 |         ,(->sexpr (:alternant a))))
45 | )
46 | 


--------------------------------------------------------------------------------
/show.ss:
--------------------------------------------------------------------------------
 1 | ;; Friendly representations of classes (and values in general, but
 2 | ;; most just `show` to themselves)
 3 | 
 4 | (import type-system)
 5 | (import oo)
 6 | 
 7 | (define (show v)
 8 |   (cond ((or (instance-of? v <symbol>)
 9 |              (instance-of? v <number>)
10 |              (instance-of? v <boolean>)
11 |              (instance-of? v <string>)
12 |              (instance-of? v <char>)
13 |              (instance-of? v <procedure>)
14 |              (eq? v (void)))
15 |          v)
16 |         ((list? v)
17 |          (map show v))
18 |         ((pair? v) ;; catch dotted pairs
19 |          (cons (show (car v)) (show (cdr v))))
20 |         ((vector? v)
21 |          (list->vector (map show (vector->list v))))
22 |         (else
23 |          (show-class-value v))))
24 | 
25 | (define (show-class-value v)
26 |   (let collect ((classes (class-precedence-list (type-of v)))
27 |                 (slots '()))
28 |     (if (null? classes)
29 |         `(,(class-name (type-of v))
30 |           ,@(map (lambda (s) (show-class-slot s v)) slots))
31 |         (collect (cdr classes)
32 |                  (append slots (class-direct-slots (car classes)))))))
33 | 
34 | (define symbol->list (compose string->list symbol->string))
35 | (define list->symbol (compose string->symbol list->string))
36 | (define (string-prepend a b) (string-append b a))
37 | 
38 | (define (show-slot-name s)
39 |   (-> s slot-name symbol->string (string-prepend ":") string->symbol))
40 | 
41 | (define (show-class-slot s v)
42 |   `(,(show-slot-name s) ,(show ((slot-accessor s) v))))
43 | 


--------------------------------------------------------------------------------
/test-exprs.scm:
--------------------------------------------------------------------------------
 1 | ;; Test expressions for run-smoketest.scm
 2 | 
 3 | "built-in in head position, literals"
 4 | (+ 1 1)
 5 | 
 6 | "let form"
 7 | ((lambda (x y) (+ y x)) 1 2)
 8 | 
 9 | "abstraction and application"
10 | ((lambda (f) (f 2 2)) (lambda (x y) (+ x y)))
11 | 
12 | "thunk let"
13 | ((lambda () (+ 1 2)))
14 | 
15 | "thunk application"
16 | ((lambda (f) (f)) (lambda () (+ 2 3)))
17 | 
18 | "dotted let, built-in as value, and apply"
19 | ((lambda (f . args) (apply f args)) + 2 3)
20 | 
21 | "list primitive"
22 | (list 1 2 3)
23 | 
24 | "list and apply"
25 | (apply + (list 3 4))
26 | 
27 | "call/cc"
28 | (+ 4 (call/cc (lambda (k) (k 4))))
29 | 
30 | "nested let with call/cc"
31 | ((lambda (a p b)
32 |    ((lambda (c)
33 |       (p (call/cc c) b))
34 |     (lambda (k) (k a)))) 1 + 2)
35 | 
36 | "set! in fix-let"
37 | ((lambda (a) (set! a 1) a) #f)
38 | 
39 | "set! global variable"
40 | (begin (set! b "foobar") 2)
41 | 
42 | "set! in function"
43 | ((lambda (f) (f #f 1)) (lambda (a b) (set! a b) a))
44 | 


--------------------------------------------------------------------------------