\ Thread safe
\        
\  

WINAPI: TlsAlloc                    KERNEL32.DLL
WINAPI: TlsFree                     KERNEL32.DLL
WINAPI: TlsSetValue                 KERNEL32.DLL
WINAPI: TlsGetValue                 KERNEL32.DLL

(      )

50000 VALUE T-SIZE \      
VARIABLE    T-DP   \      

: InitThread
  T-SIZE ALLOCATE IF ExitThread THEN
  BEGIN
    TlsAlloc DUP -1 = IF DROP FALSE ELSE TRUE THEN
  UNTIL
  DUP TlsIndex! TlsSetValue 0= IF BYE THEN
;
: T-BEGIN
  TlsIndex@ TlsGetValue
;
: ExitThread
  T-BEGIN FREE DROP
  TlsIndex@ TlsFree DROP ExitThread
;
: T-HERE ( -- t-here ) \     
  T-DP @
;
: T-ALLOCATE ( n -- addr )
  T-HERE 2DUP + T-SIZE > IF 450 THROW THEN
  SWAP T-DP +! \     ,
               \    
;
: T-CREATE
  CREATE T-HERE ,
  DOES> @ T-BEGIN +
;
: T-VARIABLE
  CREATE 1 CELLS T-ALLOCATE DUP , T-BEGIN + 0!
  DOES> @ T-BEGIN +
;
: T-VAR ( n -- )
  CREATE , DOES> @ T-BEGIN +
;

InitThread

(       )

600 T-ALLOCATE 500 + T-VAR PAD
2  T-ALLOCATE T-VAR EM_BUF
T-VARIABLE HLD
T-VARIABLE BASE 10 BASE !

: <# ( -- )
  PAD HLD !
;
: HOLD ( char -- )
  HLD @ 1- DUP HLD !
  C!
;
: HOLDS ( addr u -- )
  SWAP OVER + SWAP 0 ?DO DUP I - 1- C@ HOLD LOOP DROP
;
: # ( ud1 -- ud2 )
  BASE @ /MOD >R BASE @ UM/MOD R>
  ROT DUP 10 < IF 48 + ELSE 55 + THEN HOLD
;
: #S ( ud1 -- ud2 )
  BEGIN
    # 2DUP D0=
  UNTIL
;
: #> ( xd -- c-addr u )
  2DROP HLD @ PAD OVER -
;
: SIGN ( n -- )
  0< IF [CHAR] - HOLD THEN
;
(     )

T-VARIABLE HANDLER

: OLD-CATCH CATCH ;

: THROW ( k*x n -- k*x | i*x n )
  ?DUP
  IF HANDLER @ RP!
     R> HANDLER !
     R> SWAP >R
     SP! DROP R>
  THEN
;
: CATCH ( i*x xt -- j*x 0 | i*x n )
  SP@ >R  HANDLER @ >R
  RP@ HANDLER !
  EXECUTE
  R> HANDLER !
  RDROP
  0
;

(       
    
)
T-VARIABLE ASOURCE-ID
: SOURCE-ID ASOURCE-ID @ ;

: FORM-PRE
  BEGIN
    >IN @ #TIB @ <
  WHILE
    [CHAR] { PARSE SOURCE-ID WriteSocket DROP \   
    [CHAR] } PARSE SP@ CELL+ CELL+ S0 !
    EVALUATE
  REPEAT SOURCE-ID WriteSocketCRLF DROP
;
: INCL-TYPE ( S" " -- )
  ['] <PRE> >BODY @ >R
  ['] FORM-PRE TO <PRE> 
  ['] INCLUDED OLD-CATCH DROP
  R> TO <PRE>
;
T-VARIABLE AC/L
T-VARIABLE ATIB
T-VARIABLE #TIB
T-VARIABLE >IN
T-VARIABLE STATE

: TIB ATIB @ ;
: C/L AC/L @ ;

512 AC/L !
C/L T-ALLOCATE T-VAR TIB0
TIB0 ATIB !

: REFILL ( -- flag ) \ 94 FILE EXT
  #TIB 0!
  BEGIN
    TIB #TIB @ + DUP 1 SOURCE-ID ReadSocket THROW 1 =
    SWAP C@ 13 <> AND
  WHILE
    #TIB 1+!
  REPEAT
  TIB #TIB @ + 1 SOURCE-ID ReadSocket THROW DROP
  >IN 0! TRUE
;
: ?STACK ;

: PARSE ( char "ccc<char>" -- c-addr u )
  TIB #TIB @ + TIB >IN @ + ?DO
    I C@ OVER = IF DROP TIB >IN @ + I OVER - DUP 1+ >IN +! UNLOOP EXIT THEN
  LOOP DROP TIB >IN @ + #TIB @ >IN @ -  #TIB @ >IN !
;
: SKIP ( char "<chars>ccc" -- )
  BEGIN
    >IN @ #TIB @ <
    IF TIB >IN @ + C@ OVER =
       IF >IN 1+! FALSE
       ELSE TRUE THEN
    ELSE TRUE THEN
  UNTIL DROP
;
: WORD ( char "<chars>ccc<char>" -- c-addr )
  DUP SKIP PARSE
  DUP T-HERE T-BEGIN + C! T-HERE T-BEGIN + 1+ SWAP CMOVE
  BL T-HERE T-BEGIN + COUNT + !
  T-HERE T-BEGIN +
;
: ?LITERAL
  COUNT C" NOTFOUND" FIND IF EXECUTE THEN
;
\ ------
: CONT CONTEXT ;
T-VARIABLE CURRENT
16 CELLS T-ALLOCATE T-VAR S-O
T-VARIABLE ACONTEXT
: CONTEXT ACONTEXT @ ;

: VOCAB VOCABULARY ;
: ALS ALSO ;
: PREV PREVIOUS ;
: DEF DEFINITIONS ;

: VOCABULARY ( "<spaces>name" -- ) \    CONTEXT
  WORDLIST DUP CREATE ,
  LATEST OVER CELL+ !
  GET-CURRENT SWAP PAR!
  VOC
  DOES> @ CONTEXT !
;

: SET-CURRENT ( wid -- ) \ 94 SEARCH
  CURRENT !
;
: GET-CURRENT ( -- wid ) \ 94 SEARCH
  CURRENT @
;
: DEFINITIONS ( -- ) \ 94 SEARCH
  CONTEXT @ CURRENT !
;
: GET-ORDER ( -- widn ... wid1 n ) \ 94 SEARCH
  CONTEXT 1+ S-O DO I @ 1 CELLS +LOOP
  CONTEXT S-O - 1 CELLS / 1+
;

: FORTH ( -- ) \ 94 SEARCH EXT
  FORTH-WORDLIST CONTEXT !
;
: ONLY ( -- ) \ 94 SEARCH EXT
  S-O ACONTEXT !
  FORTH
;
: SET-ORDER ( widn ... wid1 n -- )
  ?DUP IF DUP -1 = IF DROP ONLY EXIT THEN
          DUP 1- CELLS S-O + ACONTEXT !
          0 DO CONTEXT I CELLS - ! LOOP
       ELSE S-O ACONTEXT !  CONTEXT 0! THEN
;
: FIND ( c-addr -- c-addr 0 | xt 1 | xt -1 )
  0
  S-O 1- CONTEXT
  DO
   OVER COUNT I @ SEARCH-WORDLIST
   ?DUP IF 2SWAP 2DROP LEAVE THEN
   I S-O = IF LEAVE THEN
   1 CELLS NEGATE
  +LOOP
;
: ALSO ( -- )
  GET-ORDER 1+ OVER SWAP SET-ORDER
;
: PREVIOUS ( -- )
  CONTEXT 1 CELLS - S-O MAX ACONTEXT !
;

\ ------
: INTERPRET ( -> ) \   
  BEGIN
    BL WORD DUP C@
  WHILE
    FIND ?DUP
    IF
         STATE @ =
         IF COMPILE, ELSE EXECUTE THEN
    ELSE
         ?LITERAL
    THEN
    ?STACK
  REPEAT DROP
;
: SOURCE
  TIB #TIB @
;
: HEX 16 BASE ! ;
: DECIMAL 10 BASE ! ;

: InitThread
  R>
  RP@ 100 - RP!
  >R >R
  SP@ 100 - SP!
  R>
  InitThread TIB0 ATIB ! 512 AC/L !
  ONLY FORTH DEFINITIONS
  DECIMAL
;
(   )

: OLD-TYPE TYPE ;
: OLD-CR CR ;

: TYPE
  SOURCE-ID WriteSocket THROW
;
: CR
  SOURCE-ID WriteSocketCRLF THROW
;
: EMIT ( x -- )
  EM_BUF ! EM_BUF 1 SOURCE-ID WriteSocket THROW
;
: SPACE ( -- )
  BL EMIT
;
: SPACES ( n -- )
  BEGIN
    DUP
  WHILE
    BL EMIT 1-
  REPEAT DROP
;
: D. ( d -- )
  DUP >R DABS <# #S R> SIGN #>
  TYPE SPACE
;
: . ( n -- )
  S>D D.
;
: U. ( u -- )
  U>D D.
;
: ID. COUNT TYPE ;

: NLIST ( A -> )
  @
  >OUT 0! CR W-CNT 0!
  BEGIN
    DUP 0<> \ KEY? 0= AND
  WHILE
    W-CNT 1+!
    DUP C@ >OUT @ + 71 >
    IF CR >OUT 0! THEN
    DUP ID.
    DUP C@ >OUT +!
    8 >OUT @ 8 MOD - DUP >OUT +! SPACES
    CDR
  REPEAT DROP \ KEY? IF KEY DROP THEN
  CR CR S" Words: " TYPE W-CNT @ U. CR
;
: WORDS ( -- )
  CONTEXT @ NLIST
;
: MAIN-S ( -- )
  BEGIN
    REFILL
  WHILE
    INTERPRET
  REPEAT
;
