#!/usr/bin/env retro
This implements a minimal version of the Nga virtual machine,
Unu source preprocessor, and the generic output (to stdout)
device. Effectively, it lets you run a RETRO source file and
then exits.
The useful bit is that the entire thing is written in RETRO,
so it provides a way to sandbox things, at the expense of
performance (since it's now emulating a MISC system on an
already emulated MISC system).
Configuration
~~~#65535 #2 * 'IMAGE-SIZE const
#1024 'STACK-SIZE const
~~~
Unu
Since sources are written in a literate format I have a version
of the retro-unu tool included here. This will run a quote on
each line in the source that is a fenced region.
~~~{{
'Fenced var
:toggle-fence @Fenced not !Fenced ;
:fenced? (-f) @Fenced ;
:handle-line (s-)
fenced? [ over call ] [ drop ] choose ;
---reveal---
:unu (sq-)
swap [ dup '~~~ s:eq?
[ drop toggle-fence ]
[ handle-line ] choose
] file:for-each-line drop ;
}}
~~~
Allocate a memory region for the new image and stacks. I
also create variables to hold the instruction and stack
pointers.
The image size is capped at 128K cells; adjust here if
you want or need a larger image.
~~~'Image d:create IMAGE-SIZE allot
'DataStack d:create STACK-SIZE allot
'ReturnStack d:create STACK-SIZE allot
'SP var
'RP var
'IP var
~~~
There are a few items in the kernel I need to access as this
progresses. I will fill in the value for interpret later.
~~~#1025 &Image + 'TIB const
#367 't:interpret var-n
#339 't:notfound var-n
~~~
I next define helpers to move values to/from the host data
stack to the target ones.
~~~:>s (n-) &DataStack @SP + store &SP v:inc ;
:s> (-n) &SP v:dec &DataStack @SP + fetch ;
:>r (n-) &ReturnStack @RP + store &RP v:inc ;
:r> (-n) &RP v:dec &ReturnStack @RP + fetch ;
~~~
One more helper here: a word to return the value that the
IP register points to in the target memory.
~~~:[IP] @IP &Image + fetch ;
~~~
Ok, now for the instructions. See the Nga documentation
for these. Basically I just move things to/from the target
stacks, use the host words, then push the updated values
back.
~~~:i:no ;
:i:li &IP v:inc [IP] >s ;
:i:du s> dup >s >s ;
:i:dr s> drop ;
:i:sw s> s> swap >s >s ;
:i:pu s> >r ;
:i:po r> >s ;
:i:ju s> n:dec !IP ;
:i:ca @IP >r i:ju ;
:i:cc s> s> [ >s i:ca ] [ drop ] choose ;
:i:re r> !IP ;
:i:eq s> s> eq? >s ;
:i:ne s> s> -eq? >s ;
:i:lt s> s> swap lt? >s ;
:i:gt s> s> swap gt? >s ;
:i:fe s> #-1 [ @SP >s ] case
#-2 [ @RP >s ] case
#-3 [ IMAGE-SIZE >s ] case
&Image + fetch >s ;
:i:st s> s> swap &Image + store ;
:i:ad s> s> + >s ;
:i:su s> s> swap - >s ;
:i:mu s> s> * >s ;
:i:di s> s> swap /mod swap >s >s ;
:i:an s> s> and >s ;
:i:or s> s> or >s ;
:i:xo s> s> xor >s ;
:i:sh s> s> swap shift >s ;
:i:zr s> dup n:zero? [ drop i:re ] [ >s ] choose ;
:i:en #0 !RP ;
:i:ie #1 >s ;
:i:iq #0 dup >s >s ;
:i:ii s> s> nip c:put ;
~~~
As with the C implementation, I use a jump table to map the
instructions to their handlers.
~~~'Instructions d:create
&i:no , &i:li , &i:du , &i:dr , &i:sw , &i:pu ,
&i:po , &i:ju , &i:ca , &i:cc , &i:re , &i:eq ,
&i:ne , &i:lt , &i:gt , &i:fe , &i:st , &i:ad ,
&i:su , &i:mu , &i:di , &i:an , &i:or , &i:xo ,
&i:sh , &i:zr , &i:en , &i:ie , &i:iq , &i:ii ,
~~~
Now to actually process the instructions. Instructions are
packed, so I need a word to unpack them. This is a simple
matter of shifting and masking.
~~~{{
:mask #255 and ;
:next #8 shift ;
---reveal---
:unpack (n-dcba)
dup mask swap next
dup mask swap next
dup mask swap next
'abcd 'dcba reorder ;
}}
~~~
Processing of a single opcode is next. This will do some
validation to make sure the opcode is in the expected range.
~~~:process-single-opcode (n-)
dup #0 #29 n:between?
[ 0; &Instructions + fetch call ]
[ 'Invalid_Instruction:_%n_! s:format s:put nl ] choose ;
~~~
And then a word to process a packed opcode. This also traps
the err:notfound to report on word-not-found conditions.
~~~:notfound? (-f) @IP @t:notfound eq? ;
:display (-) #1025 &Image + s:put sp $? c:put nl ;
:process-packed-opcode (n-)
notfound? [ display ] if
unpack
process-single-opcode
process-single-opcode
process-single-opcode
process-single-opcode ;
~~~
The final part of running code in the target is the
execute word. This will run through code until the
top level word called returns.
~~~:execute (a-)
!IP #0 >r
[ [IP] process-packed-opcode &IP v:inc
@RP n:zero? ] until ;
~~~
~~~'FID var
:read-byte (n-) @FID file:read #255 and ;
:read-cell (-n)
read-byte read-byte read-byte read-byte
#-8 shift + #-8 shift + #-8 shift + ;
:size (-n) @FID file:size #4 / ;
:load-image (s-)
file:R file:open !FID
&Image size [ read-cell over store n:inc ] times drop
@FID file:close ;
'ngaImage load-image
~~~
~~~:image:Dictionary &Image #2 + ;
:xt-for (s-a)
here store
image:Dictionary fetch &Image +
[ repeat fetch 0; &Image + dup d:name here fetch s:eq?
[ dup d:xt fetch here n:inc store ] if again ] call
here n:inc fetch ;
:map (as-)
xt-for swap store ;
&t:interpret 'interpret map
&t:notfound 'err:notfound map
~~~
~~~:gc (a-) &Heap swap v:preserve ;
:to-TIB (s-) TIB s:copy ;
:process #1025 >s @t:interpret execute ;
:valid? (s-sf) dup s:length n:-zero? ;
#0 script:get-argument
[ [ ASCII:SPACE s:tokenize
[ valid? [ to-TIB process ] &drop choose ] a:for-each
] gc ] unu nl
~~~