add retro-extend written in retro

FossilOrigin-Name: 454964c4c38d225882f00a27d4902a6ba18ef4489ce551942ee2814b079f6381

Makefile

@@ -11,7 +11,7 @@ RIIO ?= io/filesystem.o io/floatingpoint.o io/gopher.o io/unix.o
 
 all: build
 
-build: dirs bin/retro-embedimage bin/retro-extend bin/retro-injectimage-js bin/retro-muri bin/RETRO12.html bin/retro bin/retro-repl bin/retro-unu
+build: dirs bin/retro-embedimage bin/retro-extend bin/retro-injectimage-js bin/retro-muri bin/RETRO12.html bin/retro bin/retro-ri bin/retro-repl bin/retro-unu
 
 dirs:
 	mkdir -p bin

RELEASE_NOTES.md

@@ -91,6 +91,7 @@
 - add net_fetch.forth
 - add paste.forth
 - add Paste_to_Sprunge.forth
+- add retro-extend.forth
 - add Save_and_Restore_Stack.forth
 - add share.forth and shared.forth
 - add uuencode.forth

tools/retro-extend.forth

@@ -0,0 +1,249 @@
+#!/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
+'interpret var
+~~~
+
+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 [ #65535 #4 * >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      >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?
+  [ &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.
+
+Todo: the address of `err:notfound` shouldn't be hard coded
+here.
+
+~~~
+:process-packed-opcode (n-)
+  @IP #339 eq? [ #1025 &Image + s:put sp $? c:put nl ] 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 + ;
+
+:load-image (s-)
+  file:R file:open !FID
+  &Image @FID file:size #4 / [ read-cell over store n:inc ] times drop
+  @FID dup file:size #4 / n:put '_cells s:put nl file:close ;
+
+'ngaImage load-image
+~~~
+
+# Map in Functions
+
+~~~
+'Find_`interpret`... s:put
+:image:Dictionary &Image #2 + ;
+image:Dictionary fetch
+  [ repeat fetch 0; dup d:name 'interpret s:eq?
+    [ dup d:xt fetch !interpret ] if again ] call
+'_@_ s:put @interpret n:put nl
+~~~
+
+# Process the Extensions
+
+~~~
+#0 sys:argv
+  [ &Heap
+    [ ASCII:SPACE s:tokenize
+      [ dup s:length n:zero? &drop [ TIB s:copy #1025 >s @interpret execute ] choose $. c:put  ] set:for-each
+    ] v:preserve ] 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
+  @FID file:close ;
+
+'ngaImage2 save-image
+~~~