( FORTHkit  1986 February)
( Optimizing compiler)  4 LOAD  5 LOAD  6 LOAD
: 0<   [COMPILE] 0<  [COMPILE] NOP ;

FORTH : REMEMBER   CREATE  CONTEXT 2 - 2@ , ,
   DOES  R> 32767 AND  DUP 2 + H !  2@ CONTEXT 2 - 2!  FORTH ;
: THRU ( n n)   OVER - FOR  DUP LOAD  1 + NEXT DROP ;
REMEMBER EMPTY








   ( Separated heads)
VARIABLE H'  HEX 1000 , ( relocation)
: {   dA @  HERE  H' 2@ H !  dA !  H' 2! ;      : }   { ;
COMPILER : }   H' @ ,A  PREVIOUS  8000 XOR  SWAP !  { ;
FORTH : FORGET   SMUDGE ;
: RECOVER   -1 ALLOT ;
VARIABLE RAM            : VARIABLE   RAM @ CONSTANT  1 RAM +! ;

: SCAN ( a - a)   @ BEGIN  DUP 1 2000 WITHIN WHILE  @ REPEAT ;
: TRIM ( a a - a)   DUP >R  dA @ -  SWAP !  R>
   DUP 1 +  DUP @  DFFF AND  SWAP ! ;
: CLIP ( a)   DUP BEGIN  DUP SCAN  DUP WHILE  TRIM  REPEAT
   2001 XOR  dA @ -  SWAP !  @ , ;
: PRUNE   { CONTEXT 2 -  DUP CLIP  1 + CLIP {
   A0 0 2001 2!  EMPTY ;

( cmFORTH)   EMPTY
( Target compile)   2 LOAD
HEX 2000 800 FFFF FILL   2001 H' !  10 RAM !  DECIMAL

{ : #   R>DROP ;
( Nucleus)  7 11 THRU
( Variables)  12 LOAD
( Terminal)  13 16 THRU
( Disk)  17 18 THRU
( Interpreter)  19 22 THRU
( Initialize)  23 24 THRU
   ' RESET  dA @ -  HEX 2000 !  DECIMAL
( Compiler)  25 30 THRU
FORTH  }  ROM dA @ + 9 +  H' !
PRUNE

( Optimizing compiler)   OCTAL
: FORTH   1 CONTEXT ! ;
: COMPILER   2 CONTEXT ! ;
: uCODE ( n)   CREATE ,  DOES   R> 77777 AND  @ ,C ;

COMPILER : [COMPILE]   2 -' IF  DROP ABORT" ?"  THEN ,A ;
: !-   172700 SHORT ;
100000 uCODE NOP         140000 uCODE TWO
100020 uCODE SWAP-DROP   140721 uCODE R>DROP
160000 uCODE @DROP       154600 uCODE 0+c
177300 uCODE N!          147303 uCODE -1

FORTH : DUP?   HERE 2 - @  100120 = IF
      HERE 1 - @  7100 XOR  -2 ALLOT  ,C  THEN ;
COMPILER : I!   157200 SHORT  DUP? ;
         : >R   157201 ,C  DUP? ;
   ( Defining words)   OCTAL
FORTH : PACK ( a n - a)   160257 AND  140201 XOR IF
      40 SWAP +!  ELSE DROP  100040 ,  THEN  R>DROP ;
COMPILER : EXIT   ?CODE @  DUP IF  0 ?CODE !  DUP @  DUP 0< IF
         DUP 170000 AND  100000 = IF  PACK THEN
         DUP 170300 AND  140300 = IF  PACK THEN
         DUP 170000 AND  150000 = IF
            DUP 170600 AND  150000 XOR IF  PACK THEN  THEN DROP
      ELSE  DUP HERE dA @ - XOR  170000 AND 0= IF
         7777 AND  130000 XOR  SWAP !  EXIT THEN DROP  THEN
   THEN DROP  100040 , ;
: ;   [COMPILE] RECURSIVE  R>DROP  [COMPILE] EXIT ;

FORTH : CONSTANT ( n)   CREATE  -1 ALLOT
   [COMPILE] LITERAL  [COMPILE] EXIT ;

   ( Binary operators)   OCTAL
: BINARY ( n n)   CREATE , ,  DOES   R> 77777 AND  2@
   ?CODE @ DUP IF  @  DUP 117100 AND  107100 =
      OVER 177700 AND  157500 = OR IF ( y -!)
         DUP 107020 - IF  SWAP-DROP XOR  DUP 700 AND  200 = IF
            500 XOR  ELSE DUP 70000 AND 0= IF  20 XOR  THEN THEN
            ?CODE @ !  EXIT THEN
   THEN THEN DROP  ,C  DROP ;
: SHIFT ( n)   CREATE ,  DOES   R> 77777 AND  @
   ?CODE @ DUP IF  @  DUP 171003 AND  100000 = IF
      XOR  ?CODE @ !  EXIT THEN  THEN DROP  100000 XOR ,C ;
COMPILER
4100 103020 BINARY OR      2100 105020 BINARY XOR
6100 101020 BINARY AND     3100 104020 BINARY +
5100 106020 BINARY -       1100 102020 BINARY SWAP-
2 SHIFT 2*            1 SHIFT 2/           3 SHIFT 0<
( Nucleus)   OCTAL
: ROT ( n n n - n n n)   >R SWAP  R> SWAP ; ( 5)

: 0= ( n - t)   IF  0 EXIT  THEN -1 ; ( 3)
: NOT ( n - t)   0= ; ( 4)
: < ( n n - t)   - 0< ; ( 1)
: > ( n n - t)   SWAP- 0< ; ( 1)
: = ( n n - t)   XOR 0= ; ( 5)
: U< ( u u - t)   - 2/  0< ;  ( 3)

{ COMPILER
104411 uCODE *'      102411 uCODE *-
100012 uCODE D2*     100011 uCODE D2/
102416 uCODE /'      102414 uCODE /''
( 102412 uCODE *F      102616 uCODE S')  FORTH }

   ( Unsigned multiply, divide)   OCTAL
{ COMPILER
: I@!   157700 SHORT ;

157504 uCODE MD   ( Multiplier/divisor register)
157506 uCODE SR   ( Square-root register)
FORTH }

: 2/MOD ( n - r q)   DUP 1 AND  SWAP 2/ ; ( 5)
: U*+ ( u r u - l h)   MD I!  16 TIMES  *' ; ( 19)
: M/MOD ( l h u - q r)   MD I!  D2*  15 TIMES  /'  /'' ; ( 20)





   ( Multiply, divide)
: -M/MOD ( l h u - q r)   OVER 0< IF  DUP >R +  R> THEN
   M/MOD ; ( 23-25)
: M/ ( l h u - q)   -M/MOD DROP ; ( 27)

: M*+ ( n 0 u - h l)   MD I!  13 TIMES  *'  *- ; ( 19)
: VNEGATE ( v - v)   NEGATE SWAP  NEGATE SWAP ; ( 5)
: M* ( n n - d)   DUP 0< IF  VNEGATE  THEN 0 SWAP M*+ ;
   ( 24-29)
: /MOD ( u u r q)   0 SWAP  M/MOD SWAP ; ( 24)
: MOD ( u u - r)   /MOD DROP ; ( 26)
: */MOD ( u u u - r q)   >R  0 SWAP U*+  R> M/MOD SWAP ; ( 45)

: */ ( n n u - n)   >R M*  R> M/ ; ( 59)
: * ( n n - n)   0 SWAP U*+ DROP ; ( 23)
: / ( n u - q)   >R  DUP 0<  R> M/ ; ( 31)
   ( Memory reference operators)
: +! ( n a)   0 @+ >R  +  R> ! ; ( 8)
: C! ( n b)   2/MOD   DUP >R @  SWAP IF  -256 AND
   ELSE  255 AND  SWAP 6 TIMES 2*  THEN XOR R> ! ; ( 20-29)
: C@ ( b - n)   2/MOD @  SWAP 1 - IF  6 TIMES 2/  THEN 255 AND ;
   ( 10-20)
: 2C@+ ( a - a l h)   1 @+ SWAP  DUP 127 AND  SWAP 6 TIMES 2/ ;
: 2@ ( a - d)   1 @+  @ SWAP ; ( 6)
: 2! ( d a)   1 !+  ! ; ( 6)

: 2DROP ( d)   DROP DROP ; ( 3)
: MOVE ( s d' #)   >R  MD I!  I TIMES 1 @+
   MD I@!  R> TIMES  1 !-  DROP ; ( 2* 11+)
: FILL ( a # n)   SWAP 1 - >R  SWAP BEGIN  OVER SWAP 1 !+  NEXT
   2DROP ; ( 5* 8+)
: ERASE ( a #)   0 FILL ;
   ( Words)
: EXECUTE ( a)   >R ; ( 3)
: CYCLES ( n)   FOR  NEXT ; ( 4 n+)

: 2DUP ( d - d d)   OVER OVER ; ( 3)
: ?DUP ( n - n n, 0)   DUP IF  DUP EXIT  THEN ; ( 4)

: WITHIN ( n l h - t)   OVER - >R  - R> U< ;
: ABS ( n - u)   DUP 0< IF  NEGATE EXIT  THEN ; ( 4)
: MAX ( n n - n)   OVER OVER - 0< IF BEGIN  SWAP-DROP ;
: MIN ( n n - n)   OVER OVER - 0< UNTIL  THEN DROP ; ( 5)





   ( RAM allocation)   OCTAL
{ : ARRAY ( n)   RAM @ CONSTANT  RAM +!  154462 USE ;
   VARIABLE PREV        ( Last referenced buffer)
   VARIABLE OLDEST      ( Oldest loaded buffer)
   2 ARRAY BUFFERS      ( Block in each buffer) }
2 1 - CONSTANT NB    ( Number of buffers)
VARIABLE BASE    VARIABLE CNT
VARIABLE >IN     VARIABLE BLK    VARIABLE ?CODE

( Initialized)
VARIABLE dA
VARIABLE MSG     VARIABLE CURSOR
VARIABLE WIDTH   VARIABLE OFFSET   VARIABLE H
VARIABLE C/B     2 RAM +! ( interrupt)
2 RAM +!         VARIABLE CONTEXT

( ASCII terminal: 4X in, 0X out)
: EMIT ( n)   30 13 I!  2* 511 XOR
   9 FOR  DUP 12 I!  2/  C/B @ 11 - CYCLES  NEXT DROP ;
: CR   13 EMIT  10 EMIT ;
: TYPE ( a - a)   2*  DUP C@ 1 - FOR  1 +  DUP C@ EMIT  NEXT
   2 + 2/ ;

: RX ( - n)   12 I@  16 AND ; ( 3)
: KEY ( - n)   0 BEGIN RX  16 XOR UNTIL  C/B @  DUP 2/ +
   7 FOR  14 - CYCLES  2/  RX  2* 2* 2* OR  C/B @  NEXT
   BEGIN RX UNTIL  DROP ;





   ( Serial EXPECT)   HEX
: SPACE   20 EMIT ;
: SPACES ( n)   0 MAX  ?DUP IF  1 - FOR  SPACE NEXT THEN ;
: HOLD ( ..# x n - ..# x)   SWAP >R  SWAP 1 +  R> ;

: EXPECT ( a #)   SWAP CURSOR !
   1 - DUP FOR  KEY  DUP 8 XOR IF
         DUP D XOR IF  DUP 4000 +  CURSOR @ 1 !+  CURSOR !  EMIT
         ELSE  SPACE  DROP  R> - CNT !  EXIT THEN
      ELSE ( 8)  DROP  DUP I XOR [ OVER ] UNTIL
         CURSOR @ 1 - CURSOR !  R> 2 + >R  8 EMIT
      THEN NEXT 1 + CNT ! ;

: HERE ( - a)   H @ ;


   ( Numbers)
: DIGIT ( n - n)   DUP 9 >  7 AND +  48 + ;
: <# ( n - ..# n)   -1 SWAP ;
: #> ( ..# n)   DROP FOR  EMIT NEXT ;
: SIGN ( ..# n n - ..# n)   0< IF  45 HOLD  THEN ;
: # ( ..# n - ..# n)   BASE @ /MOD  SWAP DIGIT HOLD ;
: #S ( ..# n - ..# 0)   BEGIN  #  DUP 0= UNTIL ;
: (.) ( n - ..# n)   DUP >R ABS  <# #S  R> SIGN ;
: . ( n)   (.) #> SPACE ;
: ? ( a)   @ . ;

: U.R ( u n)   >R  <# #S  OVER R> SWAP-  1 - SPACES  #> ;
: U. ( u)   0 U.R  SPACE ;
: DUMP ( a - a )   CR DUP 5 U.R SPACE  7 FOR
      1 @+ SWAP  7 U.R  NEXT SPACE ;

   ( Strings)   HEX
{ : abort" }   H @ TYPE  SPACE  R> 7FFF AND TYPE  2DROP
   BLK @  0 ( QUIT) ;
{ : dot" }   R> 7FFF AND  TYPE  >R ;

{ COMPILER
   : ABORT"   COMPILE abort"  4022 STRING ;
   : ."   COMPILE dot"  4022 STRING ;
   FORTH }







   ( 15-bit buffer manager)
{ : ADDRESS ( n - a) }   2 +  8 TIMES 2* ;
{ : ABSENT ( n - n) }   NB FOR  DUP  I BUFFERS @ XOR  2* WHILE
      NEXT  EXIT THEN  R>  PREV N!  R>DROP SWAP-DROP  ADDRESS ;

{ : UPDATED ( - a n) }   OLDEST @  BEGIN  1 +  NB AND
      DUP PREV @ XOR UNTIL  OLDEST N!  PREV N!
   DUP ADDRESS  SWAP BUFFERS  DUP @
   8192 ROT !  DUP 0< NOT IF  R>DORP DROP THEN ;

: UPDATE  PREV @ BUFFERS  0 @+ SWAP  32768 OR  SWAP ! ;
{ : ESTABLISH ( n a - a) }   SWAP  OLDEST @  PREV N!
   BUFFERS ! ;
: IDENTIFY ( n a - a)   SWAP  PREV @ BUFFERS ! ;


   ( Disk read/write)
{ : ## ( a n - a a #) }   0 EMIT  256 /MOD EMIT EMIT  DUP 1023 ;

{ : buffer ( n - a) }  UPDATED
   ## FOR  1 @+ SWAP  EMIT  NEXT  KEY 2DROP ;
: BUFFER ( n - a)   buffer ESTABLISH ;

{ : block ( n a - n a) }  OVER  ## FOR  KEY 16384 XOR  SWAP 1 !+
      NEXT DROP ;
: BLOCK ( n - a)   ABSENT buffer  block ESTABLISH ;

: FLUSH   NB FOR  8192 BUFFER DROP  NEXT ;
: EMPTY-BUFFERS   PREV [ NB 3 + ] LITERAL ERASE  FLUSH ;



( Interpreter)
{ : LETTER ( b a # - b a) } FOR DUP @  SR I@ XOR  WHILE  SWAP >R
      1 @+ SWAP  127 AND  I C!  R> 1 + SWAP NEXT  EXIT THEN
      R> NEGATE  >IN +! ;
{ : -LETTER ( b a # - b a) }   ?DUP IF
      1 - FOR  1 @+ SWAP  SR I@ XOR  0= WHILE NEXT  EXIT THEN
      1 - R> LETTER  THEN ;
: WORD ( n - a)   >R  H @ 2* 1 +  DUP  >IN @  BLK @ IF
      BLK @ BLOCK +  1024
   ELSE  MSG @ +  CNT @  THEN  >IN @  OVER >IN !  -  R> SR I!
   -LETTER  DROP 32 OVER C!  SWAP- H @ 2* C!  H @ ;





   ( Dictionary search)   HEX
{ : SAME ( h a - h a f, a t) }   OVER >R  DUP 1
   BEGIN +  1 @+ SWAP  R> 1 @+ >R  - 2* DUP UNTIL  R>DROP
   FEFF AND IF  0 AND  EXIT THEN
   SWAP 1 + @  0< IF  @  THEN SWAP ;

{ : HASH ( n - a) }   CONTEXT SWAP- ;
{ : -FIND ( h n - h t, a f) }   HASH BEGIN  @ DUP WHILE
      SAME UNTIL  0 EXIT THEN  -1 XOR ;







   ( Number input)   HEX
: -DIGIT ( n - n)   DUP 39 > IF  DUP 40 >  7 AND -  THEN
   30 -  DUP BASE @ U< IF  EXIT THEN
   2DROP DROP  ABORT" ?"  DROP ;  RECOVER

{ : 10*+ ( u n - u) }   -DIGIT  0E TIMES *'  DROP ;
: NUMBER ( a - n)   BASE @ MD I!  2C@+ OVER 2D =  DUP >R IF
      SWAP-DROP 0  ELSE  SWAP -DIGIT  THEN SWAP
   1 - ?DUP IF  1 - 2/ FOR  SWAP 2C@+  SWAP >R >R  SWAP
      R> 10*+  R>  DUP 20 XOR IF  10*+  ELSE  DROP  THEN
      NEXT THEN SWAP-DROP  R> IF NEGATE  THEN ;





   ( Control)
: -' ( n - h t, a f)   [ HEX ] 4020 WORD  SWAP -FIND ;
: ' ( - a)   CONTEXT @ -' IF  DROP ABORT" ?"  THEN ;  FORGET

: INTERPRET ( n n)   >IN 2!  BEGIN  1 -' IF  NUMBER
      ELSE  EXECUTE  THEN AGAIN ;  RECOVER

: QUIT   BEGIN CR  MSG @ 40 EXPECT
      0 0 INTERPRET ." ok"  AGAIN ;  RECOVER

' QUIT  dA @ -  ' abort" 9 + !





   ( Initialize)
HERE { CONSTANT ROM }
   0 ( dA) ,  RAM @ ( MSG) ,  0 ( CURSOR) ,
   2 ( WIDTH - cells) ,  0 ( OFFSET) ,  RAM @ 64 + ( H) ,
   417 ( 4MHz 9600b/s) ,  { : interrupt }   R>DROP ;
   0 , 0 , 1 ( CONTEXT) ,

: DECIMAL   10 BASE ! ;
{ : BAUD }   2 BEGIN RX  16 XOR UNTIL  BEGIN 5 +  RX UNTIL
   2/ C/B ! ;   HEX
: RESET   0 DUP D I!  F E I!  DUP F I!  1A C I!
   DUP 9 I!  FFFF A I!  0B I!  0 8 I!
   CONTEXT @  [ ROM dA @ - ] LITERAL CONTEXT 0B MOVE
   1 - IF  EMPTY-BUFFERS  THEN  DECIMAL
   BAUD  ." hi"  QUIT ;

   ( Words)
: SWAP   SWAP ;         : OVER   OVER ;
: DUP   DUP ;           : DROP   DROP ;

: XOR   XOR ;           : AND   AND ;
: OR   OR ;
: +   + ;               : -   - ;
: 0<   0< ;             : NEGATE   NEGATE ;

: @   @ ;               : !   ! ;

: OCTAL   8 BASE ! ;
: HEX   16 BASE ! ;
: LOAD ( n)   >IN 2@ >R >R  0 INTERPRET  R> R> >IN 2!  DECIMAL ;
   FORGET

( Compiler)   OCTAL
: ALLOT ( n)   H +! ;
: , ( n)   H @ !  1 ALLOT ;
: ,C ( n)   H @ ?CODE !  , ;
: ,A ( a)   dA @ -  ,C ;

COMPILER : LITERAL ( n)   DUP -40 AND IF  147500 ,C  ,  EXIT
   THEN  157500 XOR ,C ;
: [   R>DROP ;

FORTH : ]   BEGIN 2 -' IF  1 -FIND IF  NUMBER  [COMPILE] LITERAL
   ELSE DUP @
      DUP 140040 AND  140040 =  OVER 170377 AND  140342 XOR AND
      SWAP 170040 AND  100040 = OR IF  @ 40 XOR  ,C
      ELSE  ,A  THEN THEN
   ELSE  EXECUTE  THEN AGAIN ;  RECOVER
   ( Compiler)   HEX
: PREVIOUS ( - a n)   CONTEXT @ HASH  @ 1 +  0 @+ SWAP ;
{ : COUNT ( n - n) }   7 TIMES 2/  0F AND  1 +  WIDTH @ MIN ;
: USE ( a)   PREVIOUS  COUNT + ! ;
: DOES   R> 7FFF AND  USE ;
: SMUDGE   PREVIOUS 2000 XOR  SWAP ! ;
: EXIT   R>DROP ;

: COMPILE   R>  7FFF AND  1 @+ >R  ,A ;
OCTAL
COMPILER : EXIT    100040 ,C ;   HEX
: RECURSIVE   PREVIOUS DFFF AND  SWAP ! ;
: ;   [COMPILE] RECURSIVE  R>DROP  [COMPILE] EXIT ;  FORGET



   ( Defining words)   OCTAL
FORTH : CREATE   H @ 0 ,  40040 WORD  CONTEXT @ HASH
   2DUP @  SWAP 1 - !  SWAP @  COUNT ALLOT
   200 H @ 1 - +!  !  147342 , ;

: :   CREATE  -1 ALLOT  SMUDGE  0 ?CODE !  ] ;  FORGET

: CONSTANT ( n)   CREATE  -1 ALLOT  [COMPILE] LITERAL
   [COMPILE] EXIT ;
: VARIABLE   CREATE  0 , ;






   ( uCODE)   OCTAL
: -SHORT ( - t)   ?CODE @ @  177700 AND  157500 XOR ;
: FIX ( n)   ?CODE @ @  77 AND OR  ?CODE @ ! ;
: SHORT ( n)   -SHORT IF  DROP ABORT" n?"  THEN FIX ;

COMPILER
: @   -SHORT IF  167100 ,C  ELSE  147100 FIX  THEN ;  FORGET
: !   -SHORT IF  177000 ,C  ELSE  157000 FIX  THEN ;  FORGET
: I@   147300 SHORT ;
: I!   157200 SHORT ;
: @+   164700 SHORT ;
: !+   174700 SHORT ;

: R>   147321 ,C ;      : >R   157201 ,C ;
: I   147301 ,C ;       : TIMES   157221 ,C ;  FORGET

   ( Structures)   OCTAL
FORTH { : OR, ( n n) }   0 ?CODE !  SWAP 7777 AND  OR , ;
{ : begin ( - a) }   H @  0 ?CODE ! ;
COMPILER : BEGIN ( - a)   begin ;

: UNTIL ( a)   110000 OR, ;
: AGAIN ( a)   130000 OR, ;
: THEN ( a)   begin  7777 AND  SWAP +! ;
: IF ( - a)   begin  110000 , ;
: WHILE ( a - a a)   [COMPILE] IF  SWAP ;
: REPEAT ( a a)   [COMPILE] AGAIN  [COMPILE] THEN ;
: ELSE ( a - a)   begin  130000 ,  SWAP [COMPILE] THEN ;

: FOR ( - a)   [COMPILE] >R  begin ;
: NEXT ( a)   120000 OR, ;

   ( Strings)   HEX
FORTH : STRING ( n)   WORD @  7 TIMES 2/  1 + ALLOT ;

COMPILER : ABORT"   COMPILE abort"  4022 STRING ;
: ."   COMPILE dot"  4022 STRING ;
: (   4029 WORD DROP ;

FORTH : (   [COMPILE] ( ;

