diff --git a/bytecode-compiler.scm b/bytecode-compiler.scm
index 243b99a..6f04632 100644
--- a/bytecode-compiler.scm
+++ b/bytecode-compiler.scm
@@ -1,452 +1,253 @@
 (use-modules (ice-9 match)
-             (srfi srfi-1) 
-             (srfi srfi-9) ;; Record types
-             (srfi srfi-64) ;; Testing framework
-             )
-;; Compiler o'clock!
-
-;; Globals
+             (ice-9 format)
+             (srfi srfi-1)
+             (srfi srfi-2)
+             (srfi srfi-9)
+             (oop goops)
+             ((rnrs base) #:version (6) #:select (assert)))
+
+;; Doing this one from scratch to clean stuff up a bit
+;; Combinators will now use +plus-muffs+
+
+ ;; Misc
+(define (static-error . vals)
+  (apply error vals))
+
 (define undefined-value (make-symbol "undefined"))
-(define leafs '())
-(define compounds '())
 
-;; registers
-(define *env* (make-parameter #f))
-(define *val* (make-parameter #f))
-(define *fun* (make-parameter #f))
-(define *arg1* (make-parameter #f))
-(define *arg2* (make-parameter #f))
-(define *pc* (make-parameter '()))
-;; stack
-(define *stack* (make-vector 100))
-(define *stack-index* (make-parameter 0))
-(define (stack-push v)
-  (vector-set! *stack* (*stack-index*) v)
-  (*stack-index* (1+ (*stack-index*))))
-(define (stack-pop)
-  (*stack-index* (1- (*stack-index*)))
-  (vector-ref *stack* (*stack-index*)))
-;; Leftover bs
-(define sg.init (make-vector 100))
-(define sg.current (make-vector 100))
-(define g.init (make-parameter '()))
-(define g.current (make-parameter '()))
-(define desc.init (make-parameter '()))
-
-;; Macros
-(define-syntax-rule (define-leaf (leaf-name args ...) body ...)
-  (begin (define (leaf-name args ...)
-           (list (lambda () #((name . leaf-name)) body ...)))
-         (set! leafs (cons '(leaf-name (args ...)) leafs))))
-(define-syntax-rule (define-compound (name args ...) body ...)
-  (begin (define (name args ...) body ...)
-         (set! compounds (cons '(name (args ...)) compounds))))
+(define atom? (negate pair?))
 
-(define-syntax with-fresh-globals
-  (syntax-rules ()
-    [(_ expr ...)
-     (parameterize ([g.current '()]
-                    [g.init '()]
-                    [desc.init '()]
-                    [*env* #f]
-                    [*pc* '()]
-                    [*stack-index* 0])
-       expr ...)]))
-(define-syntax define-initial
-  (syntax-rules ()
-    [(_ name value)
-     (vector-set! sg.init (g.init-extend! 'name) value)]))
-(define-syntax define-primitive
-  (syntax-rules ()
-    [(_ name value 0) (define-primitive0 name value)]
-    [(_ name value 1) (define-primitive1 name value)]
-    [(_ name value 2) (define-primitive2 name value)]
-    [(_ name value 3) (define-primitive3 name value)]))
-(define-syntax-rule (define-primitive0 name value)
-  (define-initial name
-    (description-extend! 'name `(function ,value))))
-(define-syntax-rule (define-primitive1 name value)
-  (define-initial name
-    (description-extend! 'name `(function ,value a))))
-(define-syntax-rule (define-primitive2 name value)
-  (define-initial name
-    (description-extend! 'name `(function ,value a b))))
-(define-syntax-rule (define-primitive3 name value)
-  (define-initial name
-    (description-extend! 'name `(function ,value a b c))))
-
-;; Record types
-(define-record-type <activation-record>
-  (make-activation-record next vals)
-  activation-record?
-  (next activation-record-next activation-record-next-set!)
-  (vals activation-record-vals))
-(define-record-type <closure>
-  (make-closure code closed-environment)
-  closure?
-  (code closure-code)
-  (closed-environment closure-closed-environment))
-
-;; Helpers
-(define (local-variable env ref)
-  (let scan-env ([env env] [i 0])
-    (if (null? env)
-        #f
-        (let ([j (list-index (lambda (name) (eq? name ref)) (car env))])
-          (if j
-              `(local ,i . ,j)
-              (scan-env (cdr env) (+ i 1)))))))
+(define finish-pc 0)
 
-(define (global-variable env ref)
-  (assq-ref env ref))
+(define (conjoin . preds)
+  (lambda (x)
+    (any (lambda (pred) (pred x)) preds)))
 
-(define (compute-kind ref r)
-  (or (local-variable r ref)
-      (global-variable (g.current) ref)
-      (global-variable (g.init) ref)))
+ ;; Activation frames
+(define-class <frame> ()
+  (next #:init-value #f #:accessor frame-next)
+  (values #:init-keyword #:values #:accessor frame-values))
 
-(define (global-update! i v)
-  (vector-set! sg.current i v))
+(define-method (write (f <frame>) out)
+  (format out "#<<frame> (next=~s) (args=~s)>" (frame-next f) (frame-values f)))
 
-(define (g.current-extend! ref)
-  (let ([level (length (g.current))])
-    (g.current (cons (cons ref (cons 'global level)) (g.current)))
-    level))
+(define (frame? x)
+  (is-a? x <frame>))
 
-(define (g.init-extend! ref)
-  (let ([level (length (g.init))])
-    (g.init (cons (cons ref (cons 'predefined level)) (g.init)))
-    level))
+(define (allocate-frame size+1)
+  (make <frame> #:values (make-vector size+1)))
 
-(define (static-error . args)
-  (apply error "Static Error:" args))
+(define (frame-ref sr k)
+  (vector-ref (frame-values sr) k))
 
-;; activation records
-(define (make-activation-rec size)
-  (make-activation-record #f (make-vector size)))
+(define (frame-set! sr k v)
+  (vector-set! (frame-values sr) k v))
 
-(define activation-rec-set!
-  (case-lambda
-    [(r k v) (vector-set! (activation-record-vals r) k v)]
-    [(r j k v) (if (zero? j)
-                   (activation-rec-set! r k v)
-                   (activation-rec-set! (activation-rec-next r) (1- j) k v))]))
+(define (frame-extend next frame)
+  (set! (frame-next frame) next)
+  frame)
 
-(define activation-rec-ref
-  (case-lambda
-    [(r i)
-     (vector-ref (activation-record-vals r) i)]
-    [(r i j)
-     (if (zero? i)
-         (activation-rec-ref r j)
-         (activation-rec-ref (activation-rec-next r) (1- i) j))]))
-
-(define (activation-rec-length r)
-  (vector-length (activation-record-vals r)))
-
-(define (activation-rec-next r)
-  (if r
-      (activation-record-next r)
-      (error "Tried to take next of nil record")))
+(define (frame->list frame arity)
+  (take (vector->list (frame-values frame)) arity))
 
 (define (listify! v* arity)
-  (let lp ([index (1- (activation-rec-length v*))]
-           [result '()])
-    (if (= arity index)
-        (activation-rec-set! v* arity result)
-        (lp (1- index) (cons (activation-rec-ref v* (1- index))
-                             result)))))
-;; closures
-(define (invoke f)
-  (cond
-   [(closure? f)
-    (stack-push (*pc*))
-    (*env* (closure-closed-environment f))
-    (*pc* (closure-code f))]
-   [else (error "Tried to invoke a non-closure")]))
+  (let loop ([index 0])
+    (if (= index arity)
+        (frame-ref v* index)
+        (cons (frame-ref v* index) (loop (+ index 1))))))
 
-;; function descriptions
-(define (description-extend! name description)
-  (desc.init (cons (cons name description) (desc.init))))
+ ;; Invoke
+(define-class <closure> ()
+  (code #:init-keyword #:code #:getter closure-code)
+  (closed-env #:init-keyword #:closed-env #:getter closure-closed-env))
 
-(define (get-description name)
-  (let ([p (assq name (desc.init))])
-    (and (pair? p) (cdr p))))
+(define-method (invoke (f <closure>) tail?)
+  (unless tail? (stack-push (*pc*)))
+  (*env* (closure-closed-env f))
+  (*pc* (closure-code f)))
 
-(define desc-args cddr)
+(define-method (write (c <closure>) port)
+  (format port "#<closure (code=~s) (closed-env=~s)>" (closure-code c) (closure-closed-env c)))
 
-(define desc-address cadr)
+(define-class <primitive> ()
+  (name #:init-keyword #:name #:getter primitive-name)
+  (func #:init-keyword #:func #:getter primitive-func)
+  (arity #:init-keyword #:arity #:getter primitive-arity))
 
-(define (list->activation-rec lst)
-  (let lp ([lst lst]
-           [next #f])
-    (if (null? lst)
-        next
-        (lp (cdr lst)
-            (make-activation-record next (list->vector (append (car lst) (list undefined-value))))))))
+(define-method (invoke (f <primitive>) tail?)
+  (let ([func (primitive-func f)]
+        [args (frame->list (*val*) (primitive-arity f))])
+    (*val* (apply func args))))
 
-(define (env-set! lst)
-  (*env* (list->activation-rec lst)))
+(define-method (write (p <primitive>) port)
+  (format port "#<primitive (~s)>" (primitive-name p)))
 
-;; environments
-(define (predefined-fetch i)
-  (vector-ref sg.init i))
+ ;; Virtual machine registers and functions
+(define-syntax define-registers
+  (syntax-rules (null false)
+    [(_ name null more ...)
+     (begin (define name (make-parameter '()))
+            (define-registers more ...))]
+    [(_ name false more ...)
+     (begin (define name (make-parameter #f))
+            (define-registers more ...))]
+    [(_) '()]))
+
+(define-registers
+  *globals*    null
+  *primitives* null
+  *stack*      null
+  *constants*  null
+  *code*       null
+  *env*        false
+  *val*        false
+  *pc*         false
+  *finish-pc*  false
+  *fun*        false
+  *arg1*       false
+  *arg2*       false
+  *exit*       false)
+
+(define (stack-push v)
+  (*stack* (cons v (*stack*))))
+
+(define (stack-pop)
+  (let ([v (car (*stack*))])
+    (*stack* (cdr (*stack*)))
+    v))
+
+(define (deep-fetch env i j)
+  (if (zero? i)
+      (frame-ref env j)
+      (deep-fetch (frame-next env) (- i 1) j)))
+
+(define (deep-update! frame i j v)
+  (if (zero? i)
+      (frame-set! frame j v)
+      (deep-update! (frame-next frame) (- i 1) j v)))
 
 (define (global-fetch i)
-  (vector-ref sg.current i))
+  (list-ref (*globals*) i))
 
-(define (r-extend* r n*)
-  (cons n* r))
+(define (global-update! i v)
+  (list-set! (*globals*) i v))
 
-(define (sr-extend* sr v*)
-  (activation-record-next-set! v* sr)
-  v*)
-
-;; Initial definitions
-(define-initial t #t)
-(define-initial f #f)
-(define-initial nil '())
-(define-primitive cons cons 2)
-(define-primitive car car 1)
-(define-primitive cdr cdr 1)
-(define-primitive + + 2)
-(define-primitive - - 2)
-(define-primitive = = 2)
-(define-primitive < < 2)
-
-;; Combinators
-(define-leaf (CONSTANT v)
-  (*val* v))
+(define (predefined-fetch i)
+  (list-ref (*primitives*) i))
 
-(define-leaf (PUSH-VALUE)
-  (stack-push (*val*)))
+(define-syntax-rule (define-predefined (name func arity) ...)
+  (*primitives*
+   `(,(make <primitive> #:name 'name #:func func #:arity arity) ...)))
 
-(define-leaf (POP-FUNCTION)
-  (*fun* (stack-pop)))
+(define-predefined
+  ;; The first few correspond to direct instructions and should not change
+  (#t (lambda () #t) 0)
+  (#f (lambda () #f) 0)
+  (() (lambda () '()) 0)
+  (cons cons 2)
+  (car car 1)
+  (cdr cdr 1)
+  (pair? pair? 1)
+  (symbol? symbol? 1)
+  (eq? eq? 2)
+  ;; These are not direct instructions, but we act like they are? I'm a little confused
+  (+ + 2)
+  (- - 2)
+  (* * 2)
+  (/ / 2))
 
-(define-leaf (PRESERVE-ENV)
-  (stack-push (*env*)))
-
-(define-leaf (FUNCTION-INVOKE)
-  (invoke (*fun*)))
-
-(define-leaf (RESTORE-ENV)
-  (*env* (stack-pop)))
-
-(define-leaf (RETURN)
-  (*pc* (stack-pop)))
-
-(define-compound (SEQUENCE m m+)
-  (append m m+))
-
-(define-leaf (SHALLOW-ARGUMENT-REF j)
-  (*val* (activation-rec-ref (*env*) j)))
-
-(define-leaf (DEEP-ARGUMENT-REF i j)
-  (*val* (activation-rec-ref (*env*) i j)))
-
-(define-leaf (PREDEFINED i)
-  (*val* (predefined-fetch i)))
-
-(define-leaf (GLOBAL-REF i)
-  (*val* (global-fetch i)))
-
-(define-leaf (CHECKED-GLOBAL-REF i)
-  (let ([v (global-fetch i)])
-    (if (eq? v undefined-value)
-        (error "Uninitialized variable")
-        (*val* v))))
-
-(define-leaf (JUMP-FALSE i)
-  (when (not (*val*))
-    (*pc* (list-tail (*pc*) i))))
-
-(define-leaf (GOTO i)
-  (*pc* (list-tail (*pc*) i)))
-
-(define-compound (ALTERNATIVE m1 m2 m3)
-  (append m1 (JUMP-FALSE (1+ (length m2))) m2 (GOTO (length m3)) m3))
-
-(define-compound (STORE-ARGUMENT m m* rank)
-  (append m (PUSH-VALUE) m* (POP-FRAME! rank)))
-
-(define-compound (CONS-ARGUMENT m m* arity)
-  (append m (PUSH-VALUE) m* (POP-CONS-FRAME! arity)))
-
-(define-leaf (POP-FRAME! rank)
-  (activation-rec-set! (*val*) rank (stack-pop)))
-
-(define-leaf (POP-CONS-FRAME! arity)
-  (activation-rec-set!
-   (*val*) arity
-   (cons (stack-pop) (activation-rec-ref (*val*) arity))))
-
-(define-leaf (ALLOCATE-FRAME size)
-  (*val* (make-activation-rec (1+ size))))
-
-(define-leaf (ALLOCATE-DOTTED-FRAME size)
-  (let ([rec (make-activation-rec (1+ size))])
-    (activation-rec-set! rec size '())
-    (*val* rec)))
-
-(define-compound (REGULAR-CALL m m+)
-  (append
-   m
-   (PUSH-VALUE)
-   m+
-   (POP-FUNCTION)
-   (PRESERVE-ENV)
-   (FUNCTION-INVOKE)
-   (RESTORE-ENV)))
-
-(define-compound (TR-REGULAR-CALL m m*)
-  (append
-   m
-   (PUSH-VALUE)
-   m*
-   (POP-FUNCTION)
-   (FUNCTION-INVOKE)))
-
-(define-compound (CALL0 address)
-  (INVOKE0 address))
-
-(define-compound (CALL1 address m1)
-  (append m1 (INVOKE1 address)))
-
-(define-compound (CALL2 address m1 m2)
-  (append m1 (PUSH-VALUE) m2 (POP-ARG1) (INVOKE2 address)))
-
-(define-compound (CALL3 address m1 m2 m3)
-  (append m1 (PUSH-VALUE) m2 (PUSH-VALUE) m3 (POP-ARG2) (POP-ARG1) (INVOKE3 address)))
-
-;; Predefined invokers, will eventually be specialized
-
-(define-leaf (INVOKE0 address)
-  (*val* (address)))
-
-(define-leaf (INVOKE1 address)
-  (*val* (address (*val*))))
-
-(define-leaf (INVOKE2 address)
-  (*val* (address (*val*) (*arg1*))))
-
-(define-leaf (INVOKE3 address)
-  (*val* (address (*val*) (*arg1*) (*arg2*))))
-
-(define-leaf (POP-ARG1)
-  (*arg1* (stack-pop)))
-
-(define-leaf (POP-ARG2)
-  (*arg2* (stack-pop)))
-
-(define-compound (FIX-LET m* m+)
-  (append m* (EXTEND-ENV) m+ (UNLINK-ENV)))
-
-(define-compound (TR-FIX-LET m* m+)
-  (append m* (EXTEND-ENV) m+))
-
-(define-leaf (EXTEND-ENV)
-  (*env* (sr-extend* (*env*) (*val*))))
-
-(define-leaf (UNLINK-ENV)
-  (*env* (activation-rec-next (*env*))))
-
-(define-compound (SHALLOW-ARGUMENT-SET! j m)
-  (append m (SET-SHALLOW-ARGUMENT! j)))
-
-(define-leaf (SET-SHALLOW-ARGUMENT! j)
-  (activation-rec-set! (*env*) j (*val*)))
-
-(define-leaf (DEEP-ARGUMENT-SET! i j m)
-  (activation-rec-set! (*env*) i j (m)))
-
-(define-compound (GLOBAL-SET! i m)
-  (append m (SET-GLOBAL! i)))
-
-(define-leaf (SET-GLOBAL! i)
-  (global-update! i (*val*)))
-
-(define-leaf (CREATE-CLOSURE offset)
-  (*val* (make-closure (list-tail (*pc*) offset) (*env*))))
-
-(define-leaf (PACK-FRAME! arity)
-  (listify! (*val*) arity))
-
-(define-leaf (ARITY>=? arity)
-  (unless (>= (activation-rec-length (*val*)) arity)
-    (error "Incorrect arity for nary function")))
-
-(define-leaf (ARITY=? arity)
-  (unless (= (activation-rec-length (*val*)) arity)
-    (error "Incorrect arity for fix function")))
-
-(define-compound (FIX-CLOSURE m+ arity)
-  (define the-function
-    (append (ARITY=? (1+ arity)) (EXTEND-ENV) m+ (RETURN)))
-  (append (CREATE-CLOSURE 1) (GOTO (length the-function)) the-function))
-
-(define-compound (NARY-CLOSURE m+ arity)
-  (define the-function
-    (append (ARITY>=? (1+ arity)) (PACK-FRAME! arity) (EXTEND-ENV) m+ (RETURN)))
-  (append (CREATE-CLOSURE 1) (GOTO (length the-function)) the-function))
-
-(define-leaf (FINISH)
-  (*pc* '()))
-
-;; Denotations
+(define init-env #f)
+ ;; Denotations
 (define (meaning e r tail?)
-  "Core of the denotation. `tail?' allows us to avoid capturing the local environment if we know we will not return"
   (match e
-    [(? (negate pair?))
-     (if (symbol? e)      (meaning-reference e r)
-         (meaning-quotation e))]
-    [('quote e* ...)      (meaning-quotation (car e*))]
-    [('lambda v* e* ...)  (meaning-abstraction v* e* r)]
-    [('if e1 e2 e3)       (meaning-alternative e1 e2 e3 r tail?)]
-    [('begin e* ...)      (meaning-sequence e* r tail?)]
-    [('set! n e)          (meaning-assignment n e r)]
-    [(f v* ...)           (meaning-application f v* r tail?)]))
+    [(? symbol?) (meaning-reference e r)]
+    [(? atom?)   (meaning-quotation e)]
+    [('quote e* ...) (meaning-quotation (car e*))]
+    [('lambda v* e* ...) (meaning-abstraction v* e* r)]
+    [('if e1 e2 e3) (meaning-alternative e1 e2 e3 r tail?)]
+    [('begin e* ...) (meaning-sequence e* r tail?)]
+    [('set! n e) (meaning-assignment n e r)]
+    [(f e* ...) (meaning-application f e* r tail?)]))
 
-(define (meaning-quotation e*)
-  (CONSTANT e*))
+(define (meaning-quotation e)
+  (+constant+ e))
+
+(define (meaning-sequence e* r tail?)
+  (if (null? (cdr e*))
+      (meaning (car e*) r tail?)
+      (+sequence+ (meaning (car e*) r #f)
+                  (meaning-sequence (car e*) r tail?))))
 
 (define (meaning-alternative e1 e2 e3 r tail?)
-  (let ([m1 (meaning e1 r #f)]
-        [m2 (meaning e2 r tail?)]
-        [m3 (meaning e3 r tail?)])
-    (ALTERNATIVE m1 m2 m3)))
-
-(define (meaning-sequence e+ r tail?)
-  (cond
-   [(null? e+) (static-error "Illegal syntax (begin)")]
-   [(null? (cdr e+)) (meaning (car e+) r tail?)]
-   [else (SEQUENCE (meaning (car e+) r #f)
-                   (meaning-sequence (cdr e+) r tail?))]))
+  (+alternative+ (meaning e1 r #f)
+                 (meaning e2 r tail?)
+                 (meaning e3 r tail?)))
 
 (define (meaning-reference n r)
-  (match (compute-kind n r)
-    [('local . (i . j))
-     (if (= i 0)
-         (SHALLOW-ARGUMENT-REF j)
-         (DEEP-ARGUMENT-REF i j))]
-    [('global . i)
-     (CHECKED-GLOBAL-REF i)]
-    [('predefined . i)
-     (PREDEFINED i)]
-    [_ (static-error "No such variable" n)]))
+  (match (lookup-reference n r)
+    [('local 0 j) (emit-shallow-argument-ref j)]
+    [('local i j) (emit-deep-argument-ref i j)]
+    [('global i) (emit-checked-global-ref i)]
+    [('predefined i) (+predefined+ i)]
+    [_ (static-error "Undefined reference" n)]))
+
+(define (meaning-assignment n e r)
+  (let ([m (meaning e r #f)])
+    (match (lookup-reference n r)
+      [('local 0 j) (+shallow-argument-set!+ j m)]
+      [('local i j) (+deep-argument-set!+ i j m)]
+      [('global i) (+global-set!+ i m)]
+      [_ (static-error "Cannot set reference" n)])))
+
+(define (meaning-abstraction v* e+ r)
+  (call-with-values (lambda () (partition-args v*))
+    (lambda (fixed-args dotted-args)
+      (if dotted-args
+        (meaning-dotted-abstraction fixed-args dotted-args e+ r)
+        (meaning-fixed-abstraction fixed-args e+ r)))))
+
+(define (meaning-fixed-abstraction v* e+ r)
+  (let* ([arity (length v*)]
+         [r2 (r-extend* r v*)]
+         [m+ (meaning-sequence e+ r2 #t)])
+    (+fix-closure+ m+ arity)))
+
+(define (meaning-dotted-abstraction fixed-args dotted-args e+ r)
+  (let* ([arity (length fixed-args)]
+         [r2 (r-extend* r (append fixed-args dotted-args))]
+         [m+ (meaning-sequence e+ r2 #t)])
+    (+nary-closure+ m+ arity)))
 
 (define (meaning-application f e* r tail?)
-  (cond
-   [(and (symbol? f)
-         (get-description f)
-         (compute-kind f r)) =>
-         (lambda (kind)
-           (if (eq? (car kind) 'predefined)
-               (meaning-primitive-application f e* r)
-               (meaning-regular-application f e* r tail?)))]
-   [(and (pair? f) (eq? (car f) 'lambda))
-    (meaning-closed-application f e* r tail?)]
-   [else (meaning-regular-application f e* r tail?)]))
+  (match f
+    [('lambda v* body ...)
+     (meaning-closed-application v* body e* r tail?)]
+    [_
+     (meaning-regular-application f e* r tail?)]))
+
+(define (meaning-closed-application v* body e* r tail?)
+  (call-with-values (lambda () (partition-args v*))
+    (lambda (fixed-args dotted-args)
+      (if dotted-args
+          (meaning-dotted-closed-application fixed-args dotted-args body e* r tail?)
+          (meaning-fix-closed-application fixed-args body e* r tail?)))))
+
+(define (meaning-regular-application f e* r tail?)
+  (let ([mf (meaning f r #f)]
+        [m* (meaning* e* r)])
+    ((if tail? +tr-regular-call+ +regular-call+) mf m*)))
+
+(define (meaning-fix-closed-application v* body e* r tail?)
+  (let* ([m* (meaning* e* r)]
+         [r2 (r-extend* r v*)]
+         [mb (meaning-sequence body r2 tail?)])
+    ((if tail? +tr-fix-let+ +fix-let+) m* mb)))
+
+(define (meaning-dotted-closed-application fixed-args dotted-args body e* r tail?)
+  (let* ([m* (meaning*-dotted e* r (length fixed-args))]
+         [r2 (r-extend* r (append fixed-args dotted-args))]
+         [mb (meaning-sequence body r2 tail?)])
+    ((if tail? +tr-fix-let+ +fix-let+) m* mb)))
 
 (define (meaning-list e* r tail?)
   (cond
@@ -458,230 +259,357 @@
   (let lp ([rank 0]
            [m* (meaning-list e* r #f)])
     (if (pair? m*)
-        (STORE-ARGUMENT (car m*) (lp (1+ rank) (cdr m*)) rank)
-        (ALLOCATE-FRAME (length e*)))))
+        (+store-argument+ (car m*) (lp (1+ rank) (cdr m*)) rank)
+        (+allocate-frame+ (+ (length e*) 1)))))
 
 (define (meaning*-dotted e* r fixed-size)
   (let lp ([rank 0]
            [m* (meaning-list e* r #f)])
     (cond
-     [(null? m*) (ALLOCATE-DOTTED-FRAME fixed-size)]
-     [(> fixed-size rank) (STORE-ARGUMENT (car m*) (lp (1+ rank) (cdr m*)) rank)]
-     [else (CONS-ARGUMENT (car m*) (lp (1+ rank) (cdr m*)) fixed-size)])))
+     [(null? m*) (+allocate-dotted-frame+ (+ fixed-size 1))]
+     [(> fixed-size rank) (+store-argument+ (car m*) (lp (1+ rank) (cdr m*)) rank)]
+     [else (+cons-argument+ (car m*) (lp (1+ rank) (cdr m*)) fixed-size)])))
 
-(define (meaning-regular-application f e* r tail?)
-  (let [(mf (meaning f r #f))
-        (m* (meaning* e* r))]
-    ((if tail? TR-REGULAR-CALL REGULAR-CALL) mf m*))) ;; hehe new trick
+(define (lookup-reference n r)
+  (cond
+   [(lookup-global (*primitives*) n) =>
+    (lambda (i)   `(predefined ,i))]
+   [(lookup-local r n) (lambda (i j) (and i j)) =>
+    (lambda (i j) `(local ,i ,j))]
+   [(lookup-global (*globals*) n) =>
+    (lambda (i)   `(global ,i))]
+   [else #f]))
 
-(define (meaning-primitive-application f e* r)
-  (let* ([desc (get-description f)]
-         [address (desc-address desc)]
-         [arity (length e*)])
-    (if (= (length (desc-args desc)) arity)
-        (case arity
-          [(0) (CALL0 address)]
-          [(1) (let ([m1 (meaning (first e*) r #f)])
-                 (CALL1 address m1))]
-          [(2) (let ([m1 (meaning (first e*)  r #f)]
-                     [m2 (meaning (second e*) r #f)])
-                 (CALL2 address m1 m2))]
-          [(3) (let ([m1 (meaning (first e*)  r #f)]
-                     [m2 (meaning (second e*) r #f)]
-                     [m3 (meaning (third e*)  r #f)])
-                 (CALL3 address m1 m2 m3))])
-        (static-error "Wrong arity for" f arity))))
+(define* (lookup-local r n #:optional (i 0))
+  (cond
+   [(null? r) (values #f #f)]
+   [(list-index (lambda (n1) (eq? n n1)) (car r)) =>
+    (lambda (j) (values i j))]
+   [else (lookup-local (cdr r) n (+ 1 i))]))
 
-(define (meaning-closed-application e ee* r tail?)
-  (let lp ([n* (second e)]
-           [e* ee*]
+(define (lookup-global tbl n)
+  (list-index (lambda (f) (equal? n (primitive-name f))) tbl))
+
+(define (partition-args v*)
+  (let lp ([v* v*]
            [fixargs '()])
     (cond
-     [(pair? n*)
-      (if (pair? e*)
-          (lp (cdr n*) (cdr e*) (cons (car n*) fixargs))
-          (static-error "Not enough arguments" e ee*))]
-     [(null? n*)
-      (if (pair? e*)
-          (static-error "Too many arguments" e ee*)
-          (meaning-fixed-closed-application (second e) (drop e 2) ee* r tail?))]
-     [else
-      (meaning-dotted-closed-application (reverse fixargs) n* (drop e 2) ee* r tail?)])))
+     [(null? v*) (values (reverse fixargs) #f)]
+     [(pair? v*) (lp (cdr v*) (cons (car v*) fixargs))]
+     [else (values (reverse fixargs) (list v*))])))
 
-(define (meaning-fixed-closed-application n* body e* r tail?)
-  (let* [(m* (meaning* e* r))
-         (r2 (r-extend* r n*))
-         (m+ (meaning-sequence body r2 tail?))]
-    ((if tail? TR-FIX-LET FIX-LET) m* m+)))
+(define (r-extend* r vals)
+  (cons vals r))
 
-(define (meaning-dotted-closed-application n* n body e* r tail?)
-  (let* ([m* (meaning*-dotted e* r (length n*))]
-         [r2 (r-extend* r (append n* (list n)))]
-         [m+ (meaning-sequence body r2 tail?)])
-    ((if tail? TR-FIX-LET FIX-LET) m* m+)))
+(define (signal-exception continuable? exceptions)
+  ;; TODO fix this
+  (apply error exceptions))
 
-(define (meaning-assignment n e r)
-  (let ([m (meaning e r #f)])
-    (match (compute-kind n r)
-      [('local . (i . j))
-       (if (zero? i)
-           (SHALLOW-ARGUMENT-SET! j m)
-           (DEEP-ARGUMENT-SET! i j m))]
-      [('global . i)
-       (GLOBAL-SET! i m)]
-      [('predefined _ ...)
-       (static-error "Cannot set predefined variable" n)]
-      [_ (static-error "Cannot set! undefined variable" n)])))
+ ;; Code generators
+(define (+constant+ v)
+  (emit-constant v))
 
-(define (meaning-abstraction nn* body r)
-  (let lp ([n* nn*]
-           [fixargs '()])
-    (cond
-     [(pair? n*) (lp (cdr n*) (cons (car n*) fixargs))]
-     [(null? n*) (meaning-fixed-abstraction nn* body r)]
-     [else (meaning-dotted-abstraction (reverse fixargs) n* body r)])))
+(define (+sequence+ m m+)
+  (append m m+))
 
-(define (meaning-fixed-abstraction n* body r)
-  (let* ([arity (length n*)]
-         [r2 (r-extend* r n*)]
-         [m+ (meaning-sequence body r2 #t)])
-    (FIX-CLOSURE m+ arity)))
+(define (+alternative+ m1 m2 m3)
+  (append m1 (+jump-false+ (1+ (length m2))) m2 (+goto+ (1+ (length m3))) m3))
+
+(define (+shallow-argument-set!+ i m)
+  (append m (emit-shallow-argument-set! i)))
+
+(define (+deep-argument-set!+ i j m)
+  (append m (emit-deep-argument-set! i j)))
+
+(define (+global-set!+ i m)
+  (append m (emit-global-set! i)))
+
+(define (+predefined+ i)
+  (if (<= i 0 8)
+      (emit-code (+ 10 i))
+      (emit-predefined i)))
+
+(define (+regular-call+ m m*)
+  (append m (emit-push-value)
+          m* (emit-pop-function)
+          (emit-preserve-env) (emit-function-invoke) (emit-restore-env)))
+
+(define (+tr-regular-call+ m m*)
+  (append m (emit-push-value)
+          m* (emit-pop-function)
+          (emit-function-invoke)))
+
+(define (+fix-closure+ m+ arity)
+  (define the-function
+    (append (emit-arity=? (+ arity 1)) (emit-extend-env) m+ (emit-return)))
+  (append (emit-create-closure 2) (+goto+ (length the-function)) the-function))
+
+(define (+nary-closure+ m+ arity)
+  (define the-function
+    (append (emit-arity>=? (+ arity)) (emit-pack-frame arity) (emit-extend-env) m+ (emit-return)))
+  (append (emit-create-closure 2) (+goto+ (length the-function)) the-function))
+
+(define (+goto+ offset)
+  (cond
+   [(< offset 255) (emit-short-goto offset)]
+   [(< offset (+ 255 (* 255 256))) ;; ???
+    (call-with-values (lambda () (truncate/ offset 256)) emit-long-goto)]
+   [else (static-error "Goto is too long" offset)]))
+
+(define (+jump-false+ offset)
+  (cond
+   [(< offset 255) (emit-short-jump-false offset)]
+   [(< offset (+ 255 (* 255 256))) ;; ???
+    (call-with-values (lambda () (truncate/ offset 256)) emit-long-jump-false)]
+   [else (static-error "jump-false is too long" offset)]))
+
+(define (+store-argument+ m m* rank)
+  (append m (emit-push-value) m* (emit-pop-frame rank)))
+
+(define (+cons-argument+ m m* arity)
+  (append m (emit-push-value) m* (emit-pop-cons-frame arity)))
+
+(define (+allocate-frame+ size)
+  (emit-allocate-frame size))
+
+(define (+allocate-dotted-frame+ size)
+  (emit-allocate-dotted-frame size))
+
+(define (+fix-let+ m* m+)
+  (append m* (emit-extend-env) m+ (emit-unlink-env)))
+
+(define (+tr-fix-let+ m* m+)
+  (append m* (emit-extend-env) m+))
+
+ ;; Instructions
+;; A somewhat contrived way to define a virtual machine and its instruction set
+;; at the same time (the book does it so we must!)
+(define-class <inst> ()
+  (name #:init-keyword #:name #:getter inst-name)
+  (impl #:init-keyword #:impl #:getter inst-impl)
+  (args #:init-keyword #:args #:getter inst-args))
+
+(define-method (write (inst <inst>) port)
+  (format port "~25a ~s" (inst-name inst) (inst-args inst)))
+
+(define instruction-lookup (make-hash-table))
+
+(define (instruction-ref code)
+  (let ([res (hashq-ref instruction-lookup code)])
+    (unless res
+      (error "Cannot find instruction" code))
+    res))
+
+(define (instruction-set! code inst)
+  (hashq-set! instruction-lookup code inst))
+
+(define* (emit-code code . args)
+  (cons code args))
+
+(define-syntax define-inst
+  (lambda (ctx)
+    (define (syntax-prefix syntax prefix)
+      (datum->syntax ctx (symbol-append prefix (syntax->datum syntax))))
+    (syntax-case ctx ()
+      [(_ (name code args ...) body ...)
+       (with-syntax ([run-inst  (syntax-prefix #'name 'run-)]
+                     [emit-inst (syntax-prefix #'name 'emit-)])
+         #'(begin
+             (define (run-inst args ...) body ...)
+             (define (emit-inst args ...) (emit-code code args ...))
+             (let ([inst (make <inst>
+                           #:name 'name
+                           #:impl run-inst
+                           #:args '(args ...))])
+               (instruction-set! code inst)
+               (format #t "Defined instruction ~2@a: ~s\n" code inst))
+))])))
+
+(define-inst (shallow-argument-ref 5 j)
+  (*val* (frame-ref (*env*) j)))
+
+(define-inst (deep-argument-ref 6 i j)
+  (*val* (deep-fetch (*env*) i j)))
+
+(define-inst (global-ref 7 i)
+  (*val* (global-fetch i)))
+
+(define-inst (checked-global-ref 8 i)
+  (*val* (global-fetch i))
+  (when (eq? (*val*) undefined-value)
+    (signal-exception #t (list "Uninitialized global variable" i))))
+
+(define-inst (predefined0 10)
+  (*val* #t))
+
+(define-inst (predefined1 11)
+  (*val* #f))
+
+(define-inst (predefined2 12)
+  (*val* '()))
+
+(define-inst (predefined3 13)
+  (*val* cons))
+
+(define-inst (predefined4 14)
+  (*val* car))
+
+(define-inst (predefined5 15)
+  (*val* cdr))
+
+(define-inst (predefined6 16)
+  (*val* pair?))
+
+(define-inst (predefined7 17)
+  (*val* symbol?))
+
+(define-inst (predefined8 18)
+  (*val* eq?))
+
+(define-inst (predefined 19 i)
+  (*val* (predefined-fetch i)))
+
+(define-inst (finish 20)
+  ((*exit*) (*val*)))
+
+(define-inst (shallow-argument-set! 25 j)
+  (frame-set! (*env*) j (*val*)))
+
+(define-inst (deep-argument-set! 26 i j)
+  (deep-update! *env* i j (*val*)))
+
+(define-inst (global-set! 27 i)
+  (global-update! i (*val*)))
+
+(define-inst (long-goto 28 offset1 offset2)
+  (*pc* (+ (*pc*) (+ offset1 (* offset2 256)))))
+
+(define-inst (long-jump-false 29 offset1 offset2)
+  (when (not (*val*))
+    (*pc* (+ (*pc*) (+ offset1 (* offset2 256))))))
+
+(define-inst (short-goto 30 offset)
+  (*pc* (+ (*pc*) offset)))
+
+(define-inst (short-jump-false 31 offset)
+  (when (not (*val*))
+    (*pc* (+ (*pc*) offset))))
+
+(define-inst (extend-env 32)
+  (*env* (frame-extend (*env*) (*val*))))
+
+(define-inst (unlink-env 33)
+  (*env* (frame-next (*env*))))
+
+(define-inst (push-value 34)
+  (stack-push (*val*)))
+
+(define-inst (preserve-env 37)
+  (assert ((conjoin frame? boolean?) (*env*)))
+  (stack-push (*env*)))
+
+(define-inst (restore-env 38)
+  (*env* (stack-pop))
+  (assert ((conjoin frame? boolean?) (*env*))))
+
+(define-inst (pop-function 39)
+  (*fun* (stack-pop)))
+
+(define-inst (create-closure 40 offset)
+  (*val* (make <closure> #:code (+ (*pc*) offset) #:closed-env (*env*))))
+
+(define-inst (pack-frame 41 arity)
+  (listify! (*val*) arity))
+
+(define-inst (return 43)
+  (*pc* (stack-pop)))
+
+(define-inst (function-invoke 45)
+  (invoke (*fun*) #f))
+
+(define-inst (function-goto 46)
+  (invoke (*fun*) #t))
+
+(define-inst (allocate-frame 55 size+1)
+  (*val* (allocate-frame size+1)))
+
+(define-inst (allocate-dotted-frame 56 size+1)
+  (*val* (allocate-frame size+1)))
+
+(define-inst (pop-frame 64 rank)
+  (assert (frame? (*val*)))
+  (frame-set! (*val*) rank (stack-pop)))
+
+(define-inst (pop-cons-frame 65 arity)
+  (frame-set! (*val*) arity (stack-pop)))
+
+(define-inst (arity=? 75 arity+1)
+  (unless (= (vector-length (frame-values (*val*))) arity+1)
+    (signal-exception #f (list "Incorrect arity"))))
+
+(define-inst (arity>=? 76 arity+1)
+  (unless (>= (vector-length (frame-values (*val*))) arity+1)
+    (signal-exception #f (list "Incorrect arity"))))
+
+(define-inst (constant 79 value)
+  (*val* value))
+
+ ;; VM operation
+(define (run-machine stack-size pc code constants global-names)
+  (parameterize ([*constants* constants]
+                 [*code* code]
+                 [*env* init-env]
+                 [*stack* '()]
+                 [*pc* pc]
+                 [*fun* #f])
+    (stack-push (*finish-pc*))
+    (call/cc (lambda (exit)
+               (*exit* exit)
+               (run)
+               (*val*)))))
+
+(define (producer e)
+  (let* ([m (meaning e '() #t)]
+         [code (make-code-segment m)]
+         [start-pc (length (code-prologue))])
+    (lambda (stack-size)
+      (run-machine stack-size start-pc code '() '()))))
+
+(define (make-code-segment m)
+  (apply vector (append (code-prologue) m (emit-return))))
+
+(define (code-prologue)
+  (*finish-pc* 0)
+  (emit-finish))
 
-(define (meaning-dotted-abstraction n* n body r)
-  (let* ([arity (length n*)]
-         [r2 (r-extend* r (append n* (list n)))]
-         [m+ (meaning-sequence body r2 #t)])
-    (NARY-CLOSURE m+ arity)))
-
-;; VM Runner
 (define (run)
-  (let ([instruction (car (*pc*))])
-    (*pc* (cdr (*pc*)))
-    (instruction)
-    (if (pair? (*pc*))
-        (run)
-        (format #f "Execution terminated with *val* = ~a\n" (*val*)))))
-
-;; Reporting
-(letrec ([combinator-name (compose symbol->string car)]
-         [sort-combinators
-          (lambda (combinators)
-            (sort combinators (lambda (a b)
-                                (string< (combinator-name a) (combinator-name b)))))]
-         [n-leafs (length leafs)]
-         [n-compounds (length compounds)])
-  (format #t "Defined ~a combinators; ~a leaves and ~a compound instructions\n" (+ n-leafs n-compounds) n-leafs n-compounds)
-  (format #t "Leaves:\n")
-  (for-each (lambda (c) (format #t " (~a ~a)\n" (first c) (second c)))
-            (sort-combinators leafs))
-    (format #t "Compounds:\n")
-  (for-each (lambda (c) (format #t " (~a ~a)\n" (first c) (second c)))
-            (sort-combinators compounds)))
-
-;; Tests
-(define (run-test prgm)
-  (*pc* prgm)
-  (let lp ()
-    (define instruction (car (*pc*)))
-    (*pc* (cdr (*pc*)))
-    (instruction)
-    (if (null? (*pc*))
-        (*val*)
-        (lp))))
+  (define (fetch-byte)
+    (vector-ref (*code*) (*pc* (+ 1 (*pc*)))))
+  (define (fetch-args n)
+    (if (zero? n)
+        '()
+        (let ([arg (fetch-byte)])
+          (cons arg (fetch-args (- n 1))))))
+  (let loop ([op (fetch-byte)])
+    (let* ([inst (instruction-ref op)]
+           [size (length (inst-args inst))]
+           [args (fetch-args size)])
+      (apply (inst-impl inst) args))
+    (loop (fetch-byte))))
 
-(test-begin "bytecode-compiler")
-;; quotation
-(test-group "meaning-quotation"
-  (with-fresh-globals
-   (test-eq 'apple
-     (run-test (meaning-quotation 'apple)))
-   (test-eq '(apple pear)
-     (run-test (meaning-quotation '(apple pear))))))
-;; alternatives
-(test-group "meaning-alternative"
-  (with-fresh-globals
-   (env-set! '((#t apple pear)))
-   (test-eq 'apple
-     (run-test (meaning-alternative 'p 't 'f '((p t f)) #t)))
-   (env-set! '((#f apple pear)))
-   (test-eq 'pear
-     (run-test (meaning-alternative 'p 't 'f '((p t f)) #t)))))
-  ;; sequences
-(test-group "meaning-sequence"
-  (with-fresh-globals
-   (env-set! '((1 2)))
-   (test-eq 2
-     (run-test (meaning-sequence '(a b) '((a b)) #t)))))
-;; references
-(test-group "meaning-reference"
-  (with-fresh-globals
-   (g.current-extend! 'a)
-   (vector-set! sg.current 0 10)
-   (g.init-extend! 'b)
-   (vector-set! sg.init 0 20)
-   (env-set! '((0 1)))
-   (test-eq 1
-     (run-test (meaning-reference 'b '((a b)))))
-   (env-set! '((0 1) (2)))
-   (test-eq 0
-     (run-test (meaning-reference 'b '((a) (b c)))))
-   (test-equal 10
-     (run-test (meaning-reference 'a '())))
-   (test-equal 20
-     (run-test (meaning-reference 'b '())))))
-;; applications
-(test-group "meaning-application"
-  (with-fresh-globals
-   (desc.init `((+ function ,+ . (x y))))
-   (define *-abstraction
-     (run-test (FIX-CLOSURE
-                (list (lambda ()
-                        (*val*
-                         (* (activation-rec-ref (*env*) 0)
-                            (activation-rec-ref (*env*) 1)))))
-       2)))
-   (env-set! `((,*-abstraction)))
-   (test-eq 9
-     (run-test (meaning-regular-application '* '(3 3) '((*)) #t)))
-   (test-eq 2
-     (run-test (meaning-primitive-application '+ '(1 1) '(()))))
-   (test-eq 2 (run-test (meaning-closed-application '(lambda (x) x) '(2) '(()) #t)))
-   (test-equal '(2 3) (run-test (meaning-closed-application '(lambda (x . y) y) '(1 2 3) '(()) #t)))))
-;; assignment
-(test-group "meaning-assignment"
-  (with-fresh-globals
-   (*env* (list->activation-rec '((1))))
-  (run-test (meaning-assignment 'apples 2 '((apples))))
-   (test-eq 2                                
-     (activation-rec-ref (*env*) 0 0))))
-;; abstraction
-(test-group "meaning-abstraction"
-  (define test-code (append
-                     (PUSH-VALUE)
-                     (CONSTANT 1)
-                     (PUSH-VALUE)
-                     (CONSTANT 2)
-                     (PUSH-VALUE)
-                     (ALLOCATE-FRAME 2)
-                     (POP-FRAME! 1)
-                     (POP-FRAME! 0)
-                     (POP-FUNCTION)
-                     (FUNCTION-INVOKE)))
-  (with-fresh-globals
-   (test-assert (closure? (run-test (meaning-abstraction '(x) '(x) '(())))))
-   (test-eq 2
-     (run-test (append (meaning-abstraction '(x y) '(y) '(())) test-code)))
-   (test-equal '(2)
-     (run-test (append (meaning-abstraction '(x . y) '(y) '(())) test-code)))))
-;; (test-group "call/cc"
-;;   (test-eq 3 ((meaning '(+ 2 (call/cc (lambda (cc) (cc 1) 2))) '(()) #t)))
-;;   (test-eq 5 ((meaning '((lambda (cont v)
-;;                            (set! v (+ 2 (call/cc (lambda (cc) (set! cont cc) 1))))
-;;                            (if (= v 3)
-;;                                (cont v)
-;;                                v)) #f 0)
-;;                        '(()) #t))))
-;; (test-group "apply"
-;;   (test-eq 3 ((meaning '(apply + 1 2 '()) '(()) #t)))
-;;   (test-eq 3 ((meaning '(apply + '(1 2)) '(()) #t))))
-(test-end "bytecode-compiler")
+(define (run-prgm prgm)
+  ((producer prgm) 100))
+
+(define (disassemble code)
+  (let lp ([i 0]
+           [lst (vector->list code)])
+    (let ([inst (instruction-ref (car lst))])
+      (format #t "~2@s: ~25a (" i (inst-name inst))
+      (for-each (lambda (arg)
+                  (format #t "(~a = ~a)" arg (cadr lst))
+                  (set-cdr! lst (cddr lst))
+                  (set! i (+ 1 i)))
+                (inst-args inst))
+      (format #t ")\n"))
+    (when (pair? (cdr lst))
+      (lp (+ 1 i) (cdr lst)))))
diff --git a/linear-thunk-interpreter.scm b/linear-thunk-interpreter.scm
new file mode 100644
index 0000000..6e9ae33
--- /dev/null
+++ b/linear-thunk-interpreter.scm
@@ -0,0 +1,687 @@
+(use-modules (ice-9 match)
+             (srfi srfi-1) 
+             (srfi srfi-9) ;; Record types
+             (srfi srfi-64) ;; Testing framework
+             )
+;; Compiler o'clock!
+
+;; Globals
+(define undefined-value (make-symbol "undefined"))
+(define leafs '())
+(define compounds '())
+
+;; registers
+(define *env* (make-parameter #f))
+(define *val* (make-parameter #f))
+(define *fun* (make-parameter #f))
+(define *arg1* (make-parameter #f))
+(define *arg2* (make-parameter #f))
+(define *pc* (make-parameter '()))
+;; stack
+(define *stack* (make-vector 100))
+(define *stack-index* (make-parameter 0))
+(define (stack-push v)
+  (vector-set! *stack* (*stack-index*) v)
+  (*stack-index* (1+ (*stack-index*))))
+(define (stack-pop)
+  (*stack-index* (1- (*stack-index*)))
+  (vector-ref *stack* (*stack-index*)))
+;; Leftover bs
+(define sg.init (make-vector 100))
+(define sg.current (make-vector 100))
+(define g.init (make-parameter '()))
+(define g.current (make-parameter '()))
+(define desc.init (make-parameter '()))
+
+;; Macros
+(define-syntax-rule (define-leaf (leaf-name args ...) body ...)
+  (begin (define (leaf-name args ...)
+           (list (lambda () #((name . leaf-name)) body ...)))
+         (set! leafs (cons '(leaf-name (args ...)) leafs))))
+(define-syntax-rule (define-compound (name args ...) body ...)
+  (begin (define (name args ...) body ...)
+         (set! compounds (cons '(name (args ...)) compounds))))
+
+(define-syntax with-fresh-globals
+  (syntax-rules ()
+    [(_ expr ...)
+     (parameterize ([g.current '()]
+                    [g.init '()]
+                    [desc.init '()]
+                    [*env* #f]
+                    [*pc* '()]
+                    [*stack-index* 0])
+       expr ...)]))
+(define-syntax define-initial
+  (syntax-rules ()
+    [(_ name value)
+     (vector-set! sg.init (g.init-extend! 'name) value)]))
+(define-syntax define-primitive
+  (syntax-rules ()
+    [(_ name value 0) (define-primitive0 name value)]
+    [(_ name value 1) (define-primitive1 name value)]
+    [(_ name value 2) (define-primitive2 name value)]
+    [(_ name value 3) (define-primitive3 name value)]))
+(define-syntax-rule (define-primitive0 name value)
+  (define-initial name
+    (description-extend! 'name `(function ,value))))
+(define-syntax-rule (define-primitive1 name value)
+  (define-initial name
+    (description-extend! 'name `(function ,value a))))
+(define-syntax-rule (define-primitive2 name value)
+  (define-initial name
+    (description-extend! 'name `(function ,value a b))))
+(define-syntax-rule (define-primitive3 name value)
+  (define-initial name
+    (description-extend! 'name `(function ,value a b c))))
+
+;; Record types
+(define-record-type <activation-record>
+  (make-activation-record next vals)
+  activation-record?
+  (next activation-record-next activation-record-next-set!)
+  (vals activation-record-vals))
+(define-record-type <closure>
+  (make-closure code closed-environment)
+  closure?
+  (code closure-code)
+  (closed-environment closure-closed-environment))
+
+;; Helpers
+(define (local-variable env ref)
+  (let scan-env ([env env] [i 0])
+    (if (null? env)
+        #f
+        (let ([j (list-index (lambda (name) (eq? name ref)) (car env))])
+          (if j
+              `(local ,i . ,j)
+              (scan-env (cdr env) (+ i 1)))))))
+
+(define (global-variable env ref)
+  (assq-ref env ref))
+
+(define (compute-kind ref r)
+  (or (local-variable r ref)
+      (global-variable (g.current) ref)
+      (global-variable (g.init) ref)))
+
+(define (global-update! i v)
+  (vector-set! sg.current i v))
+
+(define (g.current-extend! ref)
+  (let ([level (length (g.current))])
+    (g.current (cons (cons ref (cons 'global level)) (g.current)))
+    level))
+
+(define (g.init-extend! ref)
+  (let ([level (length (g.init))])
+    (g.init (cons (cons ref (cons 'predefined level)) (g.init)))
+    level))
+
+(define (static-error . args)
+  (apply error "Static Error:" args))
+
+;; activation records
+(define (make-activation-rec size)
+  (make-activation-record #f (make-vector size)))
+
+(define activation-rec-set!
+  (case-lambda
+    [(r k v) (vector-set! (activation-record-vals r) k v)]
+    [(r j k v) (if (zero? j)
+                   (activation-rec-set! r k v)
+                   (activation-rec-set! (activation-rec-next r) (1- j) k v))]))
+
+(define activation-rec-ref
+  (case-lambda
+    [(r i)
+     (vector-ref (activation-record-vals r) i)]
+    [(r i j)
+     (if (zero? i)
+         (activation-rec-ref r j)
+         (activation-rec-ref (activation-rec-next r) (1- i) j))]))
+
+(define (activation-rec-length r)
+  (vector-length (activation-record-vals r)))
+
+(define (activation-rec-next r)
+  (if r
+      (activation-record-next r)
+      (error "Tried to take next of nil record")))
+
+(define (listify! v* arity)
+  (let lp ([index (1- (activation-rec-length v*))]
+           [result '()])
+    (if (= arity index)
+        (activation-rec-set! v* arity result)
+        (lp (1- index) (cons (activation-rec-ref v* (1- index))
+                             result)))))
+;; closures
+(define (invoke f)
+  (cond
+   [(closure? f)
+    (stack-push (*pc*))
+    (*env* (closure-closed-environment f))
+    (*pc* (closure-code f))]
+   [else (error "Tried to invoke a non-closure")]))
+
+;; function descriptions
+(define (description-extend! name description)
+  (desc.init (cons (cons name description) (desc.init))))
+
+(define (get-description name)
+  (let ([p (assq name (desc.init))])
+    (and (pair? p) (cdr p))))
+
+(define desc-args cddr)
+
+(define desc-address cadr)
+
+(define (list->activation-rec lst)
+  (let lp ([lst lst]
+           [next #f])
+    (if (null? lst)
+        next
+        (lp (cdr lst)
+            (make-activation-record next (list->vector (append (car lst) (list undefined-value))))))))
+
+(define (env-set! lst)
+  (*env* (list->activation-rec lst)))
+
+;; environments
+(define (predefined-fetch i)
+  (vector-ref sg.init i))
+
+(define (global-fetch i)
+  (vector-ref sg.current i))
+
+(define (r-extend* r n*)
+  (cons n* r))
+
+(define (sr-extend* sr v*)
+  (activation-record-next-set! v* sr)
+  v*)
+
+;; Initial definitions
+(define-initial t #t)
+(define-initial f #f)
+(define-initial nil '())
+(define-primitive cons cons 2)
+(define-primitive car car 1)
+(define-primitive cdr cdr 1)
+(define-primitive + + 2)
+(define-primitive - - 2)
+(define-primitive = = 2)
+(define-primitive < < 2)
+
+;; Combinators
+(define-leaf (CONSTANT v)
+  (*val* v))
+
+(define-leaf (PUSH-VALUE)
+  (stack-push (*val*)))
+
+(define-leaf (POP-FUNCTION)
+  (*fun* (stack-pop)))
+
+(define-leaf (PRESERVE-ENV)
+  (stack-push (*env*)))
+
+(define-leaf (FUNCTION-INVOKE)
+  (invoke (*fun*)))
+
+(define-leaf (RESTORE-ENV)
+  (*env* (stack-pop)))
+
+(define-leaf (RETURN)
+  (*pc* (stack-pop)))
+
+(define-compound (SEQUENCE m m+)
+  (append m m+))
+
+(define-leaf (SHALLOW-ARGUMENT-REF j)
+  (*val* (activation-rec-ref (*env*) j)))
+
+(define-leaf (DEEP-ARGUMENT-REF i j)
+  (*val* (activation-rec-ref (*env*) i j)))
+
+(define-leaf (PREDEFINED i)
+  (*val* (predefined-fetch i)))
+
+(define-leaf (GLOBAL-REF i)
+  (*val* (global-fetch i)))
+
+(define-leaf (CHECKED-GLOBAL-REF i)
+  (let ([v (global-fetch i)])
+    (if (eq? v undefined-value)
+        (error "Uninitialized variable")
+        (*val* v))))
+
+(define-leaf (JUMP-FALSE i)
+  (when (not (*val*))
+    (*pc* (list-tail (*pc*) i))))
+
+(define-leaf (GOTO i)
+  (*pc* (list-tail (*pc*) i)))
+
+(define-compound (ALTERNATIVE m1 m2 m3)
+  (append m1 (JUMP-FALSE (1+ (length m2))) m2 (GOTO (length m3)) m3))
+
+(define-compound (STORE-ARGUMENT m m* rank)
+  (append m (PUSH-VALUE) m* (POP-FRAME! rank)))
+
+(define-compound (CONS-ARGUMENT m m* arity)
+  (append m (PUSH-VALUE) m* (POP-CONS-FRAME! arity)))
+
+(define-leaf (POP-FRAME! rank)
+  (activation-rec-set! (*val*) rank (stack-pop)))
+
+(define-leaf (POP-CONS-FRAME! arity)
+  (activation-rec-set!
+   (*val*) arity
+   (cons (stack-pop) (activation-rec-ref (*val*) arity))))
+
+(define-leaf (ALLOCATE-FRAME size)
+  (*val* (make-activation-rec (1+ size))))
+
+(define-leaf (ALLOCATE-DOTTED-FRAME size)
+  (let ([rec (make-activation-rec (1+ size))])
+    (activation-rec-set! rec size '())
+    (*val* rec)))
+
+(define-compound (REGULAR-CALL m m+)
+  (append
+   m
+   (PUSH-VALUE)
+   m+
+   (POP-FUNCTION)
+   (PRESERVE-ENV)
+   (FUNCTION-INVOKE)
+   (RESTORE-ENV)))
+
+(define-compound (TR-REGULAR-CALL m m*)
+  (append
+   m
+   (PUSH-VALUE)
+   m*
+   (POP-FUNCTION)
+   (FUNCTION-INVOKE)))
+
+(define-compound (CALL0 address)
+  (INVOKE0 address))
+
+(define-compound (CALL1 address m1)
+  (append m1 (INVOKE1 address)))
+
+(define-compound (CALL2 address m1 m2)
+  (append m1 (PUSH-VALUE) m2 (POP-ARG1) (INVOKE2 address)))
+
+(define-compound (CALL3 address m1 m2 m3)
+  (append m1 (PUSH-VALUE) m2 (PUSH-VALUE) m3 (POP-ARG2) (POP-ARG1) (INVOKE3 address)))
+
+;; Predefined invokers, will eventually be specialized
+
+(define-leaf (INVOKE0 address)
+  (*val* (address)))
+
+(define-leaf (INVOKE1 address)
+  (*val* (address (*val*))))
+
+(define-leaf (INVOKE2 address)
+  (*val* (address (*val*) (*arg1*))))
+
+(define-leaf (INVOKE3 address)
+  (*val* (address (*val*) (*arg1*) (*arg2*))))
+
+(define-leaf (POP-ARG1)
+  (*arg1* (stack-pop)))
+
+(define-leaf (POP-ARG2)
+  (*arg2* (stack-pop)))
+
+(define-compound (FIX-LET m* m+)
+  (append m* (EXTEND-ENV) m+ (UNLINK-ENV)))
+
+(define-compound (TR-FIX-LET m* m+)
+  (append m* (EXTEND-ENV) m+))
+
+(define-leaf (EXTEND-ENV)
+  (*env* (sr-extend* (*env*) (*val*))))
+
+(define-leaf (UNLINK-ENV)
+  (*env* (activation-rec-next (*env*))))
+
+(define-compound (SHALLOW-ARGUMENT-SET! j m)
+  (append m (SET-SHALLOW-ARGUMENT! j)))
+
+(define-leaf (SET-SHALLOW-ARGUMENT! j)
+  (activation-rec-set! (*env*) j (*val*)))
+
+(define-leaf (DEEP-ARGUMENT-SET! i j m)
+  (activation-rec-set! (*env*) i j (m)))
+
+(define-compound (GLOBAL-SET! i m)
+  (append m (SET-GLOBAL! i)))
+
+(define-leaf (SET-GLOBAL! i)
+  (global-update! i (*val*)))
+
+(define-leaf (CREATE-CLOSURE offset)
+  (*val* (make-closure (list-tail (*pc*) offset) (*env*))))
+
+(define-leaf (PACK-FRAME! arity)
+  (listify! (*val*) arity))
+
+(define-leaf (ARITY>=? arity)
+  (unless (>= (activation-rec-length (*val*)) arity)
+    (error "Incorrect arity for nary function")))
+
+(define-leaf (ARITY=? arity)
+  (unless (= (activation-rec-length (*val*)) arity)
+    (error "Incorrect arity for fix function")))
+
+(define-compound (FIX-CLOSURE m+ arity)
+  (define the-function
+    (append (ARITY=? (1+ arity)) (EXTEND-ENV) m+ (RETURN)))
+  (append (CREATE-CLOSURE 1) (GOTO (length the-function)) the-function))
+
+(define-compound (NARY-CLOSURE m+ arity)
+  (define the-function
+    (append (ARITY>=? (1+ arity)) (PACK-FRAME! arity) (EXTEND-ENV) m+ (RETURN)))
+  (append (CREATE-CLOSURE 1) (GOTO (length the-function)) the-function))
+
+(define-leaf (FINISH)
+  (*pc* '()))
+
+;; Denotations
+(define (meaning e r tail?)
+  "Core of the denotation. `tail?' allows us to avoid capturing the local environment if we know we will not return"
+  (match e
+    [(? (negate pair?))
+     (if (symbol? e)      (meaning-reference e r)
+         (meaning-quotation e))]
+    [('quote e* ...)      (meaning-quotation (car e*))]
+    [('lambda v* e* ...)  (meaning-abstraction v* e* r)]
+    [('if e1 e2 e3)       (meaning-alternative e1 e2 e3 r tail?)]
+    [('begin e* ...)      (meaning-sequence e* r tail?)]
+    [('set! n e)          (meaning-assignment n e r)]
+    [(f v* ...)           (meaning-application f v* r tail?)]))
+
+(define (meaning-quotation e*)
+  (CONSTANT e*))
+
+(define (meaning-alternative e1 e2 e3 r tail?)
+  (let ([m1 (meaning e1 r #f)]
+        [m2 (meaning e2 r tail?)]
+        [m3 (meaning e3 r tail?)])
+    (ALTERNATIVE m1 m2 m3)))
+
+(define (meaning-sequence e+ r tail?)
+  (cond
+   [(null? e+) (static-error "Illegal syntax (begin)")]
+   [(null? (cdr e+)) (meaning (car e+) r tail?)]
+   [else (SEQUENCE (meaning (car e+) r #f)
+                   (meaning-sequence (cdr e+) r tail?))]))
+
+(define (meaning-reference n r)
+  (match (compute-kind n r)
+    [('local . (i . j))
+     (if (= i 0)
+         (SHALLOW-ARGUMENT-REF j)
+         (DEEP-ARGUMENT-REF i j))]
+    [('global . i)
+     (CHECKED-GLOBAL-REF i)]
+    [('predefined . i)
+     (PREDEFINED i)]
+    [_ (static-error "No such variable" n)]))
+
+(define (meaning-application f e* r tail?)
+  (cond
+   [(and (symbol? f)
+         (get-description f)
+         (compute-kind f r)) =>
+         (lambda (kind)
+           (if (eq? (car kind) 'predefined)
+               (meaning-primitive-application f e* r)
+               (meaning-regular-application f e* r tail?)))]
+   [(and (pair? f) (eq? (car f) 'lambda))
+    (meaning-closed-application f e* r tail?)]
+   [else (meaning-regular-application f e* r tail?)]))
+
+(define (meaning-list e* r tail?)
+  (cond
+   [(null? e*) '()]
+   [(null? (cdr e*)) (list (meaning (car e*) r tail?))]
+   [else (cons (meaning (car e*) r #f) (meaning-list (cdr e*) r tail?))]))
+
+(define (meaning* e* r)
+  (let lp ([rank 0]
+           [m* (meaning-list e* r #f)])
+    (if (pair? m*)
+        (STORE-ARGUMENT (car m*) (lp (1+ rank) (cdr m*)) rank)
+        (ALLOCATE-FRAME (length e*)))))
+
+(define (meaning*-dotted e* r fixed-size)
+  (let lp ([rank 0]
+           [m* (meaning-list e* r #f)])
+    (cond
+     [(null? m*) (ALLOCATE-DOTTED-FRAME fixed-size)]
+     [(> fixed-size rank) (STORE-ARGUMENT (car m*) (lp (1+ rank) (cdr m*)) rank)]
+     [else (CONS-ARGUMENT (car m*) (lp (1+ rank) (cdr m*)) fixed-size)])))
+
+(define (meaning-regular-application f e* r tail?)
+  (let [(mf (meaning f r #f))
+        (m* (meaning* e* r))]
+    ((if tail? TR-REGULAR-CALL REGULAR-CALL) mf m*))) ;; hehe new trick
+
+(define (meaning-primitive-application f e* r)
+  (let* ([desc (get-description f)]
+         [address (desc-address desc)]
+         [arity (length e*)])
+    (if (= (length (desc-args desc)) arity)
+        (case arity
+          [(0) (CALL0 address)]
+          [(1) (let ([m1 (meaning (first e*) r #f)])
+                 (CALL1 address m1))]
+          [(2) (let ([m1 (meaning (first e*)  r #f)]
+                     [m2 (meaning (second e*) r #f)])
+                 (CALL2 address m1 m2))]
+          [(3) (let ([m1 (meaning (first e*)  r #f)]
+                     [m2 (meaning (second e*) r #f)]
+                     [m3 (meaning (third e*)  r #f)])
+                 (CALL3 address m1 m2 m3))])
+        (static-error "Wrong arity for" f arity))))
+
+(define (meaning-closed-application e ee* r tail?)
+  (let lp ([n* (second e)]
+           [e* ee*]
+           [fixargs '()])
+    (cond
+     [(pair? n*)
+      (if (pair? e*)
+          (lp (cdr n*) (cdr e*) (cons (car n*) fixargs))
+          (static-error "Not enough arguments" e ee*))]
+     [(null? n*)
+      (if (pair? e*)
+          (static-error "Too many arguments" e ee*)
+          (meaning-fixed-closed-application (second e) (drop e 2) ee* r tail?))]
+     [else
+      (meaning-dotted-closed-application (reverse fixargs) n* (drop e 2) ee* r tail?)])))
+
+(define (meaning-fixed-closed-application n* body e* r tail?)
+  (let* [(m* (meaning* e* r))
+         (r2 (r-extend* r n*))
+         (m+ (meaning-sequence body r2 tail?))]
+    ((if tail? TR-FIX-LET FIX-LET) m* m+)))
+
+(define (meaning-dotted-closed-application n* n body e* r tail?)
+  (let* ([m* (meaning*-dotted e* r (length n*))]
+         [r2 (r-extend* r (append n* (list n)))]
+         [m+ (meaning-sequence body r2 tail?)])
+    ((if tail? TR-FIX-LET FIX-LET) m* m+)))
+
+(define (meaning-assignment n e r)
+  (let ([m (meaning e r #f)])
+    (match (compute-kind n r)
+      [('local . (i . j))
+       (if (zero? i)
+           (SHALLOW-ARGUMENT-SET! j m)
+           (DEEP-ARGUMENT-SET! i j m))]
+      [('global . i)
+       (GLOBAL-SET! i m)]
+      [('predefined _ ...)
+       (static-error "Cannot set predefined variable" n)]
+      [_ (static-error "Cannot set! undefined variable" n)])))
+
+(define (meaning-abstraction nn* body r)
+  (let lp ([n* nn*]
+           [fixargs '()])
+    (cond
+     [(pair? n*) (lp (cdr n*) (cons (car n*) fixargs))]
+     [(null? n*) (meaning-fixed-abstraction nn* body r)]
+     [else (meaning-dotted-abstraction (reverse fixargs) n* body r)])))
+
+(define (meaning-fixed-abstraction n* body r)
+  (let* ([arity (length n*)]
+         [r2 (r-extend* r n*)]
+         [m+ (meaning-sequence body r2 #t)])
+    (FIX-CLOSURE m+ arity)))
+
+(define (meaning-dotted-abstraction n* n body r)
+  (let* ([arity (length n*)]
+         [r2 (r-extend* r (append n* (list n)))]
+         [m+ (meaning-sequence body r2 #t)])
+    (NARY-CLOSURE m+ arity)))
+
+;; VM Runner
+(define (run)
+  (let ([instruction (car (*pc*))])
+    (*pc* (cdr (*pc*)))
+    (instruction)
+    (if (pair? (*pc*))
+        (run)
+        (format #f "Execution terminated with *val* = ~a\n" (*val*)))))
+
+;; Reporting
+(letrec ([combinator-name (compose symbol->string car)]
+         [sort-combinators
+          (lambda (combinators)
+            (sort combinators (lambda (a b)
+                                (string< (combinator-name a) (combinator-name b)))))]
+         [n-leafs (length leafs)]
+         [n-compounds (length compounds)])
+  (format #t "Defined ~a combinators; ~a leaves and ~a compound instructions\n" (+ n-leafs n-compounds) n-leafs n-compounds)
+  (format #t "Leaves:\n")
+  (for-each (lambda (c) (format #t " (~a ~a)\n" (first c) (second c)))
+            (sort-combinators leafs))
+    (format #t "Compounds:\n")
+  (for-each (lambda (c) (format #t " (~a ~a)\n" (first c) (second c)))
+            (sort-combinators compounds)))
+
+;; Tests
+(define (run-test prgm)
+  (*pc* prgm)
+  (let lp ()
+    (define instruction (car (*pc*)))
+    (*pc* (cdr (*pc*)))
+    (instruction)
+    (if (null? (*pc*))
+        (*val*)
+        (lp))))
+
+(test-begin "bytecode-compiler")
+;; quotation
+(test-group "meaning-quotation"
+  (with-fresh-globals
+   (test-eq 'apple
+     (run-test (meaning-quotation 'apple)))
+   (test-eq '(apple pear)
+     (run-test (meaning-quotation '(apple pear))))))
+;; alternatives
+(test-group "linear-thunk-interpreter"
+  (with-fresh-globals
+   (env-set! '((#t apple pear)))
+   (test-eq 'apple
+     (run-test (meaning-alternative 'p 't 'f '((p t f)) #t)))
+   (env-set! '((#f apple pear)))
+   (test-eq 'pear
+     (run-test (meaning-alternative 'p 't 'f '((p t f)) #t)))))
+  ;; sequences
+(test-group "meaning-sequence"
+  (with-fresh-globals
+   (env-set! '((1 2)))
+   (test-eq 2
+     (run-test (meaning-sequence '(a b) '((a b)) #t)))))
+;; references
+(test-group "meaning-reference"
+  (with-fresh-globals
+   (g.current-extend! 'a)
+   (vector-set! sg.current 0 10)
+   (g.init-extend! 'b)
+   (vector-set! sg.init 0 20)
+   (env-set! '((0 1)))
+   (test-eq 1
+     (run-test (meaning-reference 'b '((a b)))))
+   (env-set! '((0 1) (2)))
+   (test-eq 0
+     (run-test (meaning-reference 'b '((a) (b c)))))
+   (test-equal 10
+     (run-test (meaning-reference 'a '())))
+   (test-equal 20
+     (run-test (meaning-reference 'b '())))))
+;; applications
+(test-group "meaning-application"
+  (with-fresh-globals
+   (desc.init `((+ function ,+ . (x y))))
+   (define *-abstraction
+     (run-test (FIX-CLOSURE
+                (list (lambda ()
+                        (*val*
+                         (* (activation-rec-ref (*env*) 0)
+                            (activation-rec-ref (*env*) 1)))))
+       2)))
+   (env-set! `((,*-abstraction)))
+   (test-eq 9
+     (run-test (meaning-regular-application '* '(3 3) '((*)) #t)))
+   (test-eq 2
+     (run-test (meaning-primitive-application '+ '(1 1) '(()))))
+   (test-eq 2 (run-test (meaning-closed-application '(lambda (x) x) '(2) '(()) #t)))
+   (test-equal '(2 3) (run-test (meaning-closed-application '(lambda (x . y) y) '(1 2 3) '(()) #t)))))
+;; assignment
+(test-group "meaning-assignment"
+  (with-fresh-globals
+   (*env* (list->activation-rec '((1))))
+  (run-test (meaning-assignment 'apples 2 '((apples))))
+   (test-eq 2                                
+     (activation-rec-ref (*env*) 0 0))))
+;; abstraction
+(test-group "meaning-abstraction"
+  (define test-code (append
+                     (PUSH-VALUE)
+                     (CONSTANT 1)
+                     (PUSH-VALUE)
+                     (CONSTANT 2)
+                     (PUSH-VALUE)
+                     (ALLOCATE-FRAME 2)
+                     (POP-FRAME! 1)
+                     (POP-FRAME! 0)
+                     (POP-FUNCTION)
+                     (FUNCTION-INVOKE)))
+  (with-fresh-globals
+   (test-assert (closure? (run-test (meaning-abstraction '(x) '(x) '(())))))
+   (test-eq 2
+     (run-test (append (meaning-abstraction '(x y) '(y) '(())) test-code)))
+   (test-equal '(2)
+     (run-test (append (meaning-abstraction '(x . y) '(y) '(())) test-code)))))
+;; (test-group "call/cc"
+;;   (test-eq 3 ((meaning '(+ 2 (call/cc (lambda (cc) (cc 1) 2))) '(()) #t)))
+;;   (test-eq 5 ((meaning '((lambda (cont v)
+;;                            (set! v (+ 2 (call/cc (lambda (cc) (set! cont cc) 1))))
+;;                            (if (= v 3)
+;;                                (cont v)
+;;                                v)) #f 0)
+;;                        '(()) #t))))
+;; (test-group "apply"
+;;   (test-eq 3 ((meaning '(apply + 1 2 '()) '(()) #t)))
+;;   (test-eq 3 ((meaning '(apply + '(1 2)) '(()) #t))))
+(test-end "linear-thunk-interpreter")