mirror of
https://git.sr.ht/~crc_/retroforth
synced 2024-11-16 19:48:56 +01:00
267 lines
6.4 KiB
Text
Executable file
267 lines
6.4 KiB
Text
Executable file
#!/usr/bin/env retro
|
|
|
|
There are two parts to building a Retro image. The first is the
|
|
assembly of the kernel using `retro-muri`. The second is to use
|
|
the kernel words and build up a complete image. I use this tool
|
|
(or an equivilent in C) for this.
|
|
|
|
# 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 in Retro
|
|
|
|
Since this is written in Retro and builds a new image, I need
|
|
to keep the two instances separate. To do this, I implement a
|
|
version of the Nga virtual machine in Retro. This will execute
|
|
code in the new image.
|
|
|
|
So first, allocate a memory region for the new image and
|
|
stacks. I also create variables to hold the instruction and
|
|
stack pointers.
|
|
|
|
~~~
|
|
#65535 #4 * 'IMAGE-SIZE const
|
|
|
|
'Image d:create IMAGE-SIZE allot
|
|
'DataStack d:create #1024 allot
|
|
'ReturnStack d:create #4096 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 Kernel
|
|
|
|
~~~
|
|
'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
|
|
size n:put '_cells_loaded s:put nl
|
|
@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-)
|
|
dup '__`%s`... s:format s:put
|
|
xt-for over store
|
|
'_@_ s:put fetch n:put nl ;
|
|
|
|
'Find: s:put nl
|
|
&t:interpret 'interpret map
|
|
&t:notfound 'err:notfound map
|
|
~~~
|
|
|
|
# Process the Extensions
|
|
|
|
~~~
|
|
'Process_Tokens s:put nl
|
|
|
|
: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? ;
|
|
:progress $. c:put ;
|
|
|
|
#0 sys:argv
|
|
[ [ ASCII:SPACE s:tokenize
|
|
[ valid? [ to-TIB process ] &drop choose ] a:for-each
|
|
progress
|
|
] gc ] unu nl
|
|
~~~
|
|
|
|
# Save the Image
|
|
|
|
~~~
|
|
'FID var
|
|
|
|
:write-byte (n-) @FID file:write ;
|
|
:mask (n-) #255 and ;
|
|
|
|
:write-cell (n-)
|
|
dup mask write-byte
|
|
#8 shift dup mask write-byte
|
|
#8 shift dup mask write-byte
|
|
#8 shift mask write-byte ;
|
|
|
|
:save-image (s-)
|
|
file:W file:open !FID
|
|
&Image &Image #3 + fetch [ fetch-next write-cell ] times drop
|
|
&Image #3 + fetch n:put sp 'cells_written s:put nl
|
|
@FID file:close ;
|
|
|
|
'ngaImage2 save-image
|
|
~~~
|