( 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
