536 lines
10 KiB
Forth
536 lines
10 KiB
Forth
( 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 ! ;
|
|
|
|
65536 cells allocate throw constant references
|
|
: referenced cells references + 1 swap +! ;
|
|
|
|
65536 cells allocate throw constant labels
|
|
: atlabel? ( -- f = are we at a label )
|
|
labels there cells + @ 0<>
|
|
;
|
|
|
|
: coldcross
|
|
tflash 65536 255 fill
|
|
labels 65536 cells 0 fill
|
|
;
|
|
|
|
coldcross
|
|
|
|
: 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 ;
|
|
: swabT 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 included
|
|
import marker
|
|
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)
|
|
|
|
: label: ( "name" -- ) create there , immediate does> @ (t-constant) ;
|
|
|
|
: 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
|