: task ;
( call  ) ( cfa-> call+2  )
: .cpu base @ lit 36 base ! lit 34 +origin 2@ d. base ! ;
: triad 12 emit 3 / 3 * 3 over + swap
  do cr i list ?terminal if leave then loop
  cr 15 message cr ;
: index 12 emit cr 1+ swap
  do cr i 3 .r space 0 i .line ?terminal if leave then loop ;
: list decimal cr dup scr ! ." Screen #" . lit 16 0
  do cr i lit 3 .r space i scr @ .line ?terminal if leave loop cr ;
( menu  ) ( cfa-> 0  )
: vlist lit 128 out ! context @ @ 
  begin
    out @ c/l > if cr 0 out ! then dup id. space space
    pfa lfa @ dup 0= ?terminal or
  until drop ;
: u. 0 d. ;
: ? @ . ;
: . s->d d. ;
: d. 0 d.r space ;
: .r >r s->d r> d.r ;
: d.r >r swap over dabs <# #s sign #> r> over - spaces type ;
: #s begin # over over or 0= until ;
: # base @ m/mod rot lit 9 over < if lit 7 + then lit 48 + hold ;
: sign rot 0< if lit 45 hold then ;
: #> drop drop hld @ pad over - ;
: <# pad hld ! ;
: spaces 0 max -dup if 0 do space loop then ;
: while if 2+ ; immediate
: else 2 ?pairs compile branch here 0 , swap 2 endif 2 ; immediate
: if compile 0branch here 0 , 2 ; immediate
: repeat >r >r again r> r> 2 - endif ; immediate
: again 1 ?pairs compile branch back ; immediate
: end until ; immediate
: until 1 ?pairs compile 0branch back ; immediate
: +loop 3 ?pairs compile (+loop) back ; immediate
: loop 3 ?pairs compile (loop) back ; immediate
: do compile (do) here 3 ; immediate
: then endif ; immediate
: endif ?comp 2 ?pairs here over - swap ! ; immediate
: begin ?comp here 1 ; immediate
: back here - , ;
: forget current @ context @ - 24 ?error ' dup fence @ < 21 ?error dup
nfa dp ! lfa @ context @ ! ;
: ' -find 0= 0 ?error drop literal ;
: --> ?loading 0 in ! b/scr blk @ over mod - blk +! ;
: load blk @ >r in @ >r 0 in ! b/scr * blk ! interpret r> in ! r> blk ! ;
: flush #buff 1+ 0 do 0 buffer drop loop flush+10 ;
: r/w use @ >r swap sec/blk * rot use ! sec/blk 0
  do over over t&scalc if sec-read else sec-write then 1+ lit 128 use +! loop
  drop drop r> use ! ;
( sec-write  ) ( cfa-> sec-write+2  )
( sec-read  ) ( cfa-> sec-read+2  )
: t&scalc dup 0< over lit 1439 > or lit 6 ?error lit 18 /mod track ! 1+ sec ! ;
: block offset @ + >r prev @ dup @ r - dup +
  if
    begin
      +buf 0=
      if
        drop r buffer dup r 1 r/w 2 -
      then
      dup @ r - dup + 0=
    until
    dup prev !
  then
  r> drop 2+ ;
: buffer use @ dup >r begin +buf until use ! r @ 0<
  if r 2+ r @ lit 32767 and 0 r/w then
  r ! r prev ! r> 2+ ;
: empty-buffers first limit over - erase ;
: update prev @ @ lit -32768 or prev @ ! ;
: +buf lit 260 + dup limit = if drop first then dup prev @ - ;
0 variable disk-error
4 constant #buff
1 constant sec/blk
r0+64 variable prev
r0+64 variable use
0 variable track
0 variable sec
( p!  ) ( cfa-> p!+2  )
( p@  ) ( cfa-> p@+2  )
: message
  warning @
  if
    -dup
    if lit 4 .line space then
  else
    ." Msg #" .
  then ;
: .line (line) -trailing type ;
: (line) >r lit 64 b/buf */mod r> b/scr * + block + lit 64 ;
: m/mod >r 0 r u/ r> swap >r u/ r> ;
: */ */mod swap drop ;
: */mod >r m* r> m/ ;
: mod /mod drop ;
: / /mod swap drop ;
: /mod >r s->d r> m/ ;
: * m* drop ;
: m/ over >r >r dabs r abs u/ r> r xor +- swap r> +- swap ;
: m* 2dup xor >r abs swap abs u* r> d+- ;
: max 2dup < if swap then drop ;
: min 2dup > if swap then drop ;
: dabs dup d+- ;
: abs dup +- ;
: d+- 0< if dminus then ;
: +- 0< if minus then ;
( s->d  ) ( cfa-> s->d+2  )
( cold  )
: cold
  empty-buffers
  lit r0+64 use !
  lit r0+64 prev !
  0 lit -->+28 !
  lit origin+18 lit origin+38 @ lit 6 + lit 16 cmove
  lit origin+12 @ lit forth+6 !
  abort
  [;]
: warm empty-buffers abort [;]
: abort sp! decimal ?stack cr .cpu ." fig-FORTH 1.1D" forth definitions quit [;]
: quit
  0 blk ! [
  begin
    rp! cr query interpret state @ 0= if ." Ok" then
  again
  [;]
: ( lit 41 word ; immediate
: definitions context @ current ! ;
( forth  ) ( cfa-> does>+12  )
: vocabulary
  <builds
  lit 0branch+8 , current @ cfa , here voc-link @ , voc-link !
  does> 2+ context ! ;
: immediate latest lit 64 toggle ;
: interpret
  begin
    -find
    if
      state @ <
      if
        cfa ,
      else
        cfa execute
      then
      ?stack
    else
      here number dpl @ 1+
      if
        dliteral
      else
        drop literal
      then
      ?stack
    then
  again
  [;]
: ?stack sp@ s0 @ swap u< 1 ?error sp@ here lit 128 + u< lit 7 ?error ;
: dliteral state @ if swap literal literal then ;
: literal state @ if compile lit , then ;
: [compile] -find 0= 0 ?error drop cfa , ;
: create
  -find
  if drop nfa id. lit 4 message space then
  here
  dup c@ width @ min 1+ allot
  ( hide )
  dup lit 160 toggle
  ( terminate name )
  here 1 - lit 128 toggle
  latest , current @ ! here 2+ , ;
: id.
  pad 32 95 fill
  dup pfa lfa over - pad swap cmove pad count 31 and type space ;
: error
  warning @ 0< if (abort) then
  here count type ." ? " message sp! blk @ -dup if in @ swap then quit [;]
: (abort) abort ;
: -find bl word here context @ @ (find) dup 0= if drop here latest (find) then ;
: number
  0 0 rot dup 1+ c@ lit 45 = dup >r + lit -1
  begin
    dpl ! (number) dup c@ bl -
    while 
    dup c@ lit 46 - 0 ?error 0
  repeat
  drop r> if dminus then ;
: (number)
  begin
    1+ dup >r c@ base @ digit
    while
    swap base @ u* drop rot base @ u* d+
    dpl @ 1+ if 1 dpl +! then
    r>
  repeat r> ;
: word
  blk @ if blk @ block else tib @ then
  in @ + swap enclose here lit 34
  blanks in +! over - >r r here c! + here 1+ r> cmove ;
: pad here lit 68 + ;
: hold lit -1 hld +! hld @ c! ;
: blanks bl fill ;
: erase 0 fill ;
( fill  ) ( cfa-> fill+2  )
: [eol]
  blk @
  0branch +50
  1 blk +! 0 in ! blk @ b/scr 1 - and 0=
  0branch +46
  ?exec r> drop
  ( +46 )
  branch +54
  ( +50 )
  r> drop
  ( +54 )
  ;

: query tib @ lit 80 expect 0 in ! ;
: expect
  over + over
  do
    key dup lit 14 +origin @ =
    if
      drop dup i = dup r> 2 - + >r
      if lit 7 else lit 8 then
    else
      dup lit 13 =
      if
        leave drop bl 0
      else
        dup
      then
      i c! 0 i 1+ !
    then
    emit
  loop
  drop ;
: ." lit 34 state @
  if
    compile (.") word here c@ 1+ allot
  else
    word here count type
  then ;
: (.") r count dup 1+ r> + >r type ;
: -trailing dup 0 do over over + 1 - c@ bl - if leave else 1 - then loop ;
: type -dup if over + swap do i c@ lit 127 and emit loop else drop then ;
: count dup 1+ swap c@ ;
: does> r> latest pfa ! ;code [...] immediate
: <builds 0 constant ;
: ;code ?csp compile (;code) [compile] [ noop ; immediate
: (;code) r> latest pfa cfa ! ;
: decimal lit 10 base ! ;
: hex lit 16 base ! ;
: smudge latest lit 32 toggle ;
: ] lit 192 state ! ;
: [ 0 state ! ;
: compile ?comp r> dup 2+ >r @ , ; immediate
: ?loading blk @ 0= lit 22 ?error ;
: ?csp sp@ csp @ - lit 20 ?error ;
: ?pairs - lit 19 ?error ;
: ?exec state @ lit 18 ?error ;
: ?comp state @ 0= lit 17 ?error ;
: ?error swap if error else drop then ;
: !csp sp@ csp ! ;
: pfa 1 traverse lit 5 + ;
: nfa lit 5 - lit -1 traverse ;
: cfa 2 - ;
: lfa lit 4 - ;
: latest current @ @ ;
: traverse swap begin over + lit 127 over c@ < until swap drop ;
: -dup dup if dup then ;
: space bl emit ;
( rot  ) ( cfa-> rot+2  )
: > swap < ;
: u< 2dup xor 0< if drop 0< 0= else - 0< then ;
( <  ) ( cfa-> <+2  )
: = - 0= ;
( -  ) ( cfa-> -+2  )
: c, here c! 1 allot ;
: , here ! 2 allot ;
: allot dp +! ;
: here dp @ ;
: 2+ 2 + ;
: 1+ 1 + ;
( hld  ) ( cfa-> user+6  )
( r#  ) ( cfa-> user+6  )
( csp  ) ( cfa-> user+6  )
( fld  ) ( cfa-> user+6  )
( dpl  ) ( cfa-> user+6  )
( base  ) ( cfa-> user+6  )
( state  ) ( cfa-> user+6  )
( current  ) ( cfa-> user+6  )
( context  ) ( cfa-> user+6  )
( offset  ) ( cfa-> user+6  )
( scr  ) ( cfa-> user+6  )
( out  ) ( cfa-> user+6  )
( in  ) ( cfa-> user+6  )
( blk  ) ( cfa-> user+6  )
( voc-link  ) ( cfa-> user+6  )
( dp  ) ( cfa-> user+6  )
( fence  ) ( cfa-> user+6  )
( warning  ) ( cfa-> user+6  )
( width  ) ( cfa-> user+6  )
( tib  ) ( cfa-> user+6  )
( r0  ) ( cfa-> user+6  )
( s0  ) ( cfa-> user+6  )
: +origin lit -24576 + ;
4 constant b/scr
256 constant b/buf
r0+1104 constant limit
r0+64 constant first
64 constant c/l
32 constant bl
3 constant 3
2 constant 2
1 constant 1
0 constant 0
: user constant ;code [...]
: variable constant ;code [...]
: constant create smudge , ;code [...]
: noop ;
: ; ?csp compile ;s smudge [ ; immediate
: : ?exec !csp current @ context ! create ] ;code [...]
( 2!  ) ( cfa-> 2!+2  )
( c!  ) ( cfa-> c!+2  )
( !  ) ( cfa-> !+2  )
( 2@  ) ( cfa-> 2@+2  )
( c@  ) ( cfa-> c@+2  )
( @  ) ( cfa-> @+2  )
( toggle  ) ( cfa-> toggle+2  )
( +!  ) ( cfa-> +!+2  )
( 2dup  ) ( cfa-> 2dup+2  )
( dup  ) ( cfa-> dup+2  )
( swap  ) ( cfa-> swap+2  )
( drop  ) ( cfa-> drop+2  )
( over  ) ( cfa-> over+2  )
( dminus  ) ( cfa-> dminus+2  )
( minus  ) ( cfa-> minus+2  )
( d+  ) ( cfa-> d++2  )
( +  ) ( cfa-> ++2  )
( 0<  ) ( cfa-> 0<+2  )
( 0=  ) ( cfa-> 0=+2  )
( r  ) ( cfa-> i+2  )
( r>  ) ( cfa-> r>+2  )
( >r  ) ( cfa-> >r+2  )
( leave  ) ( cfa-> leave+2  )
( ;s  ) ( cfa-> ;s+2  )
( rp!  ) ( cfa-> rp!+2  )
( rp@  ) ( cfa-> rp@+2  )
( sp!  ) ( cfa-> sp!+2  )
( sp@  ) ( cfa-> sp@+2  )
( xor  ) ( cfa-> xor+2  )
( or  ) ( cfa-> or+2  )
( and  ) ( cfa-> and+2  )
( u/  ) ( cfa-> u/+2  )
( u*  ) ( cfa-> u*+2  )
( cmove  ) ( cfa-> cmove+2  )
( cr  ) ( cfa-> cr+2  )
( ?terminal  ) ( cfa-> ?terminal+2  )
( key  ) ( cfa-> key+2  )
( emit  )
: emit
( emit+2 ) o&C________________
( emit+4 ) 1
( emit+6 ) out
( emit+8 ) +!
( emit+10 ) ;
( enclose ) ( cfa-> enclose+2  )
( (find)  ) ( cfa-> (find)+2  )
( digit  ) ( cfa-> digit+2  )
( i  ) ( cfa-> i+2  )
( (do)  ) ( cfa-> (do)+2  )
( (+loop)  ) ( cfa-> (+loop)+2  )
( (loop)  ) ( cfa-> (loop)+2  )
( 0branch  ) ( cfa-> 0branch+2  )
( branch  ) ( cfa-> branch+2  )
( execute  ) ( cfa-> execute+2  )
( lit  ) ( cfa-> lit+2  )

( dc.all end )