T3XFORTH

\ T3XFORTH High−Level Words
\ Nils M Holm, 2021
\ Public domain / CC0 License

: ?DUP ( w −− w w | w ) DUP IF DUP THEN ;

: NIP ( w1 w2 −− w2 ) SWAP DROP ;
    
: ROT ( w1 w2 w3 −− w2 w3 w1 ) >R SWAP R> SWAP ;

: −ROT ( w1 w2 w3 −− w3 w1 w2 ) ROT ROT ;

: 2DROP ( d −− ) DROP DROP ;
      
: 2DUP ( d −− d d ) OVER OVER ;

: 2SWAP ( d1 d2 −− d2 d1 ) >R −ROT R> −ROT ;

−1 CONSTANT −1
 0 CONSTANT  
 1 CONSTANT  
 2 CONSTANT  

: INVERT ( w −− w ) −1 XOR ;

: + ( n n −− n ) UM+ DROP ;

: 1+ ( n −− n ) 1 + ;
: 2+ ( n −− n ) 2 + ;

: NEGATE ( n −− n ) INVERT 1+ ;

: DNEGATE ( d −− d ) INVERT >R INVERT 1 UM+ R> + ;

: − ( n n −− n ) NEGATE + ;

: 1− ( n −− n ) 1 − ;
: 2− ( n −− n ) 2 − ;

: ABS ( n −− n ) DUP 0< IF NEGATE THEN ;

: 0= ( w −− f ) IF 0 EXIT THEN −1 ;

: NOT ( w −− f ) 0= ;

:  = ( w w −− f ) XOR 0= ;
: <> ( w w −− f ) = 0= ;

: U< ( u u −− f ) 2DUP XOR 0< IF  NIP 0< EXIT THEN − 0< ;
:  < ( n n −− f ) 2DUP XOR 0< IF DROP 0< EXIT THEN − 0< ;

: U> ( u u −− f ) SWAP U< ;
:  > ( n n −− f ) SWAP < ;

: 0> ( n −− f ) 0 > ;

: D+ ( d d −− d ) >R ROT UM+ ROT + R> + ;

: D< ( d d −− f ) ROT SWAP < IF 2DROP −1 EXIT THEN U< ;

: MAX ( n n −− n ) 2DUP < IF SWAP THEN DROP ;
: MIN ( n n −− n ) 2DUP > IF SWAP THEN DROP ;

: WITHIN ( u ul uh −− f ) OVER − >R − R> U< ;

: UM* ( u1 u2 −− ud )
  0 SWAP ( u1 v=0 u2 ) 16 0 DO
    DUP UM+ >R >R     \ u1 v         ; cu2 2u2
    DUP UM+  R> +     \ u1 2v 2u2+cv ; cu2
    R> IF             \ u1 2v 2u2+cv cu2
    >R OVER           \ u1 2v u1     ; 2u2+cv
    UM+  R> + THEN    \ u1 2v+u1 2u2+cv+c
  LOOP ROT DROP ;

: * ( w w −− w ) UM* DROP ;

: M* ( n n −− d )
  2DUP XOR 0< >R  ABS SWAP ABS UM*  R> IF DNEGATE THEN ;

: 2* ( w −− w ) 1 LSHIFT ;
: 2/ ( w −− w ) 1 RSHIFT ;

: UM/MOD ( ul uh u −− um uq )
  2DUP U<                    \ uh < u
  IF  NEGATE                 \ ul uh −u
    16 0 DO
      >R DUP  UM+  >R >R     \ ul          ;  −u ch 2uh
      DUP UM+  R> +          \ 2ul 2uh+cl  ;  −u ch
      DUP R> R@ SWAP >R      \ 2ul 2uh+cl 2uh+cl −u  ; −u ch
          UM+ R> OR          \ 2ul 2uh+cl 2uh+cl−u c|ch ; −u
      IF >R DROP 1+ R> ELSE  \ 2ul+1 2uh+cl−u ; −u
         DROP THEN           \ 2ul 2uh+cl     ; −u
    R> LOOP DROP SWAP EXIT
  THEN  DROP 2DROP  −1 DUP ;

: U/ ( u1 u2 −− u ) 0 SWAP UM/MOD NIP ;

: EXTEND ( n −− d ) DUP 0< ;

: M/MOD ( d n −− nm nq ) \ floored
  EXTEND  DUP >R  IF NEGATE >R DNEGATE R> THEN
  >R DUP 0< IF R@ + THEN  R> UM/MOD
  R> IF SWAP NEGATE SWAP THEN ;

: /MOD ( n n −− nm nq ) SWAP EXTEND ROT M/MOD ;
: MOD ( n n −− n ) /MOD DROP ;
: / ( n n −− n ) /MOD NIP ;

: */MOD ( n n n −− r q ) >R M* R> M/MOD ;
: */ ( n n n −− q ) */MOD NIP ;

VARIABLE H
VARIABLE HLD
VARIABLE UP      [HEX] F380 ' UP !
VARIABLE BASE            10 ' BASE !
VARIABLE 'EMIT        ' TX! ' 'EMIT !
VARIABLE '?KEY        ' RX? ' '?KEY !
VARIABLE SPAN
VARIABLE >IN
VARIABLE BLK
VARIABLE #TIB
VARIABLE FENCE

  32 CONSTANT BL

   2 CONSTANT CELL

1024 CONSTANT B/BUF
  64 CONSTANT B/LINE

[HEX] F000 CONSTANT S0
[HEX] F000 CONSTANT TIB
[HEX] F380 CONSTANT R0

: HERE ( −− a ) H @ ;

: PAD ( −− a ) HERE B/LINE 2* + ;

: CELL+ ( n −− n ) CELL + ;

: CELL− ( n −− n ) CELL − ;

: CELLS ( n −− n ) 1 LSHIFT ( CELL * ) ;

: >CHAR ( n −− c )
  127 AND  DUP BL 127 WITHIN 0= IF DROP [CHAR] _ THEN ;

: DEPTH ( −− n ) SP@ S0 SWAP − 1 RSHIFT ( CELL / ) ;

: PICK ( u −− w ) 1+ CELLS SP@ + @ ;

: 2OVER ( d1 d2 −− d1 d2 d1 ) 3 PICK 3 PICK ;

: +! ( n a −− ) SWAP OVER @ + SWAP ! ;

: 2! ( d a −− ) SWAP OVER ! CELL+ ! ;
: 2@ ( a −− d ) DUP CELL+ @ SWAP @ ;

: ?0>DUP ( n −− 0 | n n ) DUP 0> IF DUP EXIT THEN DROP 0 ;

: @EXECUTE ( a −− ) @ ?DUP IF EXECUTE THEN ;

: EMIT ( c −− ) 'EMIT @EXECUTE ;

: ?KEY ( −− c T | F ) '?KEY @EXECUTE ;

: CONSOLE ( −− ) ['] TX! 'EMIT !  ['] RX? '?KEY ! ;

: KEY ( −− c ) BEGIN ?KEY UNTIL ;

: COUNT ( a −− a n ) DUP 1+ SWAP C@ ;

: TYPE ( a n −− ) ?0>DUP IF 0 DO COUNT EMIT LOOP THEN DROP ;

: CR ( −− ) 13 EMIT 10 EMIT ;

: BELL ( −− ) 7 EMIT ;

: BACKSPACE ( −− ) 8 DUP EMIT BL EMIT EMIT ;

: PAGE ( −− ) 50 0 DO CR LOOP ;

: SPACE ( −− ) BL EMIT ;

: SPACES ( n −− ) ?0>DUP IF 0 DO SPACE LOOP THEN ;

: HEX     ( −− ) 16 BASE ! ;
: DECIMAL ( −− ) 10 BASE ! ;
: BINARY  ( −− )  2 BASE ! ;

: DIGIT ( u −− c ) DUP 9 > IF 55 + EXIT THEN [CHAR] 0 + ;

: <# ( ud −− u ) DROP PAD HLD ! ;

: HOLD ( c −− ) −1 HLD +!  HLD @ C! ;

: # ( u −− u ) BASE @  0 SWAP UM/MOD  SWAP DIGIT HOLD ;

: #S ( u −− 0 ) BEGIN # DUP WHILE REPEAT ;

: SIGN ( n u −− u ) SWAP 0< IF [CHAR] − HOLD THEN ;

: #> ( u −− a u ) DROP HLD @ PAD OVER − ;

: (PAD) ( u1 u2 −− u1 )
  2DUP < IF OVER − SPACES EXIT THEN DROP ;

:  .  ( n −− )    DUP ABS 0 <# #S SIGN #>          TYPE SPACE ;
: U.  ( u −− )            0 <# #S      #>          TYPE SPACE ;
:  .R ( nu−− ) >R DUP ABS 0 <# #S SIGN #> R> (PAD) TYPE ;
: U.R ( uu−− ) >R         0 <# #S      #> R> (PAD) TYPE ;

: H. ( u −− ) BASE @ HEX SWAP U. BASE ! ;

: ? ( a −− ) @ . ;

VARIABLE TMP

: EXPECT ( a u −− ) DUP TMP !  BEGIN
    DUP 0= IF DROP BL SWAP C!  TMP @ SPAN ! EXIT THEN
    KEY DUP 13 = IF DROP  TMP @ SWAP − SPAN !
                    BL SWAP C!  SPACE EXIT           ELSE
        DUP  8 = OVER 127 = OR
                 IF DROP DUP TMP @ <> IF
                    SWAP 1− SWAP 1+ BACKSPACE THEN   ELSE
        DUP 24 = IF DROP 2DROP 0 SPAN ! EXIT         ELSE
        DUP BL 127 WITHIN IF DUP EMIT
                 SWAP >R OVER C! R>  1− SWAP 1+ SWAP ELSE
    DROP BELL THEN THEN THEN THEN  AGAIN ;

: QUERY ( −− )
  TIB 80 EXPECT  SPAN @ #TIB !  0 >IN !  0 BLK ! ;

[HEX] F400 CONSTANT B0ADDR
[HEX] F800 CONSTANT B1ADDR

VARIABLE ACTIVE   −1 ' ACTIVE !
VARIABLE B0BLK    −1 ' B0BLK !
VARIABLE B1BLK    −1 ' B1BLK !
VARIABLE B0UPD     0 ' B0UPD !
VARIABLE B1UPD     0 ' B1UPD !

: ACTIVATE ( u −− ) B0BLK @ = 0= ACTIVE ! ;

: FIND−BLOCK ( u −− a T | 0 )
  DUP B0BLK @ = IF DROP B0ADDR −1 EXIT THEN
      B1BLK @ = IF      B1ADDR −1 EXIT THEN 0 ;

: SOURCE ( −− a )
  BLK @ ?DUP IF FIND−BLOCK DROP EXIT THEN TIB ;

: EXTRACT ( −− c ) SOURCE >IN @ + C@ ;

: ?MORE ( −− f ) >IN @ #TIB @ < ;

: WORD ( c −− a ) TMP !  HERE 1+
  BEGIN ?MORE EXTRACT TMP @ = AND WHILE
    1 >IN +! REPEAT
  BEGIN ?MORE EXTRACT TMP @ <> AND WHILE
    EXTRACT OVER C! 1+  1 >IN +!  REPEAT
  EXTRACT OVER C!  1 >IN +!  HERE 1+ − HERE C!  HERE ;

: .S ( −− ) S0 SP@ CELL+ = IF EXIT THEN
  S0 SP@ CELL+ DO I @ . CELL /LOOP ;

: CMOVE ( a a n −− ) ?0>DUP IF
    0 DO >R COUNT R@ C! R> 1+ LOOP 2DROP  THEN ;

: <CMOVE ( a a n −− ) ?0>DUP IF >R SWAP R@ + 1− SWAP R@ + 1− R>
    0 DO >R COUNT R@ C! 2 − R> 1− LOOP 2DROP  THEN ;

: MOVE ( a a n −− ) CELLS CMOVE ;

: UNLOOP ( −− ) R> R> R> 2DROP >R ;

: −TRAILING ( a n −− a n ) ?0>DUP IF
  1 SWAP 1− NEGATE DO DUP I − C@
      BL XOR IF I 1− NEGATE UNLOOP EXIT THEN
      LOOP 0 THEN ;

: −TEXT ( a1 u a2 −− n )
  SWAP DUP 0= IF 2DROP DROP 0 EXIT THEN
  0 DO OVER C@ OVER C@ − DUP IF
      −ROT 2DROP UNLOOP EXIT THEN
    DROP 1+ SWAP 1+ SWAP LOOP 2DROP 0 ;

: FILL ( a n c −− ) OVER 0> IF
    −ROT 0 DO 2DUP C! 1+ LOOP ELSE
    DROP THEN  2DROP ;

: ERASE ( a n −− ) 0 FILL ;

: BLANK ( a n −− ) BL FILL ;

: ?DIGIT ( c −− u T | F )
  DUP 64 > IF 55 − ELSE
  DUP 47 > IF 48 − THEN THEN
  DUP BASE @ U< IF −1 EXIT THEN DROP 0 ;

: CONVERT ( u a −− u a ) 1+
  BEGIN DUP C@ ?DIGIT WHILE ( u a digit )
    ROT BASE @ * + SWAP 1+ REPEAT ;

VARIABLE LAST
VARIABLE CONTEXT
VARIABLE CURRENT
VARIABLE (FORTH)

: FORTH ( −− ) (FORTH) CONTEXT ! ;

: DEFINITIONS ( −− ) CONTEXT @ CURRENT ! ;

: >NFA ( a −− a ) 10 − ;
: >LFA ( a −− a )  6 + ;
: >CFA ( a −− a )  8 + ;
: >PFA ( a −− a ) 10 + ;

: LOOKUP ( a a −− a f )
  BEGIN ?DUP WHILE
    2DUP ?SAME IF NIP −1 EXIT THEN
    >LFA @ REPEAT 0 ;

: UPCASE ( a −− ) COUNT 0 DO
    COUNT DUP [CHAR] a [CHAR] { WITHIN IF BL − THEN
    OVER 1− C! LOOP DROP ;

: ?FIND ( a −− a f ) DUP UPCASE
  CONTEXT @ @ LOOKUP IF >PFA −1 EXIT THEN
  (FORTH) CONTEXT @ = IF 0 EXIT THEN
  (FORTH) @ LOOKUP IF >PFA −1 EXIT THEN  0 ;

: FIND ( −− a ) BL WORD ?FIND IF >NFA >CFA EXIT THEN DROP 0 ;

: ?NUMBER ( a −− n T | F )
  DUP 1+ C@ [CHAR] − = DUP >R IF 1+ THEN
  0 SWAP CONVERT  C@ BL = IF −1 ELSE DROP 0 THEN
  R> OVER AND IF SWAP NEGATE SWAP THEN ;

VARIABLE STATE 0 ' STATE !

DEFER QUIT

: ABORT ( −− ) S0 SP!  0 STATE !  QUIT ;

: ?WHAT ( a −− ) COUNT TYPE [CHAR] ? EMIT CR ABORT ;

: $+ ( a1 −− a1 a2 ) DUP DUP C@ + 1+ ;

: ($") ( −− a ) R> $+ >R ; COMPILE−ONLY

: ?STACK ( −− ) SP@ S0 U>  SP@ PAD B/BUF + U< OR
  IF $" STK ERR" ?WHAT THEN ;

:  ( ( −− ) [CHAR] ) WORD DROP ; IMMEDIATE
: .( ( −− ) [CHAR] ) WORD COUNT TYPE ; IMMEDIATE
:  \ ( −− ) BLK @ 0= IF #TIB @ >IN ! EXIT THEN
   >IN @ B/LINE + 1− DUP B/LINE MOD − >IN ! ; IMMEDIATE

: ?ENOUGH ( −− ) [CHAR] : EMIT KEY BACKSPACE [CHAR] q = ;

: WORDS ( −− ) 0 TMP !  CR  CONTEXT @ @ BEGIN ?DUP WHILE
    DUP COUNT [HEX] 1F AND 5 MIN DUP >R TYPE 8 R> − SPACES
    1 TMP +!  TMP @ 199 > IF
      0 TMP ! ?ENOUGH IF DROP EXIT THEN THEN  >LFA @ REPEAT ;

: ?COMPILE−ONLY ( a −− a ) DUP >NFA C@ [HEX] 40 AND IF
    $" COMP ONLY" ?WHAT THEN ;

: ?IMMEDIATE ( a −− a w ) DUP >NFA C@ [HEX] 80 AND ;

:  , ( w −− ) H @  ! CELL H +! ;
: C, ( c −− ) H @ C!    1 H +! ;

: ' ( −− a ) BL WORD ?FIND 0= IF ?WHAT THEN ;

: COMPILE ( −− ) R> DUP @ , CELL+ >R ; COMPILE−ONLY

: LITERAL ( w −− ) COMPILE (LIT) , ; IMMEDIATE COMPILE−ONLY

: DUMP ( a −− ) BASE @ >R HEX
    DUP 16 0 DO COUNT 0 <# # # #> TYPE SPACE LOOP
  DROP  16 0 DO COUNT >CHAR EMIT LOOP  R> BASE ! SPACE ;

: HD ( a n −− ) BASE @ >R HEX
  0 DO CR DUP 0 <# # # # # #> TYPE
    SPACE DUMP LOOP  R> BASE ! ;

: PFA>CFA ( a −− a ) CELL− ;
: CFA>PFA ( a −− a ) CELL+ ;

: NUMBER ( a −− n )
  DUP ?NUMBER IF NIP EXIT THEN ?WHAT ;

VARIABLE DBL
VARIABLE 'NUMBER  ' NUMBER ' 'NUMBER !

: NUMBER 'NUMBER @EXECUTE ;

: DLITERAL ( d −− )
  SWAP [COMPILE] LITERAL [COMPILE] LITERAL ;
  IMMEDIATE COMPILE−ONLY

: INTERPRET ( −− ) BEGIN BL WORD DUP C@ WHILE
    STATE @ IF  ?FIND IF
        ?IMMEDIATE IF EXECUTE ELSE PFA>CFA , THEN ELSE
        NUMBER DBL @ IF
          [COMPILE] DLITERAL ELSE
          [COMPILE] LITERAL  THEN THEN
    ELSE ?FIND IF
        ?COMPILE−ONLY EXECUTE ELSE
        NUMBER THEN
    THEN ?STACK REPEAT DROP ;

: .OK ( −− )
  STATE @ 0= IF [CHAR] O EMIT [CHAR] K EMIT THEN CR ;

: ['] ( −− a ) ' [COMPILE] LITERAL ; IMMEDIATE COMPILE−ONLY

: [HEX] ( −− w ) BASE @ >R  BL WORD DUP UPCASE
  DUP HEX ?NUMBER 0= IF R> BASE ! ?WHAT THEN  NIP
  R> BASE !  STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE

: [CHAR] ( −− c ) BL WORD 1+ C@
  STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE

: [COMPILE] ( −− ) ' PFA>CFA , ; IMMEDIATE COMPILE−ONLY

: ALLOT ( n −− ) HERE + H ! ;

: ENTRY ( a −− ) DUP UPCASE
  COUNT 5 SWAP DO DUP I + BL SWAP C! LOOP DROP ;

: CREATE ( −− ) BL WORD ENTRY  6 ALLOT
  CURRENT @ @ ,  ['] (VAR) ,  HERE >NFA LAST ! ;

: PERFORMS ( −− ) R>  DUP @ CFA>PFA LAST @ >CFA !
  CELL+ >R ; COMPILE−ONLY

: LINK ( −− ) LAST @ CURRENT @ ! ;

: VARIABLE ( −− ) CREATE 0 , LINK ;

: CONSTANT ( w −− ) CREATE , PERFORMS (CONST) LINK ;

: [ ( −− )  0 STATE ! ; IMMEDIATE
: ] ( −− ) −1 STATE ! ;

: : ( −− ) CREATE PERFORMS (COLON) ] ;
: ; ( −− ) COMPILE EXIT [COMPILE] [ LINK ; IMMEDIATE
           COMPILE−ONLY

: (DEFER) ( −− ) $" DEFER ERR" ?WHAT ; COMPILE−ONLY

: DEFER ( −− ) CREATE PERFORMS (COLON) COMPILE (DEFER)
  COMPILE EXIT LINK ;

: IS ( −− ) LAST @ >CFA ' ! ;

: MARK ( −− a ) HERE 0 , ; COMPILE−ONLY

: RESOLVE ( a −− ) HERE SWAP ! ; COMPILE−ONLY

: IF ( f −− ) COMPILE (0BRANCH) MARK ; IMMEDIATE COMPILE−ONLY
: ELSE ( −− ) COMPILE (BRANCH) MARK SWAP RESOLVE ; IMMEDIATE
              COMPILE−ONLY
: THEN ( −− ) RESOLVE ; IMMEDIATE COMPILE−ONLY

: DO ( n n −− ) COMPILE (DO) HERE ; IMMEDIATE COMPILE−ONLY
: LOOP ( −− ) COMPILE (LOOP) , ; IMMEDIATE COMPILE−ONLY
: +LOOP ( n −− ) COMPILE (+LOOP) , ; IMMEDIATE COMPILE−ONLY
: /LOOP ( u −− ) COMPILE (/LOOP) , ; IMMEDIATE COMPILE−ONLY
: LEAVE ( −− ) R> R> R> DROP DUP >R >R >R ; COMPILE−ONLY

: BEGIN ( −− ) HERE ; IMMEDIATE COMPILE−ONLY
: WHILE ( f −− ) [COMPILE] IF ; IMMEDIATE COMPILE−ONLY
: REPEAT ( −− ) COMPILE (BRANCH) SWAP , RESOLVE ; IMMEDIATE
                COMPILE−ONLY
: AGAIN ( f −− ) COMPILE (BRANCH) , ; IMMEDIATE COMPILE−ONLY
: UNTIL ( f −− ) COMPILE (0BRANCH) , ; IMMEDIATE COMPILE−ONLY

: IMMEDIATE    ( −− ) LAST @ C@ [HEX] 80 OR LAST @ C! ;
: COMPILE−ONLY ( −− ) LAST @ C@ [HEX] 40 OR LAST @ C! ;

: RECURSE ( −− ) LAST @ >CFA , ; IMMEDIATE COMPILE−ONLY

: I' ( −− w )    R> R> R@ −ROT >R >R ;
: J  ( −− w ) R> R> R> R@ −ROT >R >R SWAP >R ;

: $, ( −− ) [CHAR] " WORD C@ 1+ ALLOT ; COMPILE−ONLY

: $" ( −− a ) COMPILE ($") $, ; IMMEDIATE COMPILE−ONLY

: (.") ( −− ) R> $+ >R COUNT TYPE ; COMPILE−ONLY

: ." ( −− ) COMPILE (.") $, ; IMMEDIATE COMPILE−ONLY

: (ABORT") ( f −− ) R> $+ >R SWAP IF ?WHAT THEN DROP ;
           COMPILE−ONLY

: ABORT" ( f −− ) COMPILE (ABORT") $, ; IMMEDIATE
                  COMPILE−ONLY

: <BUILDS ( −− ) VARIABLE ; COMPILE−ONLY

: DOES> ( −− ) PERFORMS (DOES>) R> LAST @ >PFA ! ; COMPILE−ONLY

: ARRAY ( u −− ) <BUILDS CELLS ALLOT DOES> SWAP CELLS + ;

: USER ( u −− ) <BUILDS CELLS , DOES> @ UP @ + ;

: VOCABULARY ( −− ) <BUILDS 0 , DOES> CONTEXT ! ;

: EMPTY ( −− ) FORTH DEFINITIONS  FENCE @ DUP DUP
  CONTEXT @ !  CURRENT @ !  >PFA CELL+ H ! ;

: FORGET ( −− )
  CURRENT @ CONTEXT @ <>    ABORT" CURRENT"
  ' >NFA DUP  FENCE @ U> 0= ABORT" FENCE"
        DUP CONTEXT @ U> 0= ABORT" CONTEXT"
  DUP H !  >LFA @ CONTEXT @ ! ;

VARIABLE SCR

: EMPTY−BUFFERS ( −− ) −1 ACTIVE !
  0 DUP B0UPD ! B1UPD !  −1 DUP B0BLK ! B1BLK ! ;

: ?I/O ( f −− ) DUP 0= IF EMPTY−BUFFERS THEN
  0= ABORT" I/O ERR" ;

: ?EXIT−CACHED ( u −− a | u )
  DUP FIND−BLOCK IF SWAP ACTIVATE R> DROP THEN ;

: 0SAVE ( −− f )
  B0UPD @ IF B0ADDR B0BLK @ WRITE−BLOCK EXIT THEN −1 ;

: 1SAVE ( −− f )
  B1UPD @ IF B1ADDR B1BLK @ WRITE−BLOCK EXIT THEN −1 ;

: BUFFER ( u −− a ) ?EXIT−CACHED ACTIVE @ IF
    0SAVE ?I/O  B0BLK !  0 ACTIVE ! 0 B0UPD ! B0ADDR ELSE
    1SAVE ?I/O  B1BLK !  1 ACTIVE ! 0 B1UPD ! B1ADDR THEN ;

: BLOCK ( u −− a ) ?EXIT−CACHED
  DUP BUFFER DUP ROT READ−BLOCK ?I/O ;

: UPDATE ( −− ) ACTIVE @ 0< IF EXIT THEN
  −1 ACTIVE @ IF B1UPD ELSE B0UPD THEN ! ;

: WIPE ( −− ) ACTIVE @ 0< IF EXIT THEN
  ACTIVE @ IF B1ADDR ELSE B0ADDR THEN B/BUF BLANK ;

: COPY ( usrc udest −− ) SWAP BLOCK DROP
  ACTIVE @ IF B1BLK ELSE B0BLK THEN ! ;

: SAVE−BUFFERS ( −− )
  0SAVE 1SAVE AND ?I/O  0 DUP B0UPD ! B1UPD ! ;

: FLUSH ( −− ) SAVE−BUFFERS ;

: LIST ( u −− ) DUP SCR !  BLOCK  16 0 DO CR
    I 1+ 2 .R [CHAR] : EMIT SPACE
    DUP I B/LINE * + B/LINE TYPE  [CHAR] : EMIT
  LOOP DROP SPACE ;

: LOAD ( u −− )
  BLK @ >R  >IN @ >R  #TIB @ >R  ACTIVE @ >R
  DUP BLOCK DROP BLK !  B/BUF #TIB !  0 >IN !  INTERPRET
  R> ACTIVE !  R> #TIB !  R> >IN !  R> BLK ! ;

: THRU ( u1 u2 −− ) 1+ SWAP DO I . I LOAD LOOP ;

: INDEX ( n1 n2 −− ) 0 −ROT
  1+ SWAP DO CR I 0 .R [CHAR] : EMIT SPACE
    I BLOCK B/LINE TYPE  1+ DUP 20 > IF
      ?ENOUGH IF UNLOOP DROP EXIT THEN
      DROP 0 THEN
    LOOP DROP ;

: RESET ( −− ) FORTH DEFINITIONS
  EMPTY−BUFFERS  DECIMAL  [HEX] F380 UP !
  $" T3XFORTH" COUNT TYPE CR  ABORT ;

: (QUIT) ( −− )
  BEGIN R0 RP!  CONSOLE  QUERY INTERPRET .OK AGAIN ;
  IS QUIT  COMPILE−ONLY

: (FENCE) ;
' (FENCE) >NFA ' FENCE !

contact  |  privacy