Externalize stack for some reason, am I deathless?

scmvm/util/stack.scm

@@ -0,0 +1,73 @@
+(define-module (scmvm util stack)
+  #:use-module (srfi srfi-43)
+  #:export (make-stack stack-ref stack->list stack-set!
+                       (push . stack-push) (pop . stack-pop) (peek . stack-peek) (swap . stack-swap)))
+
+;; Stack data structure. I made this a closure implementation for some reason
+
+(define *stack-size* 512)
+
+(define* (make-stack #:optional (stack-size *stack-size*))
+  "Make a new stack, optionally setting the size"
+  (define the-stack (make-vector stack-size))
+  (define top 0)
+  (lambda (x)
+    (case x
+      [(push)
+       (lambda (v)
+         (if (>= top stack-size)
+             (error "stack overflow")
+             (begin
+               (vector-set! the-stack top v)
+               (set! top (1+ top)))))]
+      [(pop)
+       (lambda ()
+         (if (zero? top)
+             (error "pop empty stack")
+             (begin
+               (set! top (1- top))
+               (vector-ref the-stack top))))]
+      [(peek)
+       (lambda ()
+         (if (zero? top)
+             (error "peek empty stack")
+             (vector-ref the-stack (1- top))))]
+      [(swap)
+       (lambda ()
+         (if (< (vector-length the-stack) 2)
+             (error "no value to swap")
+             (let ([a (vector-ref the-stack (- top 2))]
+                   [b (vector-ref the-stack (- top 1))])
+               (vector-set! the-stack (- top 2) b)
+               (vector-set! the-stack (- top 1) a))))]
+      [(ref)
+       (lambda (k)
+         (vector-ref the-stack k))]
+      [(->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)
+  ((stack 'push) v))
+
+(define (pop stack)
+  ((stack 'pop)))
+
+(define (peek stack)
+  ((stack 'peek)))
+
+(define (swap stack)
+  ((stack 'swap)))
+
+(define (stack-ref stack k)
+  ((stack 'ref) k))
+
+(define (stack->list stack)
+  ((stack '->list)))
+
+(define (stack-set! stack k obj)
+  ((stack 'set!) k obj))

scmvm/vm.scm

@@ -7,90 +7,22 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-43)
   #:use-module (ice-9 format)
-  #:export (make-stack (push . stack-push) (pop . stack-pop) (peek . stack-peek) stack-ref stack->list
-		       (make-vm* . make-vm) run-vm
-    		       vm-memory-ref vm-memory-byte-ref vm-memory-set! vm-memory vm-load-program!
-		       vm-data-stack vm-ret-stack
-		       vm-debugger vm-debugger-set!
-		       vm-pc vm-pc-set!
-                       vm-instruction-set
-                       instruction-lookup instruction-name instruction-code
-		       forth-instruction-set))
+  #:use-module (scmvm util stack)
+  #:export ((make-vm* . make-vm) run-vm
+    	    vm-memory-ref vm-memory-byte-ref vm-memory-set! vm-memory vm-load-program!
+	    vm-data-stack vm-ret-stack
+	    vm-debugger vm-debugger-set!
+	    vm-pc vm-pc-set!
+            vm-instruction-set
+            instruction-lookup instruction-name instruction-code
+	    forth-instruction-set))
 
-;;; Data Structures
-(define *stack-size* 512)
+;;; IO
 (define *memory-size* 2048)
 
-(define* (make-stack #:optional (stack-size *stack-size*))
-  "Make a new stack, optionally setting the size"
-  (define the-stack (make-vector stack-size))
-  (define top 0)
-  (lambda (x)
-    (case x
-      [(push)
-       (lambda (v)
-         (if (>= top stack-size)
-             (error "stack overflow")
-             (begin
-               (vector-set! the-stack top v)
-               (set! top (1+ top)))))]
-      [(pop)
-       (lambda ()
-         (if (zero? top)
-             (error "pop empty stack")
-             (begin
-               (set! top (1- top))
-               (vector-ref the-stack top))))]
-      [(peek)
-       (lambda ()
-         (if (zero? top)
-             (error "peek empty stack")
-             (vector-ref the-stack (1- top))))]
-      [(swap)
-       (lambda ()
-         (if (< (vector-length the-stack) 2)
-             (error "no value to swap")
-             (let ([a (vector-ref the-stack (- top 2))]
-                   [b (vector-ref the-stack (- top 1))])
-               (vector-set! the-stack (- top 2) b)
-               (vector-set! the-stack (- top 1) a))))]
-      [(ref)
-       (lambda (k)
-         (vector-ref the-stack k))]
-      [(->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)
-  ((stack 'push) v))
-
-(define (pop stack)
-  ((stack 'pop)))
-
-(define (peek stack)
-  ((stack 'peek)))
-
-(define (swap stack)
-  ((stack 'swap)))
-
-(define (stack-ref stack k)
-  ((stack 'ref) k))
-
 (define* (make-ram #:optional (memory-size *memory-size*))
   (make-bytevector memory-size #x00))
 
-(define (stack->list stack)
-  ((stack '->list)))
-
-(define (stack-set! stack k obj)
-  ((stack 'set!) k obj))
-
-
-;;; IO
 (define (read-word)
   "Read the next 32-bit value from (current-input-port)"
   (let ([bv (read-bytevector 4)])
@@ -123,108 +55,108 @@
 
 (define-instruction-set forth-instruction-set
   (define-instruction (push #x01)
-    (push (*data-stack*) (fetch-word!)))
+    (stack-push (*data-stack*) (fetch-word!)))
   (define-instruction (! #x02)
-    (let ([addr (pop (*data-stack*))]
-          [v (pop (*data-stack*))])
+    (let ([addr (stack-pop (*data-stack*))]
+          [v (stack-pop (*data-stack*))])
       (ram-word-set! addr v)))
   (define-instruction (@ #x03)
-    (let* ([addr (pop (*data-stack*))]
+    (let* ([addr (stack-pop (*data-stack*))]
            [v (ram-word-ref addr)])
-      (push (*data-stack*) v)))
+      (stack-push (*data-stack*) v)))
   (define-instruction (+ #x04)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
-      (push (*data-stack*) (+ v1 v2))))
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (+ v1 v2))))
   (define-instruction (- #x05)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
-      (push (*data-stack*) (- v1 v2))))
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (- v1 v2))))
   (define-instruction (and #x06)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
-      (push (*data-stack*) (logand v1 v2))))
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (logand v1 v2))))
   (define-instruction (or #x07)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
-      (push (*data-stack*) (logior v1 v2))))
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (logior v1 v2))))
   (define-instruction (nand #x08)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
-      (push (*data-stack*) (if (zero? (logand v1 v2)) 1 0))))
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (if (zero? (logand v1 v2)) 1 0))))
   (define-instruction (nor #x09)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
-      (push (*data-stack*) (if (zero? (logior v1 v2)) 1 0))))
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (if (zero? (logior v1 v2)) 1 0))))
   (define-instruction (xor #x0a)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
-      (push (*data-stack*) (logxor v1 v2))))
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (logxor v1 v2))))
   (define-instruction (= #x0b)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
       (if (= v1 v2)
-          (push (*data-stack*) 1)
-          (push (*data-stack*) 0))))
+          (stack-push (*data-stack*) 1)
+          (stack-push (*data-stack*) 0))))
   (define-instruction (> #x0c)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
       (if (> v1 v2)
-          (push (*data-stack*) 1)
-          (push (*data-stack*) 0))))
+          (stack-push (*data-stack*) 1)
+          (stack-push (*data-stack*) 0))))
   (define-instruction (< #x0d)
-    (let ([v2 (pop (*data-stack*))]
-          [v1 (pop (*data-stack*))])
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
       (if (< v1 v2)
-          (push (*data-stack*) 1)
-          (push (*data-stack*) 0))))
+          (stack-push (*data-stack*) 1)
+          (stack-push (*data-stack*) 0))))
   (define-instruction (jmp #x0e)
-    (jump! (pop (*data-stack*))))
+    (jump! (stack-pop (*data-stack*))))
   (define-instruction (branch #x0f)
-    (let* ([addr (pop (*data-stack*))]
-           [test (pop (*data-stack*))])
+    (let* ([addr (stack-pop (*data-stack*))]
+           [test (stack-pop (*data-stack*))])
       (when (zero? test)
         (jump! addr))))
   (define-instruction (call #x10)
-    (let ([addr (pop (*data-stack*))])
-      (push (*ret-stack*) (vm-pc (*vm*)))
+    (let ([addr (stack-pop (*data-stack*))])
+      (stack-push (*ret-stack*) (vm-pc (*vm*)))
       (jump! addr)))
   (define-instruction (return #x11)
-    (jump! (pop (*ret-stack*))))
+    (jump! (stack-pop (*ret-stack*))))
   (define-instruction (>R #x12)
-    (push (*ret-stack*) (pop (*data-stack*))))
+    (stack-push (*ret-stack*) (stack-pop (*data-stack*))))
   (define-instruction (R> #x13)
-    (push (*data-stack*) (pop (*ret-stack*))))
+    (stack-push (*data-stack*) (stack-pop (*ret-stack*))))
   (define-instruction (drop #x14)
-    (pop (*data-stack*)))
+    (stack-pop (*data-stack*)))
   (define-instruction (nip #x15)
-    (let ([v (pop (*data-stack*))])
-      (pop (*data-stack*))
-      (push (*data-stack*) v)))
+    (let ([v (stack-pop (*data-stack*))])
+      (stack-pop (*data-stack*))
+      (stack-push (*data-stack*) v)))
   (define-instruction (dup #x16)
-    (push (*data-stack*) (peek (*data-stack*))))
+    (stack-push (*data-stack*) (stack-peek (*data-stack*))))
   (define-instruction (swap #x17)
-    (swap (*data-stack*)))
+    (stack-swap (*data-stack*)))
   (define-instruction (rot #x18)
-    (let* ([a (pop (*data-stack*))]
-           [b (pop (*data-stack*))]
-           [c (pop (*data-stack*))])
-      (push (*data-stack*) a)
-      (push (*data-stack*) c)
-      (push (*data-stack*) b)))
+    (let* ([a (stack-pop (*data-stack*))]
+           [b (stack-pop (*data-stack*))]
+           [c (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) a)
+      (stack-push (*data-stack*) c)
+      (stack-push (*data-stack*) b)))
   (define-instruction (over #x19)
-    (let* ([a (pop (*data-stack*))]
-           [b (pop (*data-stack*))])
-      (push (*data-stack*) b)
-      (push (*data-stack*) a)
-      (push (*data-stack*) b)))
+    (let* ([a (stack-pop (*data-stack*))]
+           [b (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) b)
+      (stack-push (*data-stack*) a)
+      (stack-push (*data-stack*) b)))
   (define-instruction (not #x1a)
-    (let ([a (pop (*data-stack*))])
-      (push (*data-stack*) (if (zero? a) 1 0))))
+    (let ([a (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (if (zero? a) 1 0))))
   (define-instruction (set! #x1b)
     ;; use let* to induce an order of evaluation
-    (let* ([idx (pop (*data-stack*))]
-           [obj (pop (*data-stack*))])
+    (let* ([idx (stack-pop (*data-stack*))]
+           [obj (stack-pop (*data-stack*))])
       (stack-set! (*data-stack*) idx obj)))
   (define-instruction (bye #xff)
     (*vm-exit* #t)))