Miscellany

0 value opcode-jumptable-end
0 value opcode-jumptable

\ vm helpers

: find-instruction-by-opcode
    cells opcode-jumptable + dup opcode-jumptable-end >= if ." illegal opcode" cr abort then
    @ ;

stack-index-start value stack-index
rstack-index-start value rstack-index
0 value pc-index
0 value here-index

true value cpu-running
0 value cycles
0 value postponed-instruction

: .w
    dup $7fff > if $10000 - then . ;

: dump-stack-impl
    2dup = if
        2drop ." empty"
    else
        2dup ." { " swap - 2 / . ." }  " 2 - do i read-word .w -2 +loop
    then ;

: dump-stack
    stack-index stack-index-start dump-stack-impl ;

: dump-rstack
    rstack-index rstack-index-start dump-stack-impl ;

: flush-stack
    stack-index-start to stack-index ;

: flush-rstack
    rstack-index-start to rstack-index ;

: >stack
    stack-index data-index <= if ." stack overflow" abort then
    stack-index 2 - to stack-index
    stack-index write-word ;

: stack>
    stack-index stack-index-start >= if ." stack underflow" abort then
    stack-index read-word
    stack-index 2 + to stack-index
    dup $7fff > if $10000 - then ;

: >rstack
    rstack-index stack-index-start <= if ." rstack overflow" abort then
    rstack-index 2 - to rstack-index
    rstack-index write-word ;

: rstack>
    rstack-index rstack-index-start >= if ." rstack underflow" abort then
    rstack-index read-word
    rstack-index 2 + to rstack-index ;

: pc-index+1 pc-index 1+ to pc-index ;

: pc-index+2 pc-index 2 + to pc-index ;


\ implementation of the virtual machine instructions

: v-lit
    pc-index read-word >stack pc-index+2 ;

: v-@
    stack> read-word >stack ;

: v-c@
    stack> read-byte >stack ;

: v-!
    stack> stack> swap write-word ;

: v-c!
    stack> stack> swap write-byte ;

: v-r>
    rstack> >stack ;

: v->r
    stack> >rstack ;

: v-@r
    rstack> dup >rstack >stack ;

: v-dup
    stack> dup >stack >stack ;

: v-swap
    stack> stack> swap >stack >stack ;

: v-drop
    stack> drop ;

: v-over
    stack> stack> dup >stack swap >stack >stack ;

: v-here
    here-index >stack ;

: v-allot
    stack> here-index + to here-index ;

: v-jz
    stack> 0= if pc-index read-word to pc-index else pc-index+2 then ;

: v-jnz
    stack> 0<> if pc-index read-word to pc-index else pc-index+2 then ;

: v-jump
    pc-index read-word to pc-index ;

: v-call
    pc-index 2 + >rstack pc-index read-word to pc-index ;

: v-pop-call
    pc-index >rstack stack> to pc-index ;

: v-ret
    rstack-index rstack-index-start =
    if
        false to cpu-running
    else
        rstack> to pc-index
    then ;

: v-+
    stack> stack> + >stack ;

: v--
    stack> stack> swap - >stack ;

: v-1+
    stack> 1+ >stack ;

: v-1-
    stack> 1- >stack ;

: v-*
    stack> stack> swap * >stack ;

: v-/
    stack> stack> swap / >stack ;

: v-negate
    stack> negate >stack ;

: v-lshift
    stack> stack> swap lshift >stack ;

: v-rshift
    stack> stack> swap rshift >stack ;

: v-invert
    stack> invert >stack ;

: v-and
    stack> stack> and >stack ;

: v-or
    stack> stack> or >stack ;

: v-=
    stack> stack> = >stack ;

: v-<
    stack> stack> > >stack ;

: v->
    stack> stack> < >stack ;

: v-execute
    stack> find-instruction-by-opcode to postponed-instruction ;

: v-emit
    stack> emit ;

: v-stop
    false to cpu-running ;

: v-.
    stack> .w ;


\ virtual machine instructions

here to opcode-jumptable

\ stack/memory operations
' v-lit ,
' v-@ ,
' v-c@ ,
' v-! ,
' v-c! ,
' v-r> ,
' v->r ,
' v-@r ,
' v-dup ,
' v-swap ,
' v-drop ,
' v-over ,
' v-here ,
' v-allot ,

\ control flow
' v-jz ,
' v-jnz ,
' v-jump ,
' v-call ,
' v-pop-call ,
' v-ret ,

\ arithmetic
' v-+ ,
' v-- ,
' v-1+ ,
' v-1- ,
' v-* ,
' v-/ ,
' v-negate ,
' v-lshift ,
' v-rshift ,

\ bit operations
' v-invert ,
' v-and ,
' v-or ,

\ compare operations
' v-= ,
' v-< ,
' v-> ,

\ I/O and special instructions
' v-execute ,
' v-emit ,
' v-stop ,
' v-. ,

here to opcode-jumptable-end


\
\ simulator
\

: c
    true to cpu-running
    0 to postponed-instruction
    begin
        cpu-running invert if exit then
        cycles 10000 > if s" cycle limit reached, start 'c' for continue" type exit then
        cycles 1+ to cycles
        postponed-instruction dup if
            0 to postponed-instruction execute
        else
            drop pc-index read-byte
            find-instruction-by-opcode pc-index+1 execute
        then
    again ;

: vm ( vm-address -- )
    to pc-index
    0 to cycles
    c ;

s" :data-start" search-label drop @ to here-index

: scopy ( addr count -- v-stack: simulated-addr count )
    locals| word-count word-start |
    word-count here-index write-byte here-index 1+ dup word-count + dup to here-index
    over 2dup <> if
        do
            word-start c@ i write-byte
            word-start 1+ to word-start
        loop
    else
        2drop
    then
    >stack word-count >stack ;

: skip-input ( count -- )
    >in @ + >in ! ;

: unparsed-source ( -- addr u ) source >in @ /string ;
: read-unparsed-string ( -- addr u ) unparsed-source dup skip-input ;


: get-vm-evaluate-address ( -- vm-addr )
    s" :evaluate-code" search-label drop @ ;

: eval-string ( addr u -- )
    scopy get-vm-evaluate-address vm ;

: eval ( -- )
    read-unparsed-string eval-string dump-stack ;