Unoptimized bytecode interpreter (again without call/cc or apply)

bytecode-compiler.scm

@@ -0,0 +1,691 @@
+(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 (find-indexed pred lst)
+  (find (lambda (kons) (pred (car kons)))
+        (zip lst (iota (length lst)))))
+
+(define (local-variable env ref)
+  (let scan-env ([env env] [i 0])
+    (if (null? env)
+        #f
+        (let ([the-match (find-indexed (lambda (name) (eq? name ref)) (car env))])
+          (if the-match
+              `(local ,i . ,(cadr the-match))
+              (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 "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")

direct-style-interpreter.scm

@@ -213,28 +213,26 @@
 (define-primitive + + 2)
 (define-primitive = = 2)
 (define-initial call/cc
-  (let* ([arity 1]
-         [arity+1 (1+ arity)])
   (make-closure
    (lambda (v* sr)
-       (if (= arity+1 (activation-rec-length v*))
+     (if (= (activation-rec-length v*) 2)
          (call/cc ;; call/cc is "magic" for our purposes here,
                   ;; there are no reified continuations in the denotation
           (lambda (k)
             (invoke
              (activation-rec-ref v* 0)
-               (let ([rec (make-activation-rec (+ 1 1))])
+             (let ([rec (make-activation-rec 2)])
                (activation-rec-set!
                 rec 0
                 (make-closure
                  (lambda (values r)
-                     (if (= arity+1 (activation-rec-length values))
+                   (if (= (activation-rec-length values) 2)
                        (k (activation-rec-ref values 0))
                        (error "Incorrect arity" 'continuation)))
                  (*env*)))
                rec))))
          (error "Incorrect arity" 'call/cc)))
-     (*env*))))
+   (*env*)))
 (define-initial apply
   (make-closure
    (lambda (v* sr)