dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Externalize stack for some reason, am I deathless?

Browse Source
This commit is contained in:
Dane Johnson
2026-02-10 16:27:28 -06:00
parent 4280841719
commit c7b0d20334
3 changed files with 151 additions and 145 deletions
Download Patch File Download Diff File Expand all files Collapse all files

73
scmvm/util/stack.scm Normal file
View File

@@ -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))

222
scmvm/vm.scm
View File

@@ -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)))

1
tests.scm
View File

@@ -1,6 +1,7 @@
(use-modules (d- test)
(scmvm assembler)
(scmvm vm)
(scmvm util stack)
(scmvm debugger)
(scmvm language assembly)
(scmvm language scheme)