From a1311ef2995837ef218a9019aeb3aae4dd53d717 Mon Sep 17 00:00:00 2001 From: crc Date: Thu, 1 Oct 2020 17:15:32 +0000 Subject: [PATCH] examples: add retro.retro (for issue #7) FossilOrigin-Name: baae765aef43bc284e824b2490ca0c62bf819dd664a5ba899ca1cd1d2513e911 --- RELEASE-NOTES | 5 + example/retro.retro | 245 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 250 insertions(+) create mode 100755 example/retro.retro diff --git a/RELEASE-NOTES b/RELEASE-NOTES index d203afa..eebf828 100644 --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -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 diff --git a/example/retro.retro b/example/retro.retro new file mode 100755 index 0000000..ac7db88 --- /dev/null +++ b/example/retro.retro @@ -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 +~~~