f4

2000-01-01

Ideas:
maybe '''resolve''' can be replaced by '''postpone'''?

true quiet ! ( be quiet during compilation )


\ the order of definitions is important, must make sure no references to the
\ host dictionary are compiled into the target - or the target will likely
\ crash.


\ set up host and offset on the host for compiling
last @ host cell+ !
dp@ data - offset !


\ for testing of relocation, add some space, so addresses are likely to be
\ different
dp@ 1000 + version cells 3 * + dp!


\ reserve memory for forward resolver
dp@ resolve-start !
dp@ resolve-pos !
dp@ 256 cells + dp!


\ memory map:
\   64 kb .. stack
\   ..
\   6 kb .. dictionary start
\   5 kb .. return stack
\   4 kb .. scratch
\   3 kb .. pad
\   2 kb .. tib
\   1 kb .. control stack
\   0 kb .. system


\ ITC execution


\ this is the heart of the threading model. it takes one xt from the ip address,
\ and jumps to execute the code pointed to by its code field. example:


\ the ip points at location 200, which contains the xt of some word, 300. the xt
\ is the address of the codefield of the word, and points to the actual code,
\ which is found at 400, which contains the actual instruction add.


\ ip -> 200 [300] -> 300 [400] -> 400 [add]
\       204          304          404
\       208          308          408


.\ Compiling base execution words...


?\ Jumps to the next ITC word.
code next ( -- )


  *arg 0 , *arg 6 , *fun             ( debugger )


  *ip *mem *dup                ( fetch ip, duplicate it )
  *arg 1 cells , *add *ip *sav ( add one cell, and write into ip )
  *mem *dup *w *sav            ( fetch xt, duplicate it and store in w )
  *mem *hop                    ( read code location, and jump there )
  set-data-length reveal


\ next, define base execution words, now that we have next.


\ This is the code used by all colon-words [high level forth definitions]. It
\ saves the current ip on the return stack, then adjusts it to execute the XTs
\ contained in the datafield of the colon-word, to which w points.


?\ Enter ITC word.
code enter ( -- ) ( r: -- a )


  *arg 1 , *arg 6 , *fun            ( debugger )


  *ip *mem *rp *mem     ( fetch ip and rp )
  *arg 1 cells , *sub *dup          ( subtract a cell, and duplicate )
  *rp *sav *sav               ( update rp, write ip to [rp] )
  *w *mem *arg 1 cells , *add ( read w, add one cell )
  *ip *sav                    ( update ip )
  end-code


\ This is the code used to return from a colon-word. It reads the previous ip
\ from the return stack, then jumps to next to go on executing there.


?\ Exit from ITC word.
code exit ( -- ) ( r: a -- )


  *arg 2 , *arg 6 , *fun             ( debugger )


  *rp *mem *dup                ( fetch rp and duplicate it )
  *arg 1 cells , *add *rp *sav ( add a cell to rp )
  *mem *ip *sav                ( write [rp] to ip )
  end-code


?\ Given an xt on the stack, executes the word identified by it.
code execute ( a -- )
  *dup *w *sav ( save xt in w )
  *mem *hop          ( read code address, jump there )
  set-data-length reveal


?\ Puts an inline literal to the stack.
code dolit ( -- x )
  *ip *mem *dup                ( fetch ip, duplicate )
  *arg 1 cells , *add *ip *sav ( add a cell, write back )
  *mem                               ( read the literal )
  end-code


?\ Compiles an inline literal.
code docom ( -- x )
  *ip *mem *dup                ( fetch ip, duplicate )
  *arg 1 cells , *add *ip *sav ( add a cell, write back )
  *mem                               ( read the literal )
  *dp *mem *dup                ( fetch dp, duplicate )
  *arg 1 cells , *add *dp *sav ( add a cell, write back )
  *sav                               ( write literal to [dp] )
  end-code


?\ Puts contents of first data field cell to stack.
code docon ( -- x )
  *w *mem *arg 1 cells , *add ( fetch w and add cell )
  *mem
  end-code


?\ Puts address of data field to stack.
code dovar ( -- a )
  *w *mem *arg 1 cells , *add ( fetch w and add cell )
  end-code


( jump to an inline address. )
code branch ( -- )
  *ip *mem *mem *ip *sav ( store [ip] to ip )
  end-code


( jump to an inline address if true . )
code ?branch ( b -- )
  *arg 0 , *equ
  *pos *arg 14 cells , *add          ( add 14 cells to current ip ) ( -1 )
  *bra                               ( jump away if stack is true ) ( 3 )
  *ip *mem *mem *ip *sav ( store [ip] to ip ) ( 4 )
  *arg ' next >body , *hop           ( jump to next ) ( 11 )
  *ip *mem *arg 1 cells , *add ( fetch ip, add cell ) ( 14 )
  *ip *sav                     ( write back )
  end-code


.\ Compiling return stack words...


( easy by making them code-words, else couldn't touch the top stack. )


code >r ( x -- ) ( r: -- x )
  *rp *mem           ( fetch rp )
  *arg 1 cells , *sub *dup ( subtract cell, duplicate )
  *rp *sav *sav      ( update rp, store x )
  end-code


code r> ( -- x ) ( r: x -- )
  *rp *mem *dup                ( fetch rp, duplicate )
  *arg 1 cells , *add *rp *sav ( add cell, update rp )
  *mem                               ( read x )
  end-code


code rdrop ( r: x -- )
  *rp *mem                     ( fetch rp )
  *arg 1 cells , *add *rp *sav ( add cell, update rp )
  end-code


code r@ ( -- x )
  *rp *mem *mem ( fetch rp, read x )
  end-code


.\ Compiling stack code words...


?\ Drops top stack value.
code drop ( x -- ) *del end-code
?\ Duplicates the top stack value.
code dup ( x -- x x ) *dup end-code
code 2dup ( x y -- x y x y ) *arg 1 , *reg *arg 1 , *reg end-code
code 3dup ( x y z -- x y z x y z ) *arg 2 , *reg *arg 2 , *reg *arg 2 , *reg end-code
code over ( x y -- x y x ) *arg 1 , *reg end-code
code tuck ( x y -- y x y ) *arg 1 , *reg *arg 1 , *reg *arg 2 , *set
  *arg 0 , *set *arg 1 , *reg end-code
code pick ( x .. n -- x .. x ) *reg end-code
?\ Swaps top stack values.
code swap ( x y -- y x ) *arg 1 , *reg *arg 1 , *reg *arg 2 , *set
  *arg 0 , *set end-code
code 2swap ( x y a b -- a b x y ) *arg 3 , *reg *arg 2 , *reg *arg 4 , *set
  *arg 1 , *set *arg 2 , *reg *arg 1 , *reg *arg 3 , *set *arg 0 , *set end-code
code rot ( x y z -- y z x ) *arg 2 , *reg *arg 2 , *reg *arg 3 , *set *arg 1 ,
  *reg *arg 2 , *set *arg 0 , *set end-code


.\ Compiling math code words...


code + ( x x -- x ) *add end-code
code - ( x x -- x ) *sub end-code
code * ( x x -- x ) *mul end-code
code / ( x x -- x ) *div end-code
code mod ( x x -- x ) *mod end-code
code = ( x x -- x ) *equ end-code
code < ( x x -- x ) *low end-code
code > ( x x -- x ) *grt end-code
code negate ( x -- x ) *neg end-code
code not ( x -- x ) *bin end-code
code and ( x -- x ) *ban end-code
code or ( x -- x ) *bor end-code
code xor ( x -- x ) *xor end-code
code rshift ( x n -- x ) *los end-code
code lshift ( x n -- x ) *his end-code
code 1+ ( x -- x ) *arg 1 , *add end-code


.\ Compiling memory code words...
code @ ( a -- x ) *mem end-code
code ! ( x a -- ) *sav end-code
code c@ ( a -- c ) *fby end-code
code c! ( c a -- ) *sby end-code


.\ Compiling input/output/external code words...
code key *get end-code
code emit *put end-code
code function ( ? x -- ? ) *fun end-code


( miscellaneous code words )
code stacklen *num end-code


.\ Compiling more stack/math/memory words...


?\ Adds x to the value at address a.
: +! ( x a -- ) dup @ rot + swap ! ;
: c+! ( c a -- ) dup c@ rot + swap c! ;
: /mod ( x x -- x x ) 2dup mod rot rot / ;


: 2drop drop drop ;
: 3drop 2drop drop ;


.\ Compiling constants...


1024 constant controlstack
2048 constant tib
3072 constant pad
4096 constant scratch
5120 constant returnstack
6144 constant data


1024 constant returnstacklen
1024 constant controlstacklen
1024 constant scratchlen


-1 constant true
0 constant false


.\ Compiling variables...


?\ Stores codefield address.
variable w
?\ The ITC code position.
variable ip
?\ Return stack pointer.
variable rp
?\ Control stack pointer.
variable cp
?\ Dictionary pointer.
variable dp
?\ Compilation state.
variable state
?\ Position inside TIB.
variable >in
?\ Number of characters in TIB.
variable #tib


?\ Standard wordlist.
variable forth 0 ,


?\ Points to the last word added to the dictionary.
variable last


?\ Points to wordlist into which new words are compiled.
variable current
?\ Points to wordlist which is used to find words.
variable context


?\ Relocation offset for compiled code.
variable offset


?\ wordlist containing the host words.
variable host 0 ,


.\ Compiling some helpers...


: ip@ ip @ ;
: ip! ip ! ;
: rp@ rp @ ;
: rp! rp ! ;
: dp@ dp @ ;
: dp! dp ! ;
: cp@ cp @ ;
: cp! cp ! ;


( cells/alignment )


: cells ( x -- x ) 4 * ;
: cell+ ( a -- a ) 4 + ;
: cell+! ( a -- ) dup @ cell+ swap ! ;
: cell- ( a -- a ) 4 - ;
: aligned ( a -- a ) 3 + 3 not and ;


( dictionary )


: here ( -- a ) dp@ ;
: , ( x -- ) dp@ ! dp@ cell+ dp! ;
: c, ( c -- ) dp@ c! dp@ 1+ dp! ;


( control stack )


: >c ( x -- ) ( c: -- x ) cp@ cell- dup cp! ! ;
: c> ( -- x ) ( c: x -- ) cp@ dup cell+ cp! @ ;
: cdrop ( c: x -- ) cp@ cell+ cp! ;
: cs@ ( -- x ) cp@ @ ;
: cswap ( c: x y -- y x ) c> c> swap >c >c ;


( miscellaneous )


: ?dup ( x -- 0 | x x ) dup 0 = not if dup then ;
: sign ( s -- s ) dup 0 < if drop -1 else 0 > if 1 else 0 then then ;
: min ( x y -- z ) { 2dup < if } drop else swap drop then ;
: max ( x y -- z ) { 2dup > if } drop else swap drop then ;


( runtime words )


: (do) ( x y --  c: -- x y ) swap >c >c ;
: (?do) ( x y -- b  c: -- x y ) 2dup swap >c >c = ;
: (loop) ( -- b )  c> 1 + dup c> dup >c = swap >c not ;
: (loopdone) ( c: x y -- ) cdrop cdrop ;


.\ Compiling string words...


?\ get counted string address and character count.
: count ( a -- a n ) dup 1 + swap c@ ;


?\ type n characters beginning at address a.
: type ( a n -- ) 0 ?do dup c@ emit 1 + loop drop ;


: print ( a -- ) count type ;


( string comparison )


?\ convert character to uppercase.
: cupper ( x -- y )
    dup [char] a < if exit then
    dup [char] z > if exit then
    [char] a -
    [char] a +
    ;


?\ convert character to lowercase.
: clower ( x -- y )
    dup [char] a < if exit then
    dup [char] z > if exit then
    [char] a -
    [char] a +
    ;


: stringop ( a n a1 -- ) rot rot 0 ?do 2dup c@ swap execute over c! 1+ loop 2drop ;


?\ make string all uppercase.
: upper ( a n -- ) ['] cupper stringop ;


?\ make string all lowercase.
: lower ( a n -- )
    0 ?do dup c@ clower over c! 1+ loop drop ;


( return if character [a] is equal [0], lower [-1] or greater [+1] to [b] .)
: ccompare ( a b -- a+1 b+1 [a]==[b] )
  swap dup c@ swap 1 + swap rot ( a+1 [a] b )
       dup c@ swap 1 + swap rot ( a+1 b+1 [b] [a] ) swap - sign ;


?\ return 0 if n identical chars, else sign of first different char.
: ncompare ( a b n -- x )
  0 swap 0
  ?do drop ccompare dup 0 = not if leave then loop
  ( a b r ) swap drop swap drop ;


\ if the strings match in the first characters up to the shorter file, return 0
\ if n = m, -1 if n < m, +1 if m < n. else, return -1/+1 depending on the first
\ non-matching character.
?\ return 0 if the strings match to the length of the shorter.
: compare ( a n b m -- x )
  rot 2dup < if drop ncompare dup 0 = if drop -1 then else
      2dup > if drop ncompare dup 0 = if drop 1 then else
                drop ncompare then
      then ;


?\ Compare two counted strings.
: scompare ( a b -- x ) swap count rot count compare ;


?\ Move n characters from a1 to a2.
: cmove ( a1 a2 n -- )
    0 ?do over c@ over c! swap 1 + swap 1 + loop 2drop ;


?\ Append a1 to a2.
: cappend ( a1 n1 a2 n2 -- )
    + swap cmove ;


.\ Compiling dictionary handling words...


\ Dictionary format: Linked list of:
\  link name extra flags code data
\  0    4    8     12    16   20
\  - link links to the previous entry
\  - name points to a counted string
\  - extra points to this:
\    0     4    8   12
\    calls end  doc stack
\    - calls counts the number of times the word was called
\    - end stores the position after the end of the words data field
\    - doc points to a counted string
\    - stack is a counted string
\  - flags contains the immediacy flag
\  - code is the ITC word entry point
\  - data is a variable amount of data to follow


( navigate inside dictionary entry )
: link> ( a -- a ) 4 cells + ;
: name> ( a -- a ) 3 cells + ;
: body> ( a -- a ) 1 cells - ;
: >link ( a -- a ) 4 cells - ;
: >name ( a -- a ) 3 cells - ;
: >extra ( a -- a ) 2 cells - ;
: >body ( a -- a ) 1 cells + ;
: l>name ( a -- a ) 1 cells + ;
: l>extra ( a -- a ) 2 cells + ;
: l>flags ( a -- a ) 3 cells + ;
: l>body ( a -- a ) 5 cells + ;


: words ( -- ) last @ begin dup 0 = not while dup l>name @ print 32 emit @
                       repeat drop ;


.\ Compiling parsing words...


: bl 32 ;
: nl 10 ;


( parse characters delimited by c, return position and length inside tib. )
: parse ( c -- a n )
  tib >in @ + swap 0 swap
  ( a 0 c ) begin { >in @ #tib @ < while }
  ( a n c ) tib >in @ { dup 1 + >in ! } + c@
  ( a n c c1 ) over = if drop exit then
  ( a n c ) swap 1 + swap
  repeat
  drop
  ;


( skip whitespace inside tib. )
: skip-whitespace
  begin
  { tib >in @ + c@ bl = } { >in @ #tib @ < } and while
  >in @ 1 + >in !
  repeat
  ;


( like parse, but skip leading whitespace. )
: parse-word ( -- a n )
  skip-whitespace
  bl
  parse
  ;


.\ Compiling lookup words...


?\ Gets the XT for a string in wordlist w.
: lookup-vocabulary ( a n w -- a n 0 | x 1 | x -1 )


  5 function


\  cell+ @ begin


\  dup 0 = not while ( dictionary entry not 0 )


\  ( a n l ) 3dup
\  { l>name @ count compare 0 = if } >r 2drop r>
\  dup link> swap l>flags @ 1 and 1 = if 1 else -1 then exit then
\  @ repeat
;


?\ Gets the XT for a string.
: lookup ( a n -- a n 0 | x 1 | x -1 )
  context @
  lookup-vocabulary ;


?\ Gets the name from an XT.
: lookup-xt ( x -- x 0 | a 1 ) last @ begin
  dup 0 = not while
  ( x l ) 2dup link> = if drop >name @ 1 exit then
  @ repeat ;


: find ( a -- a 0 | x 1 | x -1 )
  count lookup dup 0 = if swap drop then ;


: relocate ( a -- a' )
  offset @ -
  ;


?\ Given an XT in host space, translates it to target space - i.e. the word with
?\ XT at a has XT a' on the target system.
: relocate-xt ( a -- a' )
  dup
  >name @ count lookup ( lookup same name in target dictionary )
  ( a n 0 | x 1 ) 0 = if
    [char] * emit type
  else
    relocate ( relocate it to target space )
    swap drop
  then
  ;


( get xt of token )
: ' ( -- a )
  parse-word lookup
  0 = if
    [char] ? emit type 0 ( todo: exception )
  else
    relocate
  then ;



.\ Compiling compilation words...


?\ Compiles a string into the dictionary.
: string, ( a n -- )
    dp@ rot rot ( remember start address )
    ( a1 a n ) dup c, ( write count )
    ( a1 a n ) dp@ swap cmove ( copy string to dictionary )
    ( a1 ) count + dp! ( adjust dp )
    dp@ aligned dp! ( align dp )
    ;


: char ( -- c ) parse-word 0 > if c@ else drop 0 then ;
: [char] ( -- ) ['] dolit relocate-xt , char , ; immediate


: ['] ( -- ) ['] dolit relocate-xt , ' , ; immediate


: [compile] ( -- ) ' , ; immediate
: compile ( -- )
  ['] docom relocate-xt ,
  ' relocate-xt ,
; immediate


: (") ( -- a n )
    r> dup
    @ swap ( get inline count )
    cell+ 1+ ( get inline address )
    2dup + aligned
    >r
    swap
    ;


?\ Compiles parser string as counted string into the dictionary.
: ," [char] " parse dup , string, ;


?\ Compile an inline string.
: "
    ['] (") relocate-xt , ,"
    ; immediate


variable doc
: doc+ ( a n -- )
    dup doc @ +! ( adjust count )
    doc @ cell+ count cappend ( append to string )
    doc @ @ doc @ cell+ c! ( adjust counted string count )
    doc @ cell+ count + aligned dp! ( adjust dp ) ;
: doc, ( a n -- ) dp@ doc ! dup , string, ;
?\ Provide short doc string for the next to be defined word.
?\ All doc lines until the next definition will be concatenated.
: ?\ ( "EOL" -- ) nl parse doc @ 0 = if doc, else "  " doc+ doc+ then ;


: ( [char] ) parse 2drop ; immediate
: \ 10 parse 2drop ; immediate
: [ 0 state ! ; immediate
: ] -1 state ! ;


?\ Compiles a recursive call.
: recurse last @ link> relocate , ; immediate


( define { and } to do nothing, so we can use them to clarify the code. )
: { ; immediate
: } ; immediate


.\ Compiling defining words...


: prepare-extra ( -- a' )
    dp@ ( remember dp )
    0 , ( counter )
    0 , ( length )
    doc @ dup 0 = not if relocate then , ( doc line pointer )
    0 doc ! ( clear doc line )
    >in @ char [char] ( = not if
        >in ! ( restore tib )
        0 , ( empty comment )
        exit
    then drop
    ( try to parse comment. )
    [char] ) parse
    ( dp a n ) string,
    ;


: prepare-name ( a n -- a' )
    dp@ rot rot ( remember name )
    ( a1 a n ) string,
    ;


?\ Defines a new dictionary entry.
: header ( a n -- )
  2dup type ( output name ) bl emit
  prepare-name
  ( name ) prepare-extra
  dp@ last @ , last ! ( write link field and update last )
  ( name extra ) swap , ( write name field )
  ( extra ) , ( write extra field )
  0 , ( write flags field )
  ;


?\ Make last defined word findable.
: reveal ( -- )
  last @ current @ cell+ ! ;


?\ Compiles a new colon word.
: : ( -- )
    parse-word header
    ['] enter relocate-xt >body , ( make colon word )
    -1 state ! ( change to compile state )
  ;


?\ Updates data length of a word.
: set-data-length ( -- )
    dp@ last @ l>body - 1 cells / last @ l>extra @ cell+ !
    ;


: ; ( -- )
    ['] exit relocate-xt ,
    0 state ! ( change to interpreter state )
    set-data-length
    reveal ; immediate


: immediate 1 last @ l>flags ! ;


( create a constant. )
: constant ( x -- )
  parse-word header
  ['] docon relocate-xt >body ,
  , reveal ;


( create a variable. )
: variable ( -- )
  parse-word header
  ['] dovar relocate-xt >body ,
  0 , reveal ;


: to ( x -- ) parse-word lookup drop >body ! ;


: code ( -- )
  parse-word header
  last @ l>body relocate , ( make code word )
  ( no compile mode )
  ;



.\ Compiling assembly words...
: *bye 1001 , ; ( ? -- )
: *arg 1002 , ; ( -- x )
: *del 1003 , ; ( x -- )
: *reg 1004 , ; ( n -- x )
: *set 1005 , ; ( x n -- )


: *hop dolit [ *hop ] , ; ( a -- )
: *pos dolit [ *pos ] , ; ( -- a )
: *num dolit [ *num ] , ; ( -- n )
: *bra dolit [ *bra ] , ; ( f a -- )
: *and dolit [ *and ] , ; ( f a -- )


: *mem dolit [ *mem ] , ; ( a -- x )
: *sav dolit [ *sav ] , ; ( x a -- )
: *fby dolit [ *fby ] , ; ( a -- c )
: *sby dolit [ *sby ] , ; ( c a -- )
: *put dolit [ *put ] , ; ( c -- )


: *get dolit [ *get ] , ; ( -- c )
: *add dolit [ *add ] , ; ( x x -- x )
: *sub dolit [ *sub ] , ; ( x x -- x )
: *mul dolit [ *mul ] , ; ( x x -- x )
: *div dolit [ *div ] , ; ( x x -- x )


: *mod dolit [ *mod ] , ; ( x x -- x )
: *neg dolit [ *neg ] , ; ( x -- x )
: *ban dolit [ *ban ] , ; ( x x -- x )
: *bor dolit [ *bor ] , ; ( x x -- x )
: *xor dolit [ *xor ] , ; ( x x -- x )


: *bin dolit [ *bin ] , ; ( x -- x )
: *his dolit [ *his ] , ; ( x n -- x )
: *los dolit [ *los ] , ; ( x n -- x )
: *equ dolit [ *equ ] , ; ( x x -- f )
: *grt dolit [ *grt ] , ; ( x x -- f )


: *low dolit [ *low ] , ; ( x x -- f )
: *fun dolit [ *fun ] , ; ( ? -- ? )


( easier to type. )
: *dup ( -- ) *arg 0 , *reg ;


.\ Compiling vocabulary words...


( vocabularies are two cells: link, word )


( simply reserve 2 cells in the dictionary )
: wordlist ( -- a ) dp@ 0 , 0 , ;
: set-current ( a -- ) current ! ;



.\ Compiling numeric conversion words...


( convert a decimal digit to a character. )
: digit ( c -- c ) 48 + ;


( add a character to the numeric output buffer. )
: hold ( c -- ) scratch @ 1 + dup scratch ! negate scratch scratchlen + + c! ;


( initialize numeric conversion. )
: <# ( -- ) 0 scratch c! ;


( add the next decimal digit to the numeric output buffer. )
: # ( x -- x ) 10 /mod swap digit hold ;


( finish numeric conversion, return string address and character count. )
: #> ( x -- a n ) drop scratch 1024 + scratch @ - scratch @ ;


( convert a complete number. )
: #s ( x -- x ) begin # dup 0 = until ;


( add a minus sign if the number is negative. )
: #sign ( x -- ) 0 < if 45 hold then ;


( convert the character at a to its numerical value and advance a, and tell
(  if it was a digit at all.
: >digit ( a -- a+1 x b ) dup 1 + swap c@ [char] 0 - dup 0 < over
  9 > or not ( a+1 x b ) ;


( convert n characters at a to a number. a is increased and n decreased for
(  every converted character.
: >number ( x a n -- x a n )
  begin dup >r 0 > while ( x a ) >digit if ( x a y ) rot 10 * + swap ( x a )
  r> 1 - else drop 1 - r> exit then repeat r> ;


.\ Compiling output words...


: cr 10 emit 13 emit ;
: space bl emit ;


( print a number. )
: . ( x -- ) dup { dup 0 < if } negate then { <# #s } swap #sign #> type ;


( change bash color. )
: color ( x -- ) 27 emit [char] [ emit . [char] m emit ;
: red 31 color ;
: green 32 color ;
: yellow 33 color ;
: blue 34 color ;
: magenta 35 color ;
: cyan 36 color ;
: nocolor 0 color ;


( print a string. )
: .( [char] ) parse type ;
: .\ nl emit 33 color nl parse type 0 color nl emit ;


( output stack contents )
: .s ( -- )
  [char] [ emit space stacklen 0
  begin 2dup > while
  2dup - 4 / 1 + pick . space cell+ repeat 2drop [char] ] emit ;


( output control stack contents )
: .c ( -- )
  [char] [ emit space
  [char] c emit
  [char] : emit space
  controlstack controlstacklen +
  begin dup cp @ > while
  cell- dup @ . space repeat drop
  [char] ] emit ;


( output return stack contents )
: .r ( -- )
  [char] [ emit space
  [char] r emit
  [char] : emit space
  returnstack returnstacklen +
  begin dup rp @ > while
  cell- dup @ . space repeat drop
  [char] ] emit ;



( end codeword definition. needs to be below the asm words. )
: end-code ( -- )
    *arg ['] next relocate-xt >body , *hop
    set-data-length reveal ;


.\ Compiling dictionary inspection words...


: dump-xt ( a -- )
    offset @ 0 = not if
        dup offset @ + lookup-xt ( relocated xt? )
        ( a name b )
        0 = not if
            magenta
            print nocolor drop exit
        then
        drop
        dup offset @ + body> lookup-xt ( relocated code? )
        ( a name b )
        0 = not if
            cyan
            print nocolor drop exit
        then
        drop
    then
    dup lookup-xt ( xt? )
    ( a name b )
    0 = not if
        over @ host cell+ @ > if green else red then
        print nocolor drop exit
    then
    drop
    dup body> lookup-xt ( code address? )
    ( a name b )
    0 = not if
        over @ host cell+ @ > if green else red then
        print nocolor drop exit
    then
    drop
    dup 1000 > if
        dup 1011 < if
            1001 - 3 *
            " byeargdelregsethopposnumbarand"
            drop + 3 blue type nocolor exit then
        dup 1021 < if
            1011 - 3 *
            " memsavfbysbyputgetaddsubmuldiv"
            drop + 3 blue type nocolor exit then
        dup 1031 < if
            1021 - 3 *
            " modnegbanborxorbinhislosequgrt"
            drop + 3 blue type nocolor exit then
        dup 1033 < if
            1031 - 3 *
            " lowfun"
            drop + 3 blue type nocolor exit then
    then
    .
    ;


?\ Output tokens in datafield of xt a.
: dump-word ( a -- )
    dup >extra @ cell+ @ 1+
    yellow
    over >name @ print ( print name )
    0 color
    space
    begin dup 0 > while
        swap dup @ dump-xt space cell+ swap
        1 -
    repeat
    2drop
    ;


?\ Decompile word.
: see ( " " -- )
    parse-word lookup dup 0 = if 3drop exit then
    1 = if [char] i emit space then dump-word ;


?\ Outputs short information about a word.
: ? ( " " -- )
    parse-word
    lookup 0 = if 2drop exit then
    >extra @ dup
    2 cells + @ dup
        0 = not if cell+ count type nl emit ( doc line )
        else drop then
    [char] ( emit space
    3 cells + count type ( stack effect )
    [char] ) emit
    ;


: dump ( -- )
    last @
    begin dup 0 = not while
        dup host cell+ @ = if " ________host________" type 10 emit then


        dup link> dump-word
        10 emit


        @
    repeat
    drop
    ;


( debugging )


: debug ( -- )
  4 6 function
;


( miscellaneous )


: bye ( ) 3 function ;
: q bye ;


( dumping )


?\ Interrupt 1 writes a memory region to disk.
: write-to-disk ( -- )
  0
  dp@
  1 function ;


?\ Interrupt 2 reads a memory region from disk.
: read-from-disk ( a -- x ) dp@ ( read to dictionary )
  2 function ( call function 2, returns size )
  dp@ + dp! ( adjust dictionary pointer ) ;


.\ Compiling the interpreter...


: interpret-value ( a n -- )
  over c@ [char] - = if swap 1 + swap 1 - -1 else 1 then rot rot
  ( s a n ) 0 rot rot ( s 0 a n ) >number
  ( s x a n ) dup 0 =
  if
    drop
    drop * ( apply sign )
    state @ 0 = not if
    ['] dolit relocate-xt ,
    , then
  else
    [char] ! emit type
    drop
  then
  ;


?\ Try to find xt for given xt in host dictionary.
: hostlookup ( a -- a' )
  ( are we compiling at all? )
  host cell+ @ 0 = if exit then


  context @ ( save current context )
  host context ! ( replace )
  swap dup ( context xt xt ) >name @ count
  ( context xt a n ) lookup ( .. a n 0 | x 1 )
  0 = if
    [char] % emit
    type
  else
    swap drop
  then
  swap context !
  ;


: interpret-word ( a x -- )
  1 = state @ 0 = or if
    \ we are about to execute a word. but as we are cross-compiling, try to
    \ find a matching word in the old dictionary and execute that instead of
    \ the one in the target dictionary, which may not execute properly.
    hostlookup
    execute
  else
    \ compile a word. this should always be a word from the target dictionary.
    dup data offset @ + < if
      35 color
      dup >name @ print
      0 color
    then
    \ therefore, it needs to be relocated.
    \ if it is a host word, things will go bad without the above check.
    relocate-xt ,
  then
  ;


: input? >in @ #tib @ < ;


: interpret ( -- )
  begin
  input? while
    parse-word
    dup 0 = if ( don't even bother about empty tokens )
      2drop [char] ~ emit exit then
    lookup
    dup 0 =
    if drop interpret-value else interpret-word then
  repeat
  ;


: >tib tib #tib @ + c! #tib @ 1 + #tib ! ;


( read one line worth of input. )
: query ( -- )
  0 >in !
  0 #tib !
  begin
    key
    dup 13 = if drop exit then
    dup 10 = if drop exit then
    >tib
  again
  ;


: version dolit [ version 1+ , ] ;


variable quiet


.\ Compiling the parser...
: quit ( -- )
    [char] f emit
    [char] 4 emit
    [char] . emit
    version .
    10 emit
    ( todo: set current, don't modify the wordlist )
    0 host cell+ !
    0 offset !
    0 quiet !
    begin
    query
    interpret
    quiet @ not if
        state @
        0 = if
            10 emit .s space
            [char] o emit
            [char] k emit
            cr
        then
    then
    again
    ;


.\ Compiling branch resolvers...


( backward )
: <mark ( -- a ) dp@ ;
: <resolve ( a -- ) relocate , ;


( forward )
: >mark ( -- a ) dp@ 0 , ;
: >resolve ( a -- ) dp@ relocate swap ! ;


: c<mark ( c: -- a ) dp@ >c ;
: c<resolve ( c: a -- ) c> relocate , ;
: c>mark ( c: -- a ) dp@ 0 , >c ;
: c>resolve ( c: a -- a )
    dp@ relocate c> dup @ >c ! cs@
    0 = not if recurse then
    ;


.\ Compiling looping and branching words...


( normal loops )
: begin ( c: -- a ) <mark ; immediate
: again ( c: a -- )
  ['] branch relocate-xt ,
  <resolve ; immediate
: until ( c: a -- )
  ['] not relocate-xt ,
  ['] ?branch relocate-xt ,
  <resolve ; immediate


: while ( c: a -- b a )
    ['] not relocate-xt ,
    ['] ?branch relocate-xt ,
    >mark swap ; immediate
: repeat ( c: b a -- )
    ['] branch relocate-xt ,
    <resolve >resolve ; immediate


( counted looping )


( do will place [0 a] to the compiler's control stack. each leave will
( write the value of the second stack register into its code, and place
( its own address to the stack. example: )
(  .. do .. leave .. leave .. leave .. loop .. )
(  this produces the code: )
(  .. [a0] .. jmp [a1] a4 .. jmp [a2] a4 .. jmp [a3] a4 .. jmp a0 [a4] .. )
(  the compiler's return stack will look like this: )
(  .. do [0 a]
(  .. leave [a1 a] - 0 is written to a1
(  .. leave [a2 a] - a1 is written to a2
(  .. leave [a3 a] - a2 is written to a3
(  .. loop [ ]


: do ( c: -- 0 a )
    ['] (do) relocate-xt ,
    0 >c ( no more forward references to resolve )
    c<mark
    ; immediate


: leave ( c: a a -- a a )
    ['] branch relocate-xt ,
    c> { dp@ { c> , } >c } >c
    ; immediate


( this is like ... do ... leave ... in a way )
: ?do ( c: -- a a )
    ['] (?do) relocate-xt ,
    ['] ?branch relocate-xt , ( jump to loop end )
    c>mark ( this is the leave address to resolve )
    c<mark ( this is the loop address )
    ; immediate


: loop ( c: a a -- )
    ['] (loop) relocate-xt ,
    ['] ?branch relocate-xt ,
    c<resolve ( jump back to start )
    cs@ 0 = not if c>resolve then cdrop ( check for exit points to resolve)
    ['] (loopdone) relocate-xt ,
    ; immediate


( if else then )


\ the normal stack is used to contain a list of addresses to be
\ forward resolved.


: if ( c: -- a )
  ['] not relocate-xt ,
  ['] ?branch relocate-xt ,
  >mark
  ; immediate


: else ( c: a -- a )
  ['] branch relocate-xt ,
  >mark swap
  >resolve
  ; immediate


: then ( c: a -- )
    >resolve
    ; immediate


.\ Compiling booting and cross compilation words...


( compile code to address 0 to jump to next. )
dp@
0 dp!
*arg ' next >body , *hop
dp!


( interrupt 4 writes the system area and relocated dictionary to disk. )
: write-to-disk-with-ip ( a -- )


  offset @ data +
  dp@ over -


  dp@ relocate dp! ( update dp )
  returnstack returnstacklen + rp !


  ( ip address size ) 4 function


  3 function ;


?\ Relocate link, name, extra fields of target dictionary.
: relocate-dictionary ( -- )


    ( setup target forth wordlist )
    last @ relocate ['] forth relocate-xt offset @ + >body cell+ !


    ( setup target host wordlist )
    last @ relocate ['] host relocate-xt offset @ + >body cell+ !


    ( setup target context )
    ['] forth relocate-xt >body ['] context relocate-xt offset @ + >body !


    ( setup target current )
    ['] forth relocate-xt >body ['] current relocate-xt offset @ + >body !


    ( setup target last )
    last @ relocate ['] last relocate-xt offset @ + >body !


    ( setup target ip )
    ['] quit relocate-xt >body ['] ip relocate-xt offset @ + >body !


    ( setup target dp )
    dp@ relocate ['] dp relocate-xt offset @ + >body !


    ( clear target rp )
    returnstack returnstacklen + ['] rp relocate-xt offset @ + >body !


    ( clear target cp )
    controlstack controlstacklen + ['] cp relocate-xt offset @ + >body !


    \ as help for external tools to find into the dictionary, put the location
    \ of last after the end of the dictionary
    ['] last relocate-xt >body ,


    last @
    ( l ) begin
        dup offset @ data +
        ( l l d ) < not
    while
        ( l ) dup @ offset @ data +
        ( l l' d ) < if ( store dictionary-offset as prev if last one )
            offset @ over !
        then
        ( l ) dup @
        ( l l' ) swap
        ( relocate extra field )
        ( l' l ) dup l>extra
        ( l' l s ) dup @ dup 0 > if relocate swap ! else 2drop then
        ( relocate name field )
        ( l' l ) dup l>name dup @ relocate swap !
        ( relocate link field )
        ( l' l ) dup @ relocate swap !
    repeat
    drop


    ;


: re ( -- )


  ['] quit relocate-xt >body ( new ip )


  relocate-dictionary
  ( the target dictionary is gone now )


  write-to-disk-with-ip
  ( this point is never reached )
  ;


resolve


variable resolve-start
variable resolve-pos
?\ Compile a forward reference with id x.
: resolve-later ( x -- )
    resolve-pos @ ! resolve-pos cell+!
    *arg
    dp @ resolve-pos @ ! resolve-pos cell+!
    0 ,
    ;


: *ip 1 resolve-later ;
: *w 2 resolve-later ;
: *dp 3 resolve-later ;
: *rp 4 resolve-later ;


: resolve-id ( x -- x' )
    dup 1 = if ( ip ) drop ['] ip relocate-xt >body exit then
    dup 2 = if ( w ) drop ['] w relocate-xt >body exit then
    dup 3 = if ( dp ) drop ['] dp relocate-xt >body exit then
    dup 4 = if ( rp ) drop ['] rp relocate-xt >body exit then
    drop red " resolving error!" type cr 0
    ;
: resolve ( -- )
    begin resolve-start @ resolve-pos @ < while
        resolve-start @ @ resolve-start cell+!
        resolve-id
        resolve-start @ @ !
        resolve-start cell+!
    repeat
    ;


false quiet ! ( display prompt again )