examples: add retro.retro (for issue #7)
FossilOrigin-Name: baae765aef43bc284e824b2490ca0c62bf819dd664a5ba899ca1cd1d2513e911
This commit is contained in:
crc
parent
c38f11224e
commit
a1311ef299
2 changed files with 250 additions and 0 deletions
|
|
@ -48,3 +48,8 @@ Documentation
|
|||
|
||||
- removed reference to old Makefile that no longer exists
|
||||
- updates word namings for deprecated words that have been removed
|
||||
|
||||
Examples
|
||||
|
||||
- add: markdown to xhtml
|
||||
- add: retro in retro
|
||||
|
|
|
|||
245
example/retro.retro
Executable file
245
example/retro.retro
Executable file
|
|
@ -0,0 +1,245 @@
|
|||
#!/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 ;
|
||||
}}
|
||||
~~~
|
||||
|
||||
# Nga Virtual Machine
|
||||
|
||||
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 ;
|
||||
~~~
|
||||
|
||||
# Load the Image
|
||||
|
||||
~~~
|
||||
'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
|
||||
~~~
|
||||
|
||||
# Map in Functions
|
||||
|
||||
~~~
|
||||
: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
|
||||
~~~
|
||||
|
||||
# Process the Extensions
|
||||
|
||||
~~~
|
||||
: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
|
||||
~~~
|
||||
Loading…
Reference in a new issue