From a76977af62010a392c16010c367185e61e856ffe Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Wed, 30 Oct 2019 20:04:56 +0100 Subject: mv to docs --- docs/j1demo/firmware/crossj1.fs | 527 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 527 insertions(+) create mode 100644 docs/j1demo/firmware/crossj1.fs (limited to 'docs/j1demo/firmware/crossj1.fs') diff --git a/docs/j1demo/firmware/crossj1.fs b/docs/j1demo/firmware/crossj1.fs new file mode 100644 index 0000000..d034611 --- /dev/null +++ b/docs/j1demo/firmware/crossj1.fs @@ -0,0 +1,527 @@ +( Cross-compiler for the J1 JCB 13:12 08/24/10) +decimal + +( outfile is fileid or zero JCB 12:30 11/27/10) + +0 value outfile + +: type ( c-addr u ) + outfile if + outfile write-file throw + else + type + then +; +: emit ( u ) + outfile if + pad c! pad 1 outfile write-file throw + else + emit + then +; +: cr ( u ) + outfile if + s" " outfile write-line throw + else + cr + then +; +: space bl emit ; +: spaces dup 0> if 0 do space loop then ; + +vocabulary j1assembler \ assembly storage and instructions +vocabulary metacompiler \ the cross-compiling words +vocabulary j1target \ actual target words + +: j1asm + only + metacompiler + also j1assembler definitions + also forth ; +: meta + only + j1target also + j1assembler also + metacompiler definitions also + forth ; +: target + only + metacompiler also + j1target definitions ; + +\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + +j1asm + +: tcell 2 ; +: tcells tcell * ; +: tcell+ tcell + ; +65536 allocate throw constant tflash + +: h# + base @ >r 16 base ! + 0. bl parse >number throw 2drop postpone literal + r> base ! ; immediate + +variable tdp +: there tdp @ ; +: islegal dup h# 7fff u> abort" illegal address" ; +: tc! islegal tflash + c! ; +: tc@ islegal tflash + c@ ; +: t! islegal over h# ff and over tc! swap 8 rshift swap 1+ tc! ; +: t@ islegal dup tc@ swap 1+ tc@ 8 lshift or ; +: talign tdp @ 1 + h# fffe and tdp ! ; +: tc, there tc! 1 tdp +! ; +: t, there t! tcell tdp +! ; +: org tdp ! ; + +tflash 65536 255 fill + +65536 cells allocate throw constant references +: referenced cells references + 1 swap +! ; + +65536 cells allocate throw constant labels +labels 65536 cells 0 fill +: atlabel? ( -- f = are we at a label ) + labels there cells + @ 0<> +; + +: preserve ( c-addr1 u -- c-addr ) + dup 1+ allocate throw dup >r + 2dup c! 1+ + swap cmove r> ; + +: setlabel ( c-addr u -- ) + atlabel? if 2drop else preserve labels there cells + ! then ; + +j1asm + +: hex-literal ( u -- c-addr u ) s>d <# bl hold #s [char] $ hold #> ; + +: imm h# 8000 or t, ; + +: T h# 0000 ; +: N h# 0100 ; +: T+N h# 0200 ; +: T&N h# 0300 ; +: T|N h# 0400 ; +: T^N h# 0500 ; +: ~T h# 0600 ; +: N==T h# 0700 ; +: N>T h# 0900 ; +: T-1 h# 0a00 ; +: rT h# 0b00 ; +: [T] h# 0c00 ; +: N<N h# 0080 or ; +: T->R h# 0040 or ; +: N->[T] h# 0020 or ; +: d-1 h# 0003 or ; +: d+1 h# 0001 or ; +: r-1 h# 000c or ; +: r-2 h# 0008 or ; +: r+1 h# 0004 or ; + +: alu h# 6000 or t, ; + +: return T h# 1000 or r-1 alu ; +: ubranch 2/ h# 0000 or t, ; +: 0branch 2/ h# 2000 or t, ; +: scall 2/ h# 4000 or t, ; + +: dump-words ( c-addr n -- ) \ Write n/2 words from c-addr + dup 6 > abort" invalid byte count" + 2/ dup >r + 0 do + dup t@ s>d <# # # # # #> type space + 2 + + loop drop + 3 r> - 5 * spaces +; + +variable padc +: pad+ ( c-addr u -- ) \ append to pad + dup >r + pad padc @ + swap cmove + r> padc +! ; + +: pad+loc ( addr -- ) + dup cells labels + @ ?dup if + nip count pad+ + else + s>d <# #s [char] $ hold #> pad+ + then + s" " pad+ +; + + +: disassemble-j + 0 padc ! + dup t@ h# 8000 and if + s" LIT " pad+ + dup t@ h# 7fff and hex-literal pad+ exit + else + dup t@ h# e000 and h# 6000 = if + s" ALU " pad+ + dup t@ pad+loc exit + else + dup t@ h# e000 and h# 4000 = if + s" CALL " + else + dup t@ h# 2000 and if + s" 0BRANCH " + else + s" BRANCH " + then + then + pad+ + dup t@ h# 1fff and 2* pad+loc + then + then +; + +: disassemble-line ( offset -- offset' ) + dup cells labels + @ ?dup if s" \ " type count type cr then + dup s>d <# # # # # #> type space + dup 2 dump-words + disassemble-j + pad padc @ type + 2 + + cr +; + +: disassemble-block + 0 do + disassemble-line + loop + drop +; + +j1asm + +\ tcompile is like "STATE": it is true when compiling + +variable tcompile +: tcompile? tcompile @ ; +: +tcompile tcompile? abort" Already in compilation mode" 1 tcompile ! ; +: -tcompile 0 tcompile ! ; + +: (literal) + \ dup $f rshift over $e rshift xor 1 and throw + dup h# 8000 and if + h# ffff xor recurse + ~T alu + else + h# 8000 or t, + then + +; +: (t-constant) + tcompile? if + (literal) + then +; + +meta + +\ Find name - without consuming it - and return a counted string +: wordstr ( "name" -- c-addr u ) + >in @ >r bl word count r> >in ! +; + + +: literal (literal) ; immediate +: 2literal swap (literal) (literal) ; immediate +: call, + dup referenced + scall +; + +: t: + talign + wordstr setlabel + create + there , + +tcompile + 947947 + does> + @ + tcompile? if + call, + then +; + +: lookback ( offset -- v ) there swap - t@ ; +: prevcall? 2 lookback h# e000 and h# 4000 = ; +: call>goto dup t@ h# 1fff and swap t! ; +: prevsafe? + 2 lookback h# e000 and h# 6000 = \ is an ALU + 2 lookback h# 004c and 0= and ; \ does not touch RStack +: alu>return dup t@ h# 1000 or r-1 swap t! ; + +: t; 947947 <> if abort" Unstructured" then + true if + atlabel? invert prevcall? and if + there 2 - call>goto + else + atlabel? invert prevsafe? and if + there 2 - alu>return + else + return + then + then + else + return + then + -tcompile +; + +: t;fallthru 947947 <> if abort" Unstructured" then + -tcompile +; + +variable shadow-tcompile +wordlist constant escape]-wordlist +escape]-wordlist set-current +: ] shadow-tcompile @ tcompile ! previous previous ; + +meta + +: [ + tcompile @ shadow-tcompile ! + -tcompile get-order forth-wordlist escape]-wordlist rot 2 + set-order +; + +: : t: ; +: ; t; ; +: ;fallthru t;fallthru ; +: , t, ; +: c, tc, ; + +: constant ( n "name" -- ) create , immediate does> @ (t-constant) ; + +: ]asm + -tcompile also forth also j1target also j1assembler ; +: asm[ +tcompile previous previous previous ; +: code t: ]asm ; + +j1asm + +: end-code + 947947 <> if abort" Unstructured" then + previous previous previous ; + +meta + +\ Some Forth words are safe to use in target mode, so import them + +: ( postpone ( ; +: \ postpone \ ; + +: import ( "name" -- ) + >in @ ' swap >in ! + create , does> @ execute ; + +import meta +import org +import include +import [if] +import [else] +import [then] + +: do-number ( n -- |n ) + state @ if + postpone literal + else + tcompile? if + (literal) + then + then +; + +decimal + +: [char] ( "name" -- ) ( run: -- ascii) char (literal) ; + +: ['] ( "name" -- ) ( run: -- xt ) + ' tcompile @ >r -tcompile execute r> tcompile ! + dup referenced + (literal) +; + +: (sliteral--h) ( addr n -- ptr ) ( run: -- eeaddr n ) + s" sliteral" evaluate + there >r + dup tc, + 0 do count tc, loop + drop + talign + r> +; + +: (sliteral) (sliteral--h) drop ; +: s" ( "ccc" -- ) ( run: -- eaddr n ) [char] " parse (sliteral) ; +: s' ( "ccc" -- ) ( run: -- eaddr n ) [char] ' parse (sliteral) ; + +: create + wordstr setlabel + create there , + does> @ do-number +; + +: allot tdp +! ; + +: variable wordstr setlabel create there , 0 t, + does> @ do-number ; +: 2variable wordstr setlabel create there , 0 t, 0 t, + does> @ do-number ; + +: createdoes + wordstr setlabel + create there , ' , + does> dup @ dup referenced (literal) cell+ @ execute +; + +: jumptable + wordstr setlabel + create there , + does> s" 2*" evaluate @ dup referenced (literal) s" + @" evaluate +; + +: | ' execute dup referenced t, ; + +: ', ' execute t, ; + +( DEFER JCB 11:18 11/12/10) + +: defer + wordstr setlabel + create there , 0 t, + does> @ tcompile? if do-number s" @ execute" evaluate then ; + +: is ( xt "name" -- ) + tcompile? if + ' >body @ do-number + s" ! " evaluate + else + ' execute t! + then ; + +: ' ' execute ; + +( VALUE JCB 13:06 11/12/10) + +: value + wordstr setlabel + create there , t, + does> @ do-number s" @" evaluate ; + +: to ( u "name" -- ) + ' >body @ do-number s" !" evaluate ; + +( ARRAY JCB 13:34 11/12/10) + +: array + wordstr setlabel + create there , 0 do 0 t, loop + does> s" cells" evaluate @ do-number s" +" evaluate ; +: 2array + wordstr setlabel + create there , 2* 0 do 0 t, loop + does> s" 2* cells" evaluate @ do-number s" +" evaluate ; + +( eforth's way of handling constants JCB 13:12 09/03/10) + +: sign>number + over c@ [char] - = if + 1- swap 1+ swap + >number + 2swap dnegate 2swap + else + >number + then +; + +: base>number ( caddr u base -- ) + base @ >r base ! + sign>number + r> base ! + dup 0= if + 2drop drop do-number + else + 1 = swap c@ [char] . = and if + drop dup do-number 16 rshift do-number + else + -1 abort" bad number" + then + then ; + +: d# 0. bl parse 10 base>number ; +: h# 0. bl parse 16 base>number ; + +( Conditionals JCB 13:12 09/03/10) +: if + there + 0 0branch +; + +: resolve + dup t@ there 2/ or swap t! +; + +: then + resolve + s" (then)" setlabel +; + +: else + there + 0 ubranch + swap resolve + s" (else)" setlabel +; + + +: begin s" (begin)" setlabel there ; +: again + ubranch +; +: until + 0branch +; +: while + there + 0 0branch +; +: repeat + swap ubranch + resolve + s" (repeat)" setlabel +; + +: 0do s" >r d# 0 >r" evaluate there s" (do)" setlabel ; +: do s" 2>r" evaluate there s" (do)" setlabel ; +: loop + s" looptest" evaluate 0branch +; +: i s" r@" evaluate ; + +77 constant sourceline# +s" none" 2constant sourcefilename + +: line# sourceline# (literal) ; +create currfilename 1 cells 80 + allot +variable currfilename# +: savestr ( c-addr u dst -- ) 2dup c! 1+ swap cmove ; +: getfilename sourcefilename currfilename count compare 0<> + if + sourcefilename 2dup currfilename savestr (sliteral--h) currfilename# ! + else + currfilename# @ dup 1+ (literal) tc@ (literal) + then ; +: snap line# getfilename s" (snap)" evaluate ; immediate +: assert 0= if line# sourcefilename (sliteral) s" (assert)" evaluate then ; immediate -- cgit v1.2.3