#!/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 ; }} ~~~

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 ; ~~~

~~~'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 ~~~

~~~: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_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 script:get-argument   [ [ ASCII:SPACE s:tokenize       [ valid? [ to-TIB process ] &drop choose ] a:for-each       progress     ] gc ] unu nl ~~~

~~~'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 ~~~