ONLY ALSO FORTH DEFINITIONS

CR .( 8086 eForth ITC 16bit inline model for MS-DOS )
CR .( Copyright Bill Muench All rights reserved. )

( Bill Muench \ OntoLogic )
(             \ Santa Cruz  CA  95065 )

(        tracks ============================================ )
( 971011 change CURRENT SFIND NAMED? MARKER WORDS )
( 971005 change _[ _] ?STACK only called after EXECUTE )
(        rename DELIMIT PARSE-WORD  add [CHAR] )
( 971003 rename pass _PASS  wake _WAKE  do" _" )
(        rename parse _PARSE  delimit _DELIMIT  do[ _[  do] _] )
(        remove >NAME  change DUMP SSEE )
( 970923 change _DOES> DOES> to use TOKEN and :NONAME )
( 970304 change ALIGNED DEPTH HAT =  add 0= NIP BOUNDS )
( 950717 change ACCEPT TOKEN? to NAMED?  remove CON )
( 950627 change to inline names 16k image )
(        change ALIGNED too slow )
(        change NAME>  SEE  HEAD,  CODE  :  PACK  DP  MARKER  DOES> )
(        rename _IF _ELSE _S" _." _ABORT" _DOES> _MARKER )
(        rename _CON _VAR _USR  ADR> to NAMED? )
(        add /STRING S, SLITERAL )
( 950525 add ALIGN to _DOES> )
( 950511 change QUIT  add 'OK LTOKEN CTOKEN  rename find to SFIND )
( 950410 change D. space at end, SSEE )
( 950322 add TOKEN  fix RECURSE with :NONAME )
( 950321 CONTEXT find WORDLIST ORDER@ GET-ORDER SET-ORDER )
( 941011 STOP TYPE _TYPE DUMP DM+ )
( 941006 2.5.0 )
(        add INITIALIZETARGETIMAGE )
(        add ALIGN to ] MARKER WORDLIST  change PACK _TYPE DM+ )
(        change ' POSTPONE CR ACCEPT BL .ID LEX! does if else )
(        change to linked search order WID? CONTEXT find )
(        REVEAL LAST FORTH-WORDLIST VLINK WORDLIST HEAD, WORDS )
(        GET-ORDER SET-ORDER marker MARKER >NAME ADR> )
( 940817 ITC 1616 )
(        change from CMOVE to MOVE )
(        remove use of CHARS )
(        Environmental dependency: )
(          only two's complement arithmetic supported )
(            ie true flags=-1 and NEGATE )
(          systems with char<byte NOT supported )
( 940815 ITC 3232 32bit tokens )
( 940814 ITC again! )
( 940806 2.4.2 )
(        remove new NEW c" C" )
(        add search order  W- W+ )
(        rename LEX! LIT DOES If Else  BKSP )
(               !lex lit does if else =BKSP )
(        rename <RESOLVE >MARK search-wordlist )
(               RESOLVE  MARK  WID? )
(        change ADR> ALIGNED >MARK DM+ DUMP WORDS HEAD, )
(               find ?UNIQUE marker MARKER QUIT )
( 940523 2.4.1 32bit meta C, )
(        change WORDS USERs BUILD ACTIVATE HAT DEPTH QUIT COLD )
(        replace HLD with HERE in ' POSTPONE  change >MARK )
( 940520 remove END-CODE STRING, CONSTANTs -1 0 1 2 )
( 940519 remove TIB  add SOURCE  change 32bit return stack )
( 940513 add CR to ?UNIQUE )
(        replace HERE with HLD in ' POSTPONE )
( 930811 2.40 )
( 930809 start 32bit eForth with 16bit tokens )
( 930731 ah, postfix again )
( 930719 remove ?STACK from EVALUATE add to _[ and _] )
( 930604 ' saves name address at HERE  add [ to REVEAL )
(        add POSTPONE  remove COMPILE [COMPILE] )
( 930530 add CHAR- CHAR+ CHARS COMPILE,  change ERF to TF )
( 930326 remove use of FOR NEXT AFT )
(        change EVAL to EVALUATE  remove >RESOLVE <MARK )
( 930224 add multitasker )
( 930212 2.30 convert to BTC )
(        add >ADR ADR>  remove QUERY )
( 920326 S.R H# _" _[ _] )
( 920324 replace SHIFT with LSHIFT RSHIFT )
(        replace NOT with INVERT )
( 920219 fix IMMEDIATE COMPILE-ONLY  change [[ to REVEAL dak )
(        new MARKER  QUIT  ALIGN  HEAD, )
( 920205 WORDS  2@ 2!  CR  remove FILE HAND  change FROM )
( 920126 -SAME? SHIFT abort" .OK )
( 920112 seperate _DELIMIT DELIMIT from _PARSE PARSE  STATE )
(        double number output and input  EVAL QUIT )
( 920110 use C@ in _PARSE -SAME? find  ,C"  BKSP dak )
( 911121 PACK STDIN :  remove TOKEN WORD NAME?  add S" )
( 910828 DUMP field size jf )
( 910722 ANS update C" ACCEPT PICK  add DOES> >BODY SM/REM )
( 910719 update : TOKEN WORD  add FROM STDIN stdin :NONAME )
( 910408 accept rid EXPECT add MARKER NEW )
( 910405 ITC update )
( 900707 convert to MASM format )
( 900412 start model meta-compile )
( 89xxxx bForth MS-DOS version )
(        coyote ============================================ )

( Notation )
  ( 0x00      Boot Firmware byte codes )
  ( 0.0.0000  ANS reference numbers )

( Conventions )
  ( a   address )
  ( c   character )
  ( f   flag  0 or non-zero )
  ( n   signed single )
  ( d   signed double )
  ( u   unsigned single )
  ( ud  unsigned double )
  ( xt  execution token )

( Name structure: link\count\name string\attribute )
  ( 'link' pointer to next 'name string' )
  ( 'count' byte length of name string 'nnnn nnnn' )
  (   n - string length, 255 bytes max )
  ( 'name string' variable length ascii 'ccc' )
  (   compiler does not set bits in the 'name string' )
  ( 'attribute' byte compiler flags 'icxx xxxx' )
  (   i - immediate )
  (   c - compile only )
  (   x - reserved )
  ( 0 < la na < ... < la na < last name compiled )

( 8086 register usage )
  ( flags the direction bit must normally be cleared. CLD )
  ( SI    IP Interpreter  Pointer  DS:SI )
  ( BP    RP Return stack Pointer  SS:BP builds up )
  ( SP    SP data Stack   Pointer  SS:SP builds down )
  ( CS=DS=SS  the segment registers must be equal )
  (       or changed temporarily within a code word. )

  ( ES    free )
  ( DI    free  ES:DI )
  ( AX    free )
  ( BX    free )
  ( CX    free )
  ( DX    free )

( ========================================================== )

META[ CR .( Metacompile Begin )

CR .( System equates )

D# 16 EQU #UP ( user variable )
D# 64 EQU #RP ( return stack )
D# 64 EQU #SP ( data stack )

D# 80 EQU #TIB ( input buffer size ) ( 6.2.0060 )

D# 80 #BITS D# 2 * D# 2 + MAX ( min [#BITS*2]+2 to format in base2 )
      EQU #PAD ( size above HERE for temporary user buffer )

H# 40 EQU =COMP ( attribute compile-only bit )
H# 80 EQU =IMED ( attribute immediate bit )

D# 8  EQU #VOCS ( vocabulary stack depth )
D# 16 EQU #DUMP ( bytes per line, adjust to display )

D# 13 EQU =CR ( the carrage return character )
D# 10 EQU =LF ( the line feed character )
D# 8  EQU =BS ( the backspace character )
D# 32 EQU =BL ( the blank character )

.( Memory allocation )

( bootdata\dp>-pad>---<u\r>--<s\tib>- )

H# 2000 !IMAGE ( max target image size in bytes )

H# FFFE ALIGNED      ( end of memory, index down )
#TIB CHARS ALIGNED - ( allocate input buffer )
    DUP EQU =TIB     ( terminal input buffer )
    DUP EQU =SP      ( data stack, builds down )
#SP CELLS -          ( allocate data stack, MS-DOS also uses! )
#RP CELLS -          ( allocate return stack )
        EQU =RP      ( return stack, builds up )

( ========================================================== )

.( System entry point )

H# 100 ORG

PROC RESET ( cold start entry )
  D# 0 ## ax mov ( patch with VCOLD )
  ax jmp
END-CODE

LABEL =VERSION
  ,C" eForth ITC16i 971014.1"

LABEL =(C)
  ,C" Copyright Bill Muench All rights reserved."

.( Interpreters )

CODE EXIT ( -- ) ( R: a -- ) ( 6.1.1380 )( 0x33 ) \ ITC
  D# 0 bp [] si mov    ( unnest )
  D# 1 CELLS ## bp sub ( pop RP )
LABEL NEXT1            ( label for next, )
  lods                 ( next token )
  ax di mov  D# 0 di [] jmp ( new interpreter )
END-CODE

PROC LIST1          ( entry for : words ) \ ITC
  D# 1 CELLS ## bp add ( push RP )
  si D# 0 bp [] mov    ( nest )
  D# 1 CELLS ## di add
  di si mov  next,     ( new list )
END-CODE

CODE EXECUTE ( xt -- ) ( 6.1.1370 )( 0x1D ) \ ITC
  di pop  D# 0 di [] jmp
END-CODE

CODE _LIT ( -- n ) ( 0x10 )
  lods  ax push  next,
END-CODE COMPILE-ONLY

.( Branch )

CODE _ELSE ( -- ) ( 0x13 )
  D# 0 si [] si mov  next, ( absolute branch )
END-CODE COMPILE-ONLY

CODE _IF ( f -- ) ( 0x14 )
  bx pop  bx bx or
  z= if ( branch if f=0 )
    D# 0 si [] si mov  next, ( absolute branch )
  then  D# 1 CELLS ## si add  next, ( continue )
END-CODE COMPILE-ONLY

.( Memory read & write )

CODE C! ( c a -- ) ( 6.1.0850 )( 0x75 )
  bx pop  ax pop  al D# 0 bx [] mov  next,
END-CODE

CODE C@ ( a -- c ) ( 6.1.0870 )( 0x71 )
  bx pop  ax ax xor  D# 0 bx [] al mov  ax push  next,
END-CODE

CODE ! ( n a -- ) ( 6.1.0010 )( 0x72 )
  bx pop  D# 0 bx [] pop  next,
END-CODE

CODE @ ( a -- n ) ( 6.1.0650 )( 0x6D )
  bx pop  D# 0 bx [] push  next,
END-CODE

.( Return stack )

CODE RP@ ( -- a )
  bp push  next,
END-CODE

CODE RP! ( a -- )
  bp pop  next,
END-CODE COMPILE-ONLY

CODE >R ( n -- ) ( R: -- n ) ( 6.1.0580 )( 0x30 )
  D# 1 CELLS ## bp add  D# 0 bp [] pop  next,
END-CODE COMPILE-ONLY

CODE R@ ( -- n ) ( R: n -- n ) ( 6.1.2070 )( 0x32 )
  D# 0 bp [] push  next,
END-CODE

CODE R> ( -- n ) ( R: n -- ) ( 6.1.2060 )( 0x31 )
  D# 0 bp [] push  D# 1 CELLS ## bp sub  next,
END-CODE COMPILE-ONLY

.( Data stack )

CODE SP@ ( -- a )
  sp bx mov  bx push  next,
END-CODE

CODE SP! ( a -- )
  sp pop  next,
END-CODE

CODE DROP ( n -- ) ( 6.1.1260 )( 0x46 )
  bx pop  next,
END-CODE

CODE SWAP ( n1 n2 -- n2 n1 ) ( 6.1.2260 )( 0x49 )
  bx pop  ax pop  bx push  ax push  next,
END-CODE

CODE DUP ( n -- n n ) ( 6.1.1290 )( 0x47 )
  bx pop  bx push  bx push  next,
END-CODE

CODE OVER ( n1 n2 -- n1 n2 n1 ) ( 6.1.1990 )( 0x48 )
  bx pop  ax pop  ax push  bx push  ax push  next,
END-CODE

.( ALU )

CODE CHAR- ( a -- a )
  bx pop  D# 1 CHARS ## bx sub  bx push  next,
END-CODE

CODE CHAR+ ( a -- a ) ( 6.1.0897 )( 0x62 )
  bx pop  D# 1 CHARS ## bx add  bx push  next,
END-CODE

CODE CHARS ( n -- n ) ( 6.1.0898 )( 0x66 )
  next,
END-CODE

CODE CELL- ( a -- a )
  bx pop  D# 1 CELLS ## bx sub  bx push  next,
END-CODE

CODE CELL+ ( a -- a ) ( 6.1.0880 )( 0x65 )
  bx pop  D# 1 CELLS ## bx add  bx push  next,
END-CODE

CODE CELLS ( n -- n ) ( 6.1.0890 )( 0x69 )
  bx pop  D# 1 ## bx shl  bx push  next,
END-CODE

CODE 0< ( n -- f ) ( 6.1.0250 )( 0x36 )
  ax pop  cwd  dx push  next,
END-CODE

CODE AND ( n n -- n ) ( 6.1.0720 )( 0x23 )
  bx pop  ax pop  ax bx and  bx push  next,
END-CODE

CODE OR ( n n -- n ) ( 6.1.1980 )( 0x24 )
  bx pop  ax pop  ax bx or  bx push  next,
END-CODE

CODE XOR ( n n -- n ) ( 6.1.2490 )( 0x25 )
  bx pop  ax pop  ax bx xor  bx push  next,
END-CODE

CODE UM+ ( u u -- u cy )
  bx pop  ax pop  bx ax add
  D# 0 ## bx mov  bx bx adc
  ax push  bx push  next,
END-CODE

.( System dependent I/O )

( MS-DOS only ============================================== )

CODE REDIRECT ( asciiz -- f )
  dx pop                ( dx=filespec0 )
  H# 3D00 ## ax mov     ( open file read-only )
  H# 21 int
  u< ~ if               ( ?err )
    D# 0 ## cx mov      ( stdin )
    ax bx mov           ( file handle )
    H# 4600 ## ax mov   ( redirect handle )
    H# 21 int           ( file = stdin )
    u< ~ if             ( ?err )
      H# 3E00 ## ax mov ( close file )
      H# 21 int
      u< ~ if           ( ?err )
        ax ax xor       ( no err )
      then
    then
  then ax push  next,   ( error code )
END-CODE COMPILE-ONLY

( ========================================================== )

CODE !IO ( u -- ) ( initialize I/O device )
  bx pop  next, ( nothing to do for MS-DOS )
END-CODE

CODE ?RX ( -- c -1 | 0 )
  bx bx xor          ( BX=0 setup false flag )
  H# FF ## dl mov    ( command == input )
  D# 6 ## ah mov     ( MS-DOS Direct Console I/O )
  H# 21 int
  z= ~ if            ( ?key ready )
    al al or         ( AL=0 if extended code )
    z= if            ( ?extended code )
      H# 21 int      ( AH=6 still )
      al ah mov      ( extended code in msb )
      bl al mov      ( al=0 )
    else bh ah mov   ( ah=0 )
    then
    ax push          ( save character )
    bx dec           ( true flag )
  then  bx push  next,
END-CODE

CODE TX! ( c -- )
  dx pop           ( char in DL )
  D# 2 ## ah mov   ( MS-DOS Character Output )
  H# 21 int  next, ( ^C will terminate )
END-CODE

( ============================================================ )

: NOOP ( -- ) ( 0x7B ) ;

.( System variables )

: _VAR ( -- a ) ( 0xB9 ) R> ; COMPILE-ONLY
: _CON ( -- n ) ( 0xBA ) R> @ ; COMPILE-ONLY

CREATE '?KEY ( input device vector )
  ' ?RX ,
CREATE 'EMIT ( output device vector )
  ' TX! ,

VARIABLE BASE ( numeric radix ) ( 6.1.0750 )( 0xA0 )
VARIABLE DPL  ( numeric input decimal place )
VARIABLE HLD  ( numeric output string pointer )

VARIABLE >IN ( input buffer offset ) ( 6.1.0560 )
CREATE #IN   ( input buffer count )
  D# 2 CELLS ALLOT ( input buffer address )

VARIABLE CSP ( save stack pointer )

CREATE STATE ( interpret/compile flag ) ( 6.1.2250 )( 0xDC )
  D# 2 CELLS ALLOT ( interpret/compile vector )

CREATE DP ( dictionary pointer )
  D# 2 CELLS ALLOT

CREATE SUP ( -- tid )
  =RP , ( return stack )
  =SP , ( data stack )

=BL CONSTANT BL ( -- c ) ( 6.1.0770 )( 0xA9 )

.( Common functions )

: HEX ( -- ) ( 6.2.1660 ) D# 16 BASE ! ;
: DECIMAL ( -- ) ( 6.1.1170 ) D# 10 BASE ! ;

: ROT ( n1 n2 n3 -- n2 n3 n1 ) ( 6.1.2160 )( 0x4A ) >R SWAP R> SWAP ;
: NIP ( n1 n2 -- n2 ) ( 6.2.1930 )( 0x4D ) SWAP DROP ;
: 2DROP ( n n -- ) ( 6.1.0370 )( 0x52 ) DROP DROP ;
: 2DUP ( n1 n2 -- n1 n2 n1 n2 ) ( 6.1.0380 )( 0x53 ) OVER OVER ;
: ?DUP ( n -- n n | 0 ) ( 6.1.0630 )( 0x50 ) DUP IF DUP THEN ;

: + ( n n -- n ) ( 6.1.0120 )( 0x1E ) UM+ DROP ;
: D+ ( d d -- d ) ( 8.6.1.1040 )( 0xD8 ) >R  SWAP >R  UM+  R> +  R> + ;

: INVERT ( n -- n ) ( 6.1.1720 )( 0x26 ) D# -1 XOR ;

: NEGATE ( n -- n ) ( 6.1.1910 )( 0x2C ) INVERT D# 1 + ;
: DNEGATE ( d -- d ) ( 8.6.1.1230 ) INVERT >R INVERT D# 1 UM+ R> + ;

: S>D ( n -- d ) ( 6.1.2170 ) DUP 0< ;
: ABS ( n -- u ) ( 6.1.0690 )( 0x2D ) DUP 0< IF NEGATE THEN ;
: DABS ( d -- ud ) ( 8.6.1.1160 ) DUP 0< IF DNEGATE THEN ;

: - ( n n -- n ) ( 6.1.0160 )( 0x1F ) NEGATE + ;

: PICK ( n -- n ) ( 6.2.2030 )( 0x50 )
  ?DUP IF SWAP >R D# 1 - RECURSE R> SWAP EXIT THEN DUP ;

.( Comparison )

: 0= ( n -- f ) ( 6.1.0270 )( 0x34 ) IF D# 0 EXIT THEN D# -1 ;
: = ( n n -- f ) ( 6.1.0530 )( 0x3C ) XOR 0= ;

: U< ( u u -- f ) ( 6.1.2340 )( 0x40 ) 2DUP XOR 0< IF  NIP 0< EXIT THEN - 0< ;
:  < ( n n -- f ) ( 6.1.0480 )( 0x3A ) 2DUP XOR 0< IF DROP 0< EXIT THEN - 0< ;

: MAX ( n n -- n ) ( 6.1.1870 )( 0x2F ) 2DUP      < IF SWAP THEN DROP ;
: MIN ( n n -- n ) ( 6.1.1880 )( 0x2E ) 2DUP SWAP < IF SWAP THEN DROP ;

: WITHIN ( u ul uh -- f ) ( 6.2.2440 )( 0x45 ) OVER - >R - R> U< ;

.( Multiply )

: LSHIFT ( u n -- u ) ( 6.1.1805 )( 0x27 )
  BEGIN DUP
  WHILE >R  DUP +  R> D# 1 -
  REPEAT DROP ;

: UM* ( u u -- ud ) ( 6.1.2360 )( 0xD4 )
  D# 0 SWAP  [ #BITS ] LITERAL
  BEGIN DUP
  WHILE >R  DUP UM+ >R >R  DUP UM+ R> + R>
    IF >R OVER UM+ R> + THEN  R> D# 1 -
  REPEAT DROP >R  NIP R> ;

: * ( n n -- n ) ( 6.1.0090 )( 0x20 ) UM* DROP ;

.( Divide )

: RSHIFT ( u n -- u ) ( 6.1.2162 )( 0x28 )
  D# 0 SWAP  [ #BITS ] LITERAL SWAP -
  BEGIN DUP
  WHILE >R  2DUP D+  R> D# 1 -
  REPEAT DROP  NIP ;

: UM/MOD ( ud u -- ur uq ) ( 6.1.2370 )( 0xD5 )
  2DUP U<
  IF NEGATE  [ #BITS ] LITERAL
    BEGIN DUP
    WHILE >R  >R  DUP UM+ >R >R  DUP UM+ R> +
      DUP R> R@ SWAP >R UM+  R> OR
      IF >R DROP D# 1 + R> ELSE DROP THEN R>  R> D# 1 -
    REPEAT 2DROP SWAP EXIT
  THEN DROP 2DROP  D# -1 DUP ;

: SM/REM ( d n -- r q ) ( 6.1.2214 ) ( symmetric )
  OVER >R >R  DABS R@ ABS UM/MOD
  R> R@ XOR 0< IF NEGATE THEN  R> 0< IF >R NEGATE R> THEN ;

: FM/MOD ( d n -- r q ) ( 6.1.1561 ) ( floored )
  DUP 0<  DUP >R IF NEGATE >R DNEGATE R> THEN
  >R DUP 0< IF R@ + THEN R> UM/MOD R> IF >R NEGATE R> THEN ;

: /MOD ( n n -- r q ) ( 6.1.0240 )( 0x2A ) OVER 0< SWAP  FM/MOD ; ( or SM/REM )

: MOD ( n n -- r ) ( 6.1.1890 )( 0x22 ) /MOD DROP ;
: / ( n n -- q ) ( 6.1.0230 )( 0x21 ) /MOD NIP ;

.( Memory access )

: +! ( n a -- ) ( 6.1.0130 )( 0x6C ) DUP >R @ + R> ! ;
: COUNT ( a -- a c ) ( 6.1.0980 )( 0x84 ) DUP CHAR+ SWAP C@ ;
: BOUNDS ( a n -- a+n a ) ( 0xAC ) OVER + SWAP ;
: /STRING ( a u n -- a+n u-n ) ( 17.6.1.0245 ) DUP >R - SWAP R> CHARS + SWAP ;
: ALIGNED ( a -- a ) ( 6.1.0706 )( 0xAE ) ( depends on 2's comp and 2^n cell size )
  [ D# 1 CELLS D# 1 - DUP ] LITERAL + [ INVERT ] LITERAL AND ;

: 2! ( u u a -- ) ( 6.1.0310 )( 0x77 ) SWAP OVER ! CELL+ ! ;
: 2@ ( a -- u u ) ( 6.1.0350 )( 0x76 ) DUP CELL+ @ SWAP @ ;

: MOVE ( a a u -- ) ( 6.1.1900 )( 0x78 )
  >R  2DUP U<
  IF
    BEGIN R> DUP
    WHILE CHAR- >R  OVER R@ + C@  OVER R@ + C!
    REPEAT DROP  2DROP EXIT
  THEN R> OVER + >R
  BEGIN DUP R@ XOR
  WHILE >R  DUP C@ R@ C!  CHAR+ R> CHAR+
  REPEAT R> DROP  2DROP ;

: FILL ( a u c -- ) ( 6.1.1540 )( 0x79 )
  >R  CHARS BOUNDS
  BEGIN 2DUP XOR
  WHILE R@ OVER C!  CHAR+
  REPEAT R> DROP 2DROP ;

: -TRAILING ( a u -- a u ) ( 17.6.1.0170 )
  BEGIN DUP
  WHILE D# 1 -  2DUP CHARS + C@  BL SWAP U<
  UNTIL D# 1 + THEN ;

: >ADR ( xt -- a ) ; \ ITC
: >BODY ( xt -- a ) ( 6.1.0550 )( 0x86 ) >ADR CELL+ CELL+ ; \ ITC

.( Multitask )

VARIABLE UP ( current task pointer )
: _USR ( -- a ) UP @ R> @ + ; COMPILE-ONLY

( U1\TF\TID\TOS\STATUS\FOLLOWER\r>--<s  order IS important )
1 CELLS ( init offset )
  CELL- DUP USER FOLLOWER ( address of next task's STATUS )
  CELL- DUP USER STATUS   ( PASS or WAKE )
  CELL- DUP USER TOS      ( top of stack )
  CELL- DUP USER TID      ( back link tid )
  CELL- DUP USER TF       ( throw frame )
  CELL- DUP USER U1       ( free )
DROP ( cleanup )

: 'S ( tid a -- a ) ( index another task's local variable )
  FOLLOWER  CELL+ - SWAP @ + ;

: _PASS ( -- ) ( hilevel absolute branch )
  R> @ >R ; COMPILE-ONLY
' _PASS CONSTANT PASS

: _WAKE ( -- ) ( restore follower )
  R> UP !  TOS @ SP! RP! ; COMPILE-ONLY
' _WAKE CONSTANT WAKE

: PAUSE ( -- ) ( allow another task to execute )
  RP@  SP@ TOS !  FOLLOWER @ >R ;

: STOP ( -- ) ( sleep current task )
  PASS STATUS ! PAUSE ; COMPILE-ONLY

: GET ( semaphore -- )
  PAUSE ( remember your manners )
  DUP @ STATUS XOR ( owner ? )
  IF BEGIN DUP @ WHILE PAUSE REPEAT ( no, wait for release )
    STATUS SWAP ! ( lock ) EXIT
  THEN DROP ;

: RELEASE ( semaphore -- )
  DUP @ STATUS XOR IF DROP EXIT THEN  D# 0 SWAP ! ( unlock ) ;

: SLEEP ( tid -- ) ( sleep another task )
  PASS SWAP STATUS 'S ! ;

: AWAKE ( tid -- ) ( wake another task )
  WAKE SWAP STATUS 'S ! ;

: ACTIVATE ( tid -- )
  DUP 2@        ( tid sp rp )
  R> OVER !     ( save entry at rp )
  OVER !        ( save rp at sp )
  OVER TOS 'S ! ( save sp in tos )
  AWAKE ; COMPILE-ONLY

: BUILD ( tid -- )
  DUP SLEEP                     ( sleep new task )
  FOLLOWER @ OVER FOLLOWER 'S ! ( link new task )
  DUP STATUS 'S FOLLOWER !      ( link old task )
  DUP TID 'S ! ;                ( link to tid )

.( Numeric input )

: DIGIT? ( c base -- u f ) ( 0xA3 )
  >R [CHAR] 0 - D# 9 OVER <
  IF D# 7 - DUP D# 10 < OR THEN DUP R> U< ;

: >NUMBER ( ud a u -- ud a u ) ( 6.1.0570 )
  BEGIN DUP
  WHILE >R  DUP >R C@ BASE @ DIGIT?
  WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> CHAR+ R> D# 1 -
  REPEAT DROP R> R> THEN ;

: NUMBER? ( a u -- d -1 | a u 0 )
  OVER C@ [CHAR] - = DUP >R IF D# 1 /STRING THEN
  >R >R  D# 0 DUP  R> R>  D# -1 DPL !
  BEGIN >NUMBER DUP
  WHILE OVER C@ [CHAR] . XOR
    IF ROT DROP ROT R> 2DROP  D# 0 EXIT
    THEN D# 1 - DPL !  CHAR+  DPL @
  REPEAT 2DROP R> IF DNEGATE THEN D# -1 ;

.( Numeric output )

: HERE ( -- a ) ( 6.1.1650 )( 0xAD ) DP @ ;
: PAD ( -- a ) ( 6.2.2000 ) HERE [ #PAD CHARS ] LITERAL + ;

: <# ( -- ) ( 6.1.0490 )( 0x96 ) PAD HLD ! ;
: DIGIT ( u -- c ) D# 9 OVER < D# 7 AND + [CHAR] 0 + ;
: HOLD ( c -- ) ( 6.1.1670 )( 0x95 ) HLD @ CHAR- DUP HLD ! C! ;

: # ( d -- d ) ( 6.1.0030 )( 0xC7 )
  D# 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ;

: #S ( d -- d ) ( 6.1.0050 )( 0xC8 ) BEGIN # 2DUP OR 0= UNTIL ;
: #> ( d -- a u ) ( 6.1.0040 )( 0xC9 ) 2DROP HLD @ PAD OVER - ;

: SIGN ( n -- ) ( 6.1.2210 )( 0x98 ) 0< IF [CHAR] - HOLD THEN ;

.( Error handling )

: CATCH ( xt -- 0 | err ) ( 9.6.1.0875 )( 0x217 )
  SP@ >R  TF @ >R  RP@ TF !  EXECUTE  R> TF !  R> DROP  D# 0 ;

: THROW ( 0 | err -- | err ) ( R: i*x i*y -- i*x i*y | i*x ) ( 9.6.1.2275 )( 0x218 )
  ?DUP IF TF @ RP!  R> TF !  R> SWAP >R SP! DROP R> THEN ;

: ABORT ( i*n -- ) ( R: i*x i*y -- i*x ) ( 9.6.2.0670 )( 0x216 ) D# -1 THROW ;

.( Basic I/O )

: ?KEY ( -- c -1 | 0 )  PAUSE  '?KEY @ EXECUTE ;
: KEY ( -- c ) ( 6.1.1750 )( 0x8E ) BEGIN ?KEY UNTIL ;
: NUF? ( -- f ) ?KEY DUP IF 2DROP KEY [ =CR ] LITERAL = THEN ;

: EMIT ( c -- ) ( 6.1.1320 )( 0x8F ) 'EMIT @ EXECUTE ;
: SPACE ( -- ) ( 6.1.2220 ) BL EMIT ; ,C" coyote"

: EMITS ( n c -- )
  SWAP D# 0 MAX BEGIN DUP WHILE OVER EMIT D# 1 - REPEAT 2DROP ;
: SPACES ( n -- ) ( 6.1.2230 ) BL EMITS ;

: TYPE ( a u -- ) ( 6.1.2310 )( 0x90 )
  CHARS BOUNDS BEGIN 2DUP XOR WHILE COUNT EMIT REPEAT 2DROP ;
: CR ( -- ) ( 6.1.0990 )( 0x92 ) [ =CR ] LITERAL EMIT [ =LF ] LITERAL EMIT ;

: _" ( -- a )
  R> R> DUP COUNT CHARS + ALIGNED >R SWAP >R ; COMPILE-ONLY

: _S" ( -- a u ) _" COUNT ; COMPILE-ONLY
: _." ( -- ) ( 0x12 ) _" COUNT TYPE ; COMPILE-ONLY
: _ABORT" ( i*n f -- i*n | ) ( R: i*x i*y -- i*x i*y | i*x )
  IF _" CSP ! D# -2 THROW THEN _" DROP ; COMPILE-ONLY

: S.R ( a u n -- ) OVER - SPACES TYPE ;
: D.R ( d n -- ) ( 8.6.1.1070 ) >R DUP >R DABS <# #S R> SIGN #> R> S.R ;
: U.R ( u n -- ) ( 6.2.2330 )( 0x9C ) D# 0 SWAP D.R ;
: .R ( n n -- ) ( 6.2.0210 )( 0x9E ) >R S>D R> D.R ;

: D. ( d -- ) ( 8.6.1.1060 ) D# 0 D.R SPACE ;
: U. ( u -- ) ( 6.1.2320 )( 0x9B ) D# 0 D. ;
: . ( n -- ) ( 6.1.0180 )( 0x9D ) BASE @ D# 10 XOR IF U. EXIT THEN S>D D. ;
: ? ( a -- ) ( 15.6.1.0600 ) @ . ;

.( Bits & Bytes )

: PACK ( a1 u a2 -- a2 ) ( 0x83 )
  OVER D# 256 U<
  IF DUP >R  OVER >R  CHAR+ SWAP CHARS MOVE  R> R@ C!  R> EXIT
  THEN D# -18 THROW ;

: DEPTH ( -- n ) ( 6.1.1200 )( 0x51 )
  SP@  TID @ CELL+ @  SWAP - [ D# 1 CELLS ] LITERAL / ;
: ?STACK ( -- ) DEPTH 0< ABORT" depth?" ;

.( Terminal )

: ACCEPT ( a u -- u ) ( 6.1.0695 )
  OVER + OVER ( bot eot cur )
  BEGIN KEY
    DUP [ =CR ] LITERAL XOR ( carrage return ? )
  WHILE
    DUP [ =BS ] LITERAL = ( backspace ? )
    IF ( destructive backspace )
      DROP  >R OVER R@ < DUP ( any chars ? )
      IF [ =BS ] LITERAL DUP EMIT  BL EMIT  EMIT
      THEN R> +
    ELSE ( printable )
      >R  2DUP XOR ( more ? )
      IF R@ OVER C!  CHAR+  R@ EMIT
      THEN R> DROP
    THEN
  REPEAT DROP  NIP  SWAP - ;

.( Interpreter )

: SAME? ( a a u -- f ) \ ???faster chars
  SWAP >R
  BEGIN DUP
  WHILE CHAR-  2DUP + C@  OVER R@ + C@  XOR
  UNTIL R> DROP 2DROP  D# 0 EXIT ( no match )
  THEN R> DROP 2DROP  D# -1 ; ( found )

: _DELIMIT ( a u -- a u delta ) \ ???chars
  BOUNDS  DUP >R  CHAR-
  BEGIN CHAR+  2DUP XOR ( skip leading BL )
  WHILE BL OVER C@ <
  UNTIL SWAP OVER ( save first non blank addr )
    BEGIN CHAR+  2DUP XOR ( scan trailing BL )
    WHILE DUP C@  BL D# 1 +  <
    UNTIL NIP  DUP CHAR+ ( found )
    ELSE DROP DUP ( not found )
    THEN >R  OVER -  R>
  ELSE DROP D# 0 OVER ( all BL )
  THEN R> - ;

: _PARSE ( a1 u1 c -- a1 u2 delta ) \ ???chars
  >R  OVER +  OVER CHAR- ( save char, adjust addr )
  BEGIN CHAR+  2DUP XOR ( inc addr ? )
  WHILE DUP C@ R@ = ( match ? )
  UNTIL SWAP R> 2DROP  OVER -  DUP D# 1 + EXIT ( found )
  THEN  SWAP R> 2DROP  OVER -  DUP ; ( not found )

: NAME> ( a -- xt ) COUNT CHARS + CHAR+ ALIGNED ;

: WID? ( a u wid -- xt lex -1 | a u 0 ) \ ???chars
  SWAP >R  @ ( address of last word )
  BEGIN DUP ( last word ? )
  WHILE COUNT R@ = ( count ? )
    IF 2DUP R@ SAME? ( match )
      IF SWAP R> 2DROP CHAR-
        DUP NAME>  SWAP COUNT CHARS + C@  D# -1 EXIT ( found )
      THEN
    THEN CHAR-  CELL- @ ( link )
  REPEAT DROP R>  D# 0 ; ( no match )

CREATE CONTEXT ( search order )
  #VOCS D# 1 + CELLS ALLOT ( wids )

: SFIND ( a u -- xt lex -1 | a u 0 )
  CONTEXT CELL- >R ( setup )
  BEGIN R> CELL+ DUP >R @ DUP ( wid | 0 )
  WHILE WID? ( found ? )
  UNTIL D# -1 THEN R> DROP ;

: _[ ( a u -- ) ( the Forth interpreter )
  SFIND ( search dictionary )
  IF [ =COMP ] LITERAL AND ABORT" compile?"
    EXECUTE ?STACK EXIT
  THEN
  NUMBER? ( unknown symbol, try to convert a number )
  IF DPL @ 0< ( single? )
    IF DROP THEN EXIT
  THEN D# -13 THROW ; COMPILE-ONLY
: [ ( -- ) ( 6.1.2500 ) ['] _[  D# 0  STATE 2! ; IMMEDIATE

: SOURCE ( -- a u ) ( 6.1.2216 ) #IN 2@ ;
: PARSE-WORD ( "ccc" -- a u ) SOURCE >IN @ /STRING _DELIMIT >IN +! ;

: EVALUATE ( a u -- ) ( 6.1.1360 )( 0xCD )
  >IN @ >R  D# 0 >IN !  SOURCE >R >R  #IN 2!
  BEGIN PARSE-WORD DUP
  WHILE STATE CELL+ @ EXECUTE
  REPEAT 2DROP  R> R> #IN 2!  R> >IN ! ;

( redirect input MS-DOS only =============================== )

: ASCIIZ ( a u a -- a )
  DUP >R  SWAP CHARS  2DUP + D# 0 SWAP C!  MOVE  R> ;

: STDIN ( a u -- )
  HERE ASCIIZ REDIRECT ABORT" file?" ; COMPILE-ONLY

: FROM ( "ccc" -- ) ( chain not nest )
  PARSE-WORD STDIN  SOURCE >IN ! DROP ;

( ========================================================== )

CREATE 'OK ( prompt options )
  ' NOOP , ( typically .S )
: QUIT ( -- ) ( R: i*x -- ) ( 6.1.2050 )
  SUP @ RP!         ( reset return stack )
  [ ' [ COMPILE, ]  ( reset interpret state )
  S" CON" STDIN     ( reset console i/o, MS-DOS only )
  BEGIN
    BEGIN
      [ =TIB ] LITERAL  ( input buffer )
      DUP [ #TIB ] LITERAL ACCEPT SPACE ( user input )
      ['] EVALUATE CATCH DUP ( error ? )
      IF DUP D# -1 XOR      ( ABORT  = -1 )
        IF CR DUP D# -2 XOR ( ABORT" = -2 )
          IF SOURCE DROP ( undefined error )
            >IN @ -TRAILING TYPE ."  ?(" D# 0 .R ." )"
          ELSE CSP @ COUNT TYPE
          THEN SPACE
        THEN
        SUP CELL+ @ SP! ( reset data stack )
        RECURSE         ( restart )
      THEN CR STATE @ = ( 0 from CATCH )
    UNTIL 'OK @ EXECUTE ." ok " ( prompt )
  AGAIN ;

.( Compiler )

: ALIGN ( -- ) ( 6.1.0705 ) HERE ALIGNED DP ! ;

: ALLOT ( n -- ) ( 6.1.0710 ) DP +! ;
: S, ( a u -- ) HERE  OVER CHARS CHAR+ ALLOT  PACK DROP ;
: C, ( n -- ) ( 6.1.0860 )( 0xD0 ) HERE  [ D# 1 CHARS ] LITERAL ALLOT  C! ;
: , ( n -- ) ( 6.1.0150 )( 0xD3 ) HERE  [ D# 1 CELLS ] LITERAL ALLOT  ! ;

: COMPILE, ( xt -- ) ( 6.2.0945 )( 0xDD ) , ;
: LITERAL ( n -- ) ( 6.1.1780 ) ['] _LIT COMPILE, , ; IMMEDIATE

: CHAR ( "ccc" -- c ) ( 6.1.0895 ) PARSE-WORD DROP C@ ;
: [CHAR] ( "ccc" -- ) ( 6.1.2520 ) CHAR  [ ' LITERAL COMPILE, ] ; IMMEDIATE

: ' ( "name" -- xt ) ( 6.1.0070 ) PARSE-WORD SFIND IF DROP EXIT THEN D# -13 THROW ;
: ['] ( "name" -- ) ( 6.1.2510 ) '  [ ' LITERAL COMPILE, ] ; IMMEDIATE

: PARSE ( c "ccc" -- a u ) ( 6.2.2008 ) \ ???move
  >R SOURCE >IN @ /STRING R> _PARSE >IN +! ;

: .( ( "comment" -- ) ( 6.2.0200 ) [CHAR] ) PARSE TYPE ; IMMEDIATE
: ( ( "comment" -- ) ( 6.1.0080 ) [CHAR] ) PARSE 2DROP ; IMMEDIATE
: \ ( "comment" -- ) ( 6.2.2535 ) SOURCE >IN ! DROP ; IMMEDIATE

: SLITERAL ( a u -- ) ( -- a u ) ( 17.6.1.2212 )
  ['] _S" COMPILE, S, ALIGN ; IMMEDIATE COMPILE-ONLY

: ,C" ( "ccc" -- ) [CHAR] " PARSE S, ALIGN ;

: S" ( "ccc" -- ) ( 6.1.2165 ) ['] _S" COMPILE, ,C" ; IMMEDIATE COMPILE-ONLY
: ." ( "ccc" -- ) ( 6.1.0190 ) ['] _." COMPILE, ,C" ; IMMEDIATE COMPILE-ONLY

: ABORT" ( "ccc" -- ) ( 6.1.0680 )
  ['] _ABORT" COMPILE, ,C" ; IMMEDIATE COMPILE-ONLY

: _] ( a u -- ) ( the Forth compiler )
  SFIND ( search dictionary )
  IF [ =IMED ] LITERAL AND
    IF EXECUTE ?STACK EXIT ( immediate )
    THEN COMPILE, EXIT
  THEN
  NUMBER? ( unknown symbol, try to convert a number )
  IF DPL @ 0<
    IF DROP ( single )
    ELSE SWAP  [ ' LITERAL COMPILE, ] ( double )
    THEN  [ ' LITERAL COMPILE, ] EXIT
  THEN D# -13 THROW ; COMPILE-ONLY
: ] ( -- ) ( 6.1.2540 ) ALIGN ['] _] D# -1 STATE 2! ;

CREATE FORTH-WORDLIST ( -- wid ) ( 16.6.1.1595 )
  D# 0 , ( na, of last definition, linked )
  D# 0 , ( wid|0, next or last wordlist in chain )
  D# 0 , ( na, wordlist name pointer )

CREATE LAST ( -- a )
  D# 1 CELLS ALLOT ( na, of last definition, unlinked )
  D# 1 CELLS ALLOT ( wid, current wordlist for linking )
LABEL =TOKEN
  D# 1 CELLS ALLOT ( xt, of last definition )

CREATE CURRENT ( -- a )
  FORTH-WORDLIST , ( wid, new definitions )
  FORTH-WORDLIST , ( wid, head of chain )

: GET-CURRENT ( -- wid ) ( 16.6.1.1643 ) CURRENT @ ;
: SET-CURRENT ( wid -- ) ( 16.6.1.2195 ) CURRENT ! ;
: DEFINITIONS ( -- ) ( 16.6.1.1180 ) CONTEXT @ SET-CURRENT ;

: ?UNIQUE ( a u -- a u )
  2DUP  GET-CURRENT WID?
  IF 2DROP CR ." reDef " 2DUP TYPE EXIT THEN 2DROP ;

: HEAD, ( "name" -- ) \ ???fix ( xt "name" -- )
  PARSE-WORD  DUP
  IF ?UNIQUE ( warn if redefined )
    ALIGN
    GET-CURRENT  DUP @ ,  HERE LAST 2! ( link )
    DUP C, ( save count )
    HERE SWAP  DUP ALLOT  MOVE ( build name )
    D# 0 C, ( build attribute byte )
    EXIT
  THEN D# -16 THROW ; ( attempt to use zero-length string )

| : LEX! ( u -- ) LAST @ COUNT CHARS + DUP >R C@ OR R> C! ;
: IMMEDIATE ( -- ) ( 6.1.1710 ) [ =IMED ] LITERAL  LEX! ;
: COMPILE-ONLY ( -- ) [ =COMP ] LITERAL  LEX! ;

: REVEAL ( -- ) LAST 2@ SWAP ! [ ' [ COMPILE, ] ;
: RECURSE ( -- ) ( 6.1.2120 ) [ =TOKEN ] LITERAL @ COMPILE, ; IMMEDIATE

: POSTPONE ( "name" -- ) ( 6.1.2033 )
  PARSE-WORD SFIND
  IF [ =IMED ] LITERAL AND IF COMPILE, EXIT THEN
    [ ' LITERAL COMPILE, ]  ['] COMPILE, COMPILE,  EXIT
  THEN D# -13 THROW ; IMMEDIATE

.( Defining words )

: CODE ( "name" -- ) ( 15.6.2.0930 ) \ ITC
  HEAD, ALIGN HERE CELL+ , REVEAL ;

: next, ( -- ) \ ITC 80x86 only
  [ NEXT1 ] LITERAL  H# E9 C,  HERE D# 2 + - , ;

: :NONAME ( -- xt ) ( 6.2.0455 ) \ ITC
  ALIGN HERE  DUP [ =TOKEN ] LITERAL !  [ LIST1 ] LITERAL , ] ;

: : ( "name" -- ) ( 6.1.0450 ) HEAD, :NONAME DROP ;
: ; ( -- ) ( 6.1.0460 ) ['] EXIT COMPILE, REVEAL ; IMMEDIATE COMPILE-ONLY

: _DOES> ( -- ) ( link child )
\  ALIGN ( child ) \ ???why
  R>  [ =TOKEN ] LITERAL @  CELL+ ( ITC )  ! ; COMPILE-ONLY

: DOES> ( -- ) ( 6.1.1250 ) ( build parent )
  ['] _DOES> COMPILE, ( link child )
  :NONAME DROP  ['] R> COMPILE, ( begin child )
; IMMEDIATE COMPILE-ONLY

: CREATE ( "name" -- ) ( 6.1.1000 ) ['] _VAR  : REVEAL COMPILE, ;
: VARIABLE ( "name" -- ) ( 6.1.2410 ) CREATE D# 0 , ;
: CONSTANT ( n "name" -- ) ( 6.1.0950 ) ['] _CON  : REVEAL COMPILE,  , ;

: USER ( n "name" -- ) ['] _USR  : REVEAL COMPILE,  , ;

: HAT ( u s r "name" -- ) ( -- tid )
  CREATE + SWAP [ D# 7 CELLS ] LITERAL + ( TF\TID\TOS\STATUS\FOLLOWER\r>--<s )
  DUP HERE + ( rp0 ) , + DUP HERE + ( sp0 ) , ALLOT ;

: WORDLIST ( -- wid ) ( 16.6.1.2460 )
  ALIGN HERE D# 0 ,  DUP CURRENT CELL+  DUP @ ,  !  D# 0 , ;

: ORDER@ ( a -- u*wid u )
  DUP @ DUP IF >R CELL+  RECURSE  R> SWAP D# 1 + EXIT THEN NIP ;
: GET-ORDER ( -- u*wid u ) ( 16.6.1.1647 ) CONTEXT ORDER@ ;

: SET-ORDER ( u*wid n -- ) ( 16.6.1.2197 )
  DUP D# -1 = IF DROP FORTH-WORDLIST D# 1 THEN ( default ? )
  [ #VOCS ] LITERAL OVER U< IF D# -46 THROW THEN ( range ? )
  CONTEXT SWAP
  BEGIN DUP
  WHILE >R  SWAP OVER !  CELL+  R> D# 1 -
  REPEAT  ( 0 ) SWAP ! ;

\ ============================================================
: _MARKER ( -- ) ( R: dfa -- ) \ ???
  R> 2@ ( * ) DUP @ FOLLOWER !  DUP CONTEXT
  BEGIN >R CELL+ DUP @ DUP R@ ! WHILE R> CELL+ REPEAT ( search order )
  CELL+ DUP 2@ CURRENT 2!  CELL+ DUP @ ( cur wid & head )
  BEGIN >R  CELL+ DUP @ R@ !  R> CELL+ @ ?DUP 0= UNTIL ( wid last na's )
  R> 2DROP ( * ) DP 2! ; COMPILE-ONLY

: MARKER ( "name" -- ) \ ???
  ALIGN DP 2@ ( * ) FOLLOWER @ ,  CONTEXT
  BEGIN DUP @ DUP , WHILE CELL+ REPEAT  DROP ( search order )
  CURRENT 2@ , DUP , ( cur wid & head )
  BEGIN DUP @ , CELL+ @ ?DUP 0= UNTIL ( wid last na's )
  ['] _MARKER : REVEAL COMPILE, ( * ) , , ;
\ ============================================================

.( Control flow )

: BEGIN ( -- a ) ( 6.1.0760 ) HERE ; IMMEDIATE
: THEN ( a -- ) ( 6.1.2270 ) [ ' BEGIN COMPILE, ] ( OVER - ) SWAP ! ; IMMEDIATE

: RESOLVE ( a -- ) ( [ ' BEGIN COMPILE, ] - ) , ;
: MARK ( -- a ) HERE [ ' BEGIN COMPILE, ] RESOLVE ;

: IF ( -- a ) ( 6.1.1700 ) ['] _IF COMPILE, MARK ; IMMEDIATE
: AHEAD ( -- a ) ( 15.6.2.0702 ) ['] _ELSE COMPILE, MARK ; IMMEDIATE
: ELSE ( a -- a ) ( 6.1.1310 ) [ ' AHEAD COMPILE, ] SWAP [ ' THEN COMPILE, ] ; IMMEDIATE
: WHILE ( a -- a a ) ( 6.1.2430 ) [ ' IF COMPILE, ] SWAP ; IMMEDIATE

: UNTIL ( a -- ) ( 6.1.2390 ) ['] _IF COMPILE, RESOLVE ; IMMEDIATE
: AGAIN ( a -- ) ( 6.2.0700 ) ['] _ELSE COMPILE, RESOLVE ; IMMEDIATE
: REPEAT ( a a -- ) ( 6.1.2140 ) [ ' AGAIN COMPILE, ' THEN COMPILE, ] ; IMMEDIATE

.( Tools )

: .S ( -- ) ( 15.6.1.0220 )( 0x9F )
  ?STACK DEPTH BEGIN ?DUP WHILE DUP PICK . D# 1 - REPEAT ;

: !CSP ( -- ) SP@ CSP ! ;
: ?CSP ( -- ) SP@ CSP @ XOR ABORT" csp?" ;

: >CHAR ( c -- c )
  H# 7F AND DUP D# 127 BL WITHIN IF DROP [CHAR] _ THEN ;

: _TYPE ( a u -- ) ( alpha dump )
  CHARS BOUNDS BEGIN 2DUP XOR WHILE COUNT >CHAR EMIT REPEAT 2DROP ;

: _DUMP ( a u -- ) ( numeric dump )
  CHARS BOUNDS BEGIN 2DUP XOR WHILE COUNT D# 3 U.R REPEAT 2DROP ;

: DUMP ( a u -- ) ( 15.6.1.1280 )
  BASE @ >R HEX  CHARS BOUNDS
  BEGIN 2DUP SWAP U< WHILE ( range? )
    CR DUP D# 0 <#  # # # #  #> TYPE ( address )
    SPACE [ #DUMP ] LITERAL  2DUP _DUMP ( numeric )
    SPACE SPACE  2DUP _TYPE ( alpha )
    CHARS +  NUF? ( user? )
  UNTIL THEN 2DROP  R> BASE ! ;

: .ID ( a -- ) COUNT _TYPE ;

: WIDWORDS ( a u wid -- a u )
  SWAP >R  DUP
  IF CR DUP ." wid=" U. CR
    BEGIN @ DUP ( last name ? )
    WHILE 2DUP CHAR+ R@ SAME? ( match ? )
      IF DUP .ID SPACE THEN CELL-  NUF?
    UNTIL THEN
  THEN DROP R> ;
: WORDS ( "ccc" -- )
  BL PARSE  DUP
  IF CURRENT BEGIN CELL+ @ ?DUP WHILE DUP >R WIDWORDS R> REPEAT ( all wid )
  ELSE CONTEXT @ WIDWORDS
  THEN 2DROP ;

: NAMED? ( aa -- na | 0 )
  CURRENT ( all wid )
  BEGIN CELL+ @ DUP ( last link ? )
  WHILE DUP >R
    BEGIN @ ?DUP ( zero link ? )
    WHILE 2DUP NAME> >ADR = ( match ? )
       IF SWAP R> 2DROP EXIT ( found )
       THEN CELL-
    REPEAT R>
  REPEAT NIP ( not found ) ;

: SSEE ( a u -- ) ( simple decompiler )
  CELLS BOUNDS
  BEGIN 2DUP XOR ( done? )
  WHILE DUP NAMED? ?DUP IF CR .ID CR THEN
    SPACE DUP @ >ADR NAMED? ?DUP
    IF .ID ( display named token )
    ELSE DUP @ D# 0 U.R ( unnamed token )
    THEN CELL+  NUF?
  UNTIL THEN 2DROP ;
: SEE ( "name" -- ) ( 15.6.1.2194 ) ' >ADR D# -1 SSEE ;

.( Software reset )

: COLD ( -- )
  SUP 2@ RP! SP! ( init stacks )
  SUP @ CELL- ( FOLLOWER ) UP ! ( init user pointer )
  STATUS FOLLOWER !  SUP TID !  SUP AWAKE ( init tasks )
  D# 0 !IO ( init i/o device )
  HEX  D# -1 SET-ORDER DEFINITIONS
  CR [ =VERSION ] LITERAL COUNT TYPE
  CR [ =(C) ] LITERAL COUNT TYPE
  CR QUIT ;

CODE BYE ( -- ) ( 15.6.2.0830 )
  H# 20 int ( terminate process )
END-CODE

PROC VCOLD             ( cold start entry )
  cli                  ( disable interrupt for old 808x CPU bug )
  cs ax mov  ax ds mov ( DS=CS )
  ax ss mov            ( SS=CS )
  SUP ## bp mov        ( system user pointer )
  D# 1 CELLS bp [] sp mov ( init SP )
  D# 0 CELLS bp [] bp mov ( init RP )
  sti                  ( enable interrrupts )
\ =====================
  RESET ## dx mov      ( ^C on output MS-DOS only )
  H# 2523 ## ax mov    ( set ^C interrupt Int23 )
  H# 21 int
\ =====================
  cld                  ( direction flag, increment )
  ' COLD ## di mov     ( first word to execute ) \ ITC
  D# 0 di [] jmp          ( start eForth )
END-CODE

CR .( Metacompile End ) ]META