123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527 |
- ( 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# 0800 ;
- : N>>T h# 0900 ;
- : T-1 h# 0a00 ;
- : rT h# 0b00 ;
- : [T] h# 0c00 ;
- : N<<T h# 0d00 ;
- : dsp h# 0e00 ;
- : Nu<T h# 0f00 ;
- : T->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<quote>" -- ) ( run: -- eaddr n ) [char] " parse (sliteral) ;
- : s' ( "ccc<quote>" -- ) ( 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
|