Arbitrary stack access. What to do with tail calls?

scmvm/assembler.scm

@@ -6,7 +6,7 @@
   #:use-module ((scheme base) #:select (write-bytevector))
   #:export ((make-assembler* . make-assembler)
 	    assembler?
-	    assembler-pos
+	    assembler-pos assembler-pos-set!
 	    assembler-buf
 	    assembler-labels
 	    emit-label

scmvm/language/assembly.scm

@@ -13,8 +13,7 @@
 
 (define (lookup-instruction inst)
   (define inst-obj (assq (or-alias inst) *instruction-set*))
-  (if inst-obj
+  (or inst-obj
-      inst-obj
       (error (format #f "could not find instruction ~a" inst))))
 
 (define label? (negate pair?))

scmvm/language/scheme.scm

@@ -1,6 +1,9 @@
 (define-module (scmvm language scheme)
   #:use-module (scmvm assembler)
-  #:use-module (ice-9 match))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (compile decompile ir-convert))
 
 ;; Scheme compiler
 ;; Scheme subset we're targeting
@@ -29,7 +32,6 @@
 		(name (cdr v*)
 		      (lambda (t*)
 			(k (cons t t*)))))))))
-
 
 ;; Desugaring
 ;; Transforms to simplify the language
@@ -47,7 +49,7 @@
 
 (define (desugar-prgm prgm)
   (map (lambda (top)
-	 (if (eq? (car top) 'define)
+	 (if (and (pair? top) (eq? (car top) 'define))
 	     (desugar-define top)
 	     (desugar-exp top)))
        prgm))
@@ -94,14 +96,15 @@
 ;; <cexp> ::= (<aexp> <aexp> ...)
 ;;          | (if <aexp> <cexp> <cexp>)
 ;;          | (set-then! <var> <aexp> <cexp>)
+;;          | (define-then! <var> <aexp> <cexp>)
 ;; <aexp> ::= (lambda (<var> ...) exp)
-;;          | <num> | <sym> | <var> | #t | #f
+;;          | <num> | <var> | #t | #f
 ;; 
 ;; We choose a hybrid transformation based on https://matt.might.net/articles/cps-conversion/
 
 (define undefined-value (make-symbol "undefined"))
 
-(define (cps-convert expr ktail)
+(define (cps-convert-prgm prgm ktail)
   ;; M : expr -> aexp
   ;; T-k : expr, (aexp -> cexp) -> cexp
   ;; T-c : expr, aexp -> cexp
@@ -165,17 +168,7 @@
 		 (T*-k e* (lambda ($e*)
 			    `(,$f ,@$e* ,c)))))]))
   (define-cps-loop T*-k T-k)
-  (T-k expr ktail))
+  (T-c prgm ktail))
 
-(define (cps-convert-prgm prgm)
+(define* (ir-convert prgm #:key (ktail 'ktail))
-  (if (pair? prgm)
+  (cps-convert-prgm (desugar-prgm prgm) ktail))
-      (cons (cps-convert-top (car prgm))
-            (cps-convert-prgm (cdr prgm)))
-      '()))
-
-(define (cps-convert-top top)
-  (match top
-    [`(define ,v ,e)
-     (cps-convert e (lambda ($rv) `(define ,v ,$rv)))]
-    [_
-     (cps-convert top (lambda _ `(nop)))]))

scmvm/vm.scm

@@ -58,6 +58,9 @@
       [(->list)
        (lambda ()
 	 (reverse-vector->list the-stack 0 top))]
+      [(set!)
+       (lambda (k obj)
+         (vector-set! the-stack k obj))]
       [else (error "stack dispatch unknown value")])))
 
 (define (push stack v)
@@ -81,6 +84,9 @@
 (define (stack->list stack)
   ((stack '->list)))
 
+(define (stack-set! stack k obj)
+  ((stack 'set!) k obj))
+
 
 ;;; IO
 (define (read-word)
@@ -116,6 +122,7 @@
     (rot    #x18)
     (over   #x19)
     (not    #x1a)
+    (set!    #x1b)
     (bye    #xff)))
 
 (define instruction-name car)
@@ -243,6 +250,11 @@
        (push data-stack b)
        (push data-stack a)
        (push data-stack b))]
+    [(set!)
+     ;; use let* to induce an order of evaluation
+     (let* ([idx (pop data-stack)]
+            [obj (pop data-stack)])
+       (stack-set! data-stack idx obj))]
     [(bye) (set! exit? #t)])
   (when (not exit?)
     (run-vm vm)))