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

Debugger, begin runtime stuff

Browse Source
This commit is contained in:
Dane Johnson
2025-06-11 10:50:38 -05:00
parent a36eea12d0
commit f939d1b08b
6 changed files with 277 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files

136
scmvm/vm.scm
View File

@@ -5,7 +5,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (make-vm run-vm vm-memory-ref vm-memory-set! vm-memory vm-load-program!
vm-pc-ref vm-pc-set!
vm-pc vm-pc-set!
*instruction-set* instruction-type instruction-code))
;;; Data Structures
@@ -156,70 +156,70 @@
word))
(define (fetch-and-execute)
(define exit? #f)
(let lp ([op (fetch-byte)])
(when debugger
(debugger))
(case (op-lookup op)
[(push)
(push data-stack (fetch-word))]
[(!)
(let ([addr (pop data-stack)]
[v (pop data-stack)])
(ram-word-set! addr v))]
[(@)
(let* ([addr (pop data-stack)]
[v (ram-word-ref addr)])
(push data-stack v))]
[(+ - and or nand nor xor)
(let ([v2 (pop data-stack)]
[v1 (pop data-stack)])
(push data-stack ((binop-lookup op) v1 v2)))]
[(= > <)
(let ([v2 (pop data-stack)]
[v1 (pop data-stack)])
(if ((relop-lookup op) v1 v2)
(push data-stack 1)
(push data-stack 0)))]
[(jmp)
(jump (pop data-stack))]
[(branch)
(let ([addr (pop data-stack)])
(when (zero? (pop data-stack))
(jump addr)))]
[(call)
(let ([addr (pop data-stack)])
(push ret-stack pc)
(jump addr))]
[(return)
(jump (pop ret-stack))]
[(>R)
(push ret-stack (pop data-stack))]
[(R>)
(push data-stack (pop ret-stack))]
[(drop)
(pop data-stack)]
[(nip)
(let ([v (pop data-stack)])
(pop data-stack)
(push data-stack v))]
[(dup)
(push data-stack (peek data-stack))]
[(swap)
(swap data-stack)]
[(rot)
(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))]
[(over)
(let* ([a (pop data-stack)]
[b (pop data-stack)])
(push data-stack b)
(push data-stack a)
(push data-stack b))]
[(bye) (set! exit? #t)]))
(when debugger
(debugger))
(define op (fetch-byte))
(case (op-lookup op)
[(push)
(push data-stack (fetch-word))]
[(!)
(let ([addr (pop data-stack)]
[v (pop data-stack)])
(ram-word-set! addr v))]
[(@)
(let* ([addr (pop data-stack)]
[v (ram-word-ref addr)])
(push data-stack v))]
[(+ - and or nand nor xor)
(let ([v2 (pop data-stack)]
[v1 (pop data-stack)])
(push data-stack ((binop-lookup op) v1 v2)))]
[(= > <)
(let ([v2 (pop data-stack)]
[v1 (pop data-stack)])
(if ((relop-lookup op) v1 v2)
(push data-stack 1)
(push data-stack 0)))]
[(jmp)
(jump (pop data-stack))]
[(branch)
(let ([addr (pop data-stack)])
(when (zero? (pop data-stack))
(jump addr)))]
[(call)
(let ([addr (pop data-stack)])
(push ret-stack pc)
(jump addr))]
[(return)
(jump (pop ret-stack))]
[(>R)
(push ret-stack (pop data-stack))]
[(R>)
(push data-stack (pop ret-stack))]
[(drop)
(pop data-stack)]
[(nip)
(let ([v (pop data-stack)])
(pop data-stack)
(push data-stack v))]
[(dup)
(push data-stack (peek data-stack))]
[(swap)
(swap data-stack)]
[(rot)
(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))]
[(over)
(let* ([a (pop data-stack)]
[b (pop data-stack)])
(push data-stack b)
(push data-stack a)
(push data-stack b))]
[(bye) (set! exit? #t)])
(when (not exit?)
(fetch-and-execute)))
(lambda (x)
@@ -228,7 +228,7 @@
[(vm-memory) (lambda () ram)]
[(vm-memory-ref) ram-word-ref]
[(vm-memory-set!) ram-word-set!]
[(vm-pc-ref) (lambda () pc)]
[(vm-pc) (lambda () pc)]
[(vm-pc-set!) (lambda (v) (set! pc v))]
[else (error "vm unknown dispatch")])))
@@ -251,9 +251,9 @@
ram 0
(bytevector-length prgm))))
(define (vm-pc-ref vm)
(define (vm-pc vm)
"Return the value of the pc"
((vm 'vm-pc-ref)))
((vm 'vm-pc)))
(define (vm-pc-set! vm pc)
"Set the value of the pc"