( Copyrighted by eMAST Technology Corp, 2000 )
( All rights reserved )

comment:
\ eForth.seq, adapted from Bill Muench's aFIG.b, 27feb96cht
\ V2.06, slow down I/O for stability of RS232, 11/nov95cht
\ V2.07, merge rectangle routine in hline27, 24nov95cht
\ V20.8, add RECTANGLE to ok28c.seq, add space to 'redef ',
\        use 82C51 for serial communication. 18mar96cht
\ ef24.f 07nov00cht, convert to P24
\        02dec00cht, says ok, check DUMP, .S, WORDS and SEE

This implementation follows closely the eForth model.  The
following set of words are removed because they are not absolutely
necessary for embedded applications.  In this implementation,
the size constrain is severe, and the existence of every word
must be justified rigorously.

Words removed from the eForth model:
        CATCH, THROW, PRESET, XIO, FILE, HAND, I/O
        CONSOLE, RECURSE, USER, VER, HI, 'BOOT

Most of the user variables are eliminated:
        SP0, RP0, '?KEY, 'EMIT, 'EXPECT, 'TAP, 'ECHO
        'PROMPT, CSP, 'NUMBER, HANDLER, CURRENT, NP

Only these user variables remain and are macros:
        HLD, SPAN, >IN, #TIB, 'TIB, 'EVAL, BASE, tmp
        CP, CONTEXT, LAST, 'ABORT, TEXT

The P24 eForth system can be summarized in the following words
and their pseudo code:

COLD boots Forth, print sign-on message and jump to QUIT
QUIT repeats the sequence: accepts a line of text and executes
     the commands in sequence.  The pseudo code is:
     : QUIT BEGIN QUERY EVAL AGAIN ;
QUERY accepts one line of text of 80 characters or terminated
     by a carriage-return.
EVAL parses out tokens in the text and evaluates them:
     : EVAL BEGIN TOKEN WHILE 'EVAL @EXECUTE REPEAT .OK ;
TOKEN parses out one word from the input text.
'EVAL contains $INTERPRET in the interpret mode or $COMPILE
     in the compiling mode.
@EXECUTE executes either $INTERPRET or $COMPILE.
.OK prints out the "OK" message.
$INTERPRET ( a ) searches the dictionary for a word of the
     text string at a.  If the word exists, execute it.
     Else, convert the string into a number on the stack.
     Failing to convert the string to a number, prints an
     error message and abort to QUIT.
     : $INTERPRET NAME? IF EXECUTE ELSE NUMBER?
         IF ELSE ERROR THEN THEN ;
$COMPILE ( a ) searches the dictionary for a word of the
     text string at a.  If the word exists, compile it.
     Else, convert the string to a number and compile the
     number as a literal.  Failing the conversion, prints
     a message and abort to QUIT.
     : $COMPILE NAME? IF , ELSE NUMBER?
        IF LITERAL ELSE ERROR THEN THEN ;
NAME? calls 'find' to locate a word of the name parsed out
     out the input text string.
NUMBER? ( a ) converts the text string at a to a number.
ERROR prints the offending text string and aborts to QUIT.
LITERAL ( n ) compiles n as a literal into the current word
     being compiled.

The above words serve as a top-down map of the eForth operating
system.  The eForth system source code builds up to QUIT and
COLD.  Most words in EF24.F are necessary in the building
process.  The eForth system can be viewed as a very sophisticated
application of P24.  Most applications are much simplier than
eForth system.  You can model your application code to eForth,
and use all the tools contained therein.

comment;

\ 50us delays 52 us, half of a bit at 9600 baud.
\ 100us delays 104 us, one bit frame at 9600 baud.

\ EMIT ( c ) sends character c to the serial output port.

\ KEY ( -- c ) waits for a character from the serial input port.
\ The serial ports are actually connected to the T register.

\ The No-Cost UART
\ On executing SHR instruction, the least significant bit in
\ T, T(0), is shifted to a flip-flop, whose output is
\ connected to the serial output port.  At the same time
\ the state of the serial input port is latched into the
\ carry bit, which is bit T(24).  Repeating SHR 8 times,
\ a character is sent out.  One character is captured by
\ waiting for the start bit on the serial input port, and then
\ test the port at the intervals of 100 us.
\ One must be very careful in using the SHR instruction.
\ In order not to disturb the output port, you should always
\ set T(0) to a 1 before executing SHR.  This way, the serial
\ output port stays at the mark level.

CRR .( Chararter IO ) CRR
CODE 50us
        2 ldi skip
CODE 100us
        1 ldi
        then
        sta -138 ldi
        begin lda add
        -until
        drop
        ret
CODE EMIT ( c -- )
        $7F ldi and
        shl $FFFF01 ldi xor
        $0A ldi
        FOR shr 100us NEXT
        drop ret
CODE KEY ( -- c )
        $FFFFFF ldi
        begin   shr
        -until
        repeat   ( wait for start bit )
        50us
        7 ldi
        FOR
          100us shr
          -if $80 ldi xor then
        NEXT
        $FF ldi and
        100us ret

\ These common functions are too complicated to code in machine
\ instructions, and are left in the high level form.
CRR .( Common functions ) CRR
:: U< ( u u -- t ) 2DUP XOR 0< IF SWAP DROP 0< EXIT THEN - 0< -;'
::  < ( n n -- t ) 2DUP XOR 0< IF      DROP 0< EXIT THEN - 0< -;'
:: MAX ( n n -- n ) 2DUP      < IF SWAP THEN DROP ;;
:: MIN ( n n -- n ) 2DUP SWAP < IF SWAP THEN DROP ;;
:: WITHIN ( u ul uh -- t ) \ ul <= u < uh
  OVER - >R - R> U< -;'

\ UM/MOD and /MOD share the same body to do division of a 48-bit
\ divident by a 24 bit divisor, using the DIV machine instruction.
\ The higher half of the divident is placed in T and the lower
\ half is placed in A.  The divisor is negated and placed on the
\ data stack below T.  The negated divsor is added to T in the
\ adder.  If a carry is generated, indicating that T is big enought
\ to subtract the divisor, The sum is accepted into T, and then T-A
\ combination is shifted left by one bit.  The most significant bit
\ in A is shifted into T(0), and Carry is shifted into A(0).
\ If the adder does not generate a carry, the subtraction will not
\ be done.  The T-A combination is shifted left by one bit, and
\ a 0 is shifted into A(0).

\ The above divide step DIV instructions is repeated 25 times to
\ generate the proper quotient in A.  The remainder is in T, if it
\ is shifted right by one bit.

\ The only restriction in this division procedure is that the divisor
\ and the divident must be positive.  It cannot handle negative
\ divisor or negative divident.  This is not a serious limitation
\ because the special word M/MOD does signed division by first
\ convert both divisor and divident to postive numbers for division
\ operations, and then place appropriate signs in front of quotient
\ and remainder.

\ UM/MOD, /MOD, /, and MOD all assume that divisors and dividents
\ are positive.  In the eForth system, this is not a problem.
\ Nevertheless, users must be aware of this limitation when writing
\ code which must handle negative numbers.
CRR .( Divide ) CRR
CODE UM/MOD ( ud u -- ur uq )
   com 1 ldi add sta
   push lda push sta
   pop pop
   skip
CODE /MOD ( n n -- r q )
   com 1 ldi add push
   sta pop 0 ldi
   then
   div div div div
   div div div div
   div div div div
   div div div div
   div div div div
   div div div div
   div 1 ldi xor shr
   push drop pop lda
   ret
CODE MOD ( n n -- r )
   /MOD
   drop ret
CODE / ( n n -- q )
   /MOD
   push drop pop ret
:: M/MOD ( d n -- r q ) \ floored
  DUP 0<  DUP >R
  IF NEGATE >R DNEGATE R>
  THEN >R DUP 0< IF R@ + THEN R> UM/MOD R>
  IF SWAP NEGATE SWAP THEN ;;

\ UM* multiplies two unsigned 24-bit integers and produces a
\ 48-bit product.  The multiplier is placed in A register, and
\ the multiplicant is placed on the data stack below T.  T is
\ cleared to zero.  The MUL machine instruction looks at A(0)
\ bit.  If it is a one, the multiplicant is added to T, and
\ the T-A combination is shifted to the right by one bit.
\ Carry us shifted into T(23).  It A(0) is a zero, the multiplicant
\ is not added.  The T-A combination is shifted to the right, and
\ a zero is shifted into T(23).
\ After the MUL instruction is repeated 24 times, a 48-bit product
\ is produced in the T-A combination.  T has the more significant
\ half and A has the less significant half of the product.

\ Both UM* and * do the unsigned multiplication.  M* does signed
\ multiplication.  For correctness, * should call M* to do the
\ multiplicant.  However, here * calls UM* for speed.  You should
\ be aware of this property in your applications.  As the eForth
\ system only does unsigned multiplications, it is not a problem.
CRR .( Multiply ) CRR
CODE UM* ( u u -- ud )
   sta 0 ldi
   mul mul mul mul
   mul mul mul mul
   mul mul mul mul
   mul mul mul mul
   mul mul mul mul
   mul mul mul mul
   push drop lda pop
   ret
:: * ( n n -- n ) UM* DROP ;;
:: M* ( n n -- d )
  2DUP XOR 0< >R  ABS SWAP ABS UM*  R> IF DNEGATE THEN ;;
:: */MOD ( n n n -- r q ) >R M* R> M/MOD -;'
:: */ ( n n n -- q ) */MOD SWAP DROP ;;

\ >CHAR filters out non-printable characters for TYPE.
\ It thus ensures that TYPEing a non-printable character
\ will not choke the printer.
CRR .( Bits & Bytes ) CRR
:: >CHAR ( c -- c )
  $7F LIT AND DUP $7F LIT BL WITHIN
  IF DROP ( CHAR _ ) $5F LIT THEN ;;

CRR .( Memory access ) CRR
:: HERE ( -- a ) CP @ ;;
:: PAD ( -- a ) CP @ 50 LIT + ;;
:: TIB ( -- a ) 'TIB @ ;;

CRR
:: @EXECUTE ( a -- ) @ ?DUP IF EXECUTE THEN ;;
:: CMOVE ( b b u -- )
  FOR AFT >R DUP @ R@ ! 1+ R> 1+ THEN NEXT 2DROP ;;
:: FILL ( b u c -- )
  SWAP FOR SWAP AFT 2DUP ! 1+ THEN NEXT 2DROP ;;

\ PACK$ packs the string at b with length u into memory located
\ at a, three bytes to a 24-bit program word.  It calls B> to
\ do the packing.  This packing function greatly reduces the
\ total size of the P24 code image.  The packing also speeds
\ up the dictionary searches because three bytes are compared
\ at once.  The system scratch variable TMP is used to store
\ the byte count which directs the bytes to their proper
\ location.  After the byte string is fully packed, the last
\ packed program word is left justified and empty slots are
\ filled with NUL bytes.
:: PACK$ ( b u a -- a ) \ null fill
  dup push
  1 ldi tmp sta st
  sta dup push st
  lda pop
  FOR AFT ( b a )
    B>
    tmp sta ld
    IF ld 1 ldi xor
      IF dup dup xor st
         1 ldi add
      ELSE 2 ldi st
      THEN
    ELSE 1 ldi st
    THEN
  THEN NEXT
  tmp sta ld
  IF ld 2 ldi xor
     IF sta ld
        shl shl shl shl
        shl shl shl shl
        st lda
     THEN
     sta ld
     shl shl shl shl
     shl shl shl shl
     st lda
  THEN
  drop drop pop
  ;;

\ UNPACK$ unpacks a packed string at a into a counted byte string
\ at b.  It calls >B to unpack a 24-bit word into three bytes.
\ It allows names of words to be printed, and in-line packed strings
\ to be accessed as byte strings.
:: UNPACK$ ( a b -- b )
  DUP >R ( save b )
  >B $1F LIT AND 3 LIT /
  FOR AFT
    >B DROP
  THEN NEXT
  2DROP R>
  ;;

\ All numbers in P24 are stored internally as 24-bit binary patterns.
\ To make the numbers visual to the user, they are converted to
\ strings of digits to be printed.  A number is converted one digit
\ at a time.  It is divided by the value stored in BASE, and the
\ remainder is converted to a digit by DIGIT.  The quotient is
\ divided further by BASE to build a complete numeric string
\ suitable for printing.  The output numeric string is built
\ backward below the memory buffer at PAD, using HLD as the pointer
\ moving backward.  Additional formating characters can be inserted
\ into the output string by HOLD.

\ This numeric output mechanism is extremely flexible and can produce
\ numbers in a wide variety of formats for tables and arrays.  It also
\ allows the user to display numbers in any reasonable base, like
\ decimal, hexidecimal, octal, and binary, among other non-conventional
\ bases.
CRR .( Numeric Output ) CRR \ single precision
:: DIGIT ( u -- c )
  9 LIT OVER < 7 LIT AND +
  ( CHAR 0 ) 30 LIT + ;;
:: EXTRACT ( n base -- n c )
  0 LIT SWAP UM/MOD SWAP DIGIT -;'
:: <# ( -- ) PAD HLD ! ;;
:: HOLD ( c -- ) HLD @ 1- DUP HLD ! ! ;;
:: # ( u -- u ) BASE @ EXTRACT HOLD -;'
:: #S ( u -- 0 ) BEGIN # DUP WHILE REPEAT ;;
CRR
:: SIGN ( n -- ) 0< IF ( CHAR - ) 2D LIT HOLD THEN ;;
:: #> ( w -- b u ) DROP HLD @ PAD OVER - ;;
:: str ( n -- b u ) DUP >R ABS <# #S R> SIGN #> -;'
:: HEX ( -- ) 10 LIT BASE ! ;;
:: DECIMAL ( -- ) 0A LIT BASE ! ;;

\ Numbers are entered into P24 as strings of digits, delimited by
\ spaces and other white characters like CR, TAB, NUL, etc.
\ Numeric strings are converted to internal binary form by
\ multiply the digits, most significant digit first, by the value
\ in BASE and accumulate the product until the digits are exhausted.

\ NUMBER? does the conversion.  It allows a leading $ to
\ indicate that the numeric string is in hexidecimal.  It also
\ allows a leading - sign for negative numbers.
CRR .( Numeric Input ) CRR \ single precision
:: DIGIT? ( c base -- u t )
  >R ( CHAR 0 ) 30 LIT - 9 LIT OVER <
  IF 7 LIT - DUP 0A LIT  < OR THEN DUP R> U< -;'
:: NUMBER? ( a -- n T | a F )
  BASE @ >R  0 LIT OVER COUNT ( a 0 b n)
  OVER @ ( CHAR $ ) 24 LIT =
  IF HEX SWAP 1+ SWAP 1- THEN ( a 0 b' n')
  OVER @ ( CHAR - ) 2D LIT = >R ( a 0 b n)
  SWAP R@ - SWAP R@ + ( a 0 b" n") ?DUP
  IF 1- ( a 0 b n)
    FOR DUP >R @ BASE @ DIGIT?
      WHILE SWAP BASE @ * +  R> 1+
    NEXT DROP R@ ( b ?sign) IF NEGATE THEN SWAP
      ELSE R> R> ( b index) 2DROP ( digit number) 2DROP 0 LIT
      THEN DUP
  THEN R> ( n ?sign) 2DROP R> BASE ! ;;

\ This is the set of words displaying characters to the output
\ device.
\ DO$ is an internal system word which unpacks a packed string compiled
\ in-line with program words.  It digs up the starting address of the
\ packed string on the return stack, unpacks the string to location a,
\ and then move the return address passing the packed string.  Then,
\ the execution can continue, skipping the packed string in-line.

\ $"| is compiled before a packed string.  It unpacks the string and
\ returns the address of the TEXT buffer where the unpack string is
\ stored.
\ ."| is also compiled before a packed string.  It unpacks the string
\ and displays it on the output device.
CRR .( Basic I/O ) CRR
:: SPACE ( -- ) BL EMIT -;'
:: CHARS ( +n c -- )
  SWAP 0 LIT MAX
  FOR AFT DUP EMIT THEN NEXT DROP ;;
:: SPACES ( +n -- ) BL CHARS -;'
:: TYPE ( b u -- )
  FOR AFT DUP @ >CHAR EMIT 1+
  THEN NEXT DROP ;;
:: CR ( -- ) ( =Cr )
  0A LIT 0D LIT EMIT EMIT -;'
:: do$ ( -- a )
  R> R@ TEXT UNPACK$
  R@ R> @ $3FFFFF LIT AND $30000 LIT / 1+ +
  >R SWAP >R ;;

CRR
:: $"| ( -- a ) do$ -;'
:: ."| ( -- ) do$ COUNT TYPE -;'
::  .R ( n +n -- )
  >R str      R> OVER - SPACES TYPE -;'
:: U.R ( u +n -- )
  >R <# #S #> R> OVER - SPACES TYPE -;'
:: U. ( u -- ) <# #S #> SPACE TYPE -;'
::  . ( n -- )
  BASE @ 0A LIT  XOR
  IF U. EXIT THEN str SPACE TYPE -;'
:: ? ( a -- ) @ . -;'

\ TOKEN parses out the next word in the input stream, delimited by
\ spaces.  The word is packed and placed on the top of the dictionary,
\ so that it can be used to do dictionary searches, and becomes the
\ name field if the word just happed to be the name of a new
\ definition.

\ PARSE allows the user to specify the delimiting character to parse
\ out the next word in the input stream.  It calls 'parse' to do the
\ dirty work.

\ 'parse' scans the input stream and skips the leading blanks if
\ SPACE is the delimiting character.  The parsed word starts with
\ the next non-delimiting character and is terminated by the next
\ delimiting character.  It returns b the beginning address of the
\ parsed word, u the length of the remaining characters in the input
\ stream, and delta the length of the parsed word.  It is a very
\ long word with many nested and interlaced structures.  It is a
\ challenge even to the very experienced Forth programmers.
CRR .( Parsing ) CRR
:: (parse) ( b u c -- b u delta ; <string> )
  tmp ! OVER >R DUP \ b u u
  IF 1- tmp @ BL =
    IF              \ b u' \ 'skip'
      FOR BL OVER @ - 0< NOT
        WHILE 1+
      NEXT ( b) R> DROP 0 LIT DUP EXIT \ all delim
        THEN  R>
    THEN OVER SWAP  \ b' b' u' \ 'scan'
    FOR tmp @ OVER @ -  tmp @ BL =
      IF 0< THEN WHILE 1+
    NEXT DUP >R
      ELSE R> DROP DUP 1+ >R
      THEN OVER -  R>  R> - EXIT
  THEN ( b u) OVER R> - ;;
:: PARSE ( c -- b u ; <string> )
  >R  TIB >IN @ +
  #TIB @ >IN @ -
  R> (parse) >IN +! ;;
:: TOKEN ( -- a ;; <string> )
  BL PARSE 1F LIT MIN 2DUP
  DUP TEXT ! TEXT 1+ SWAP CMOVE
  HERE 1+ PACK$ -;'
:: WORD ( c -- a ; <string> )
  PARSE HERE 1+ PACK$ -;'

\ 'find' follows the linked list in the dictionary, and compares
\ the names of each compiled word with the packed string stored
\ at a.  va points to the starting name field of the dictionary.
\ If a match is found, it returns the execution address (code
\ field address) and the name field address of the matching word
\ in the dictionary.  If it failed to find a match, it returns
\ the address of the packed string and a 0 for a false flag.

\ 'find' runs through the dictionary very quickly, because it
\ compares the length and the first two characters in the names.
\ Most Forth words are unique in these three characters.  For
\ words with the same lengths and identical first two characters,
\ 'find' calls SAME? to determine whether the remaining characters
\  of the packed strings match.
\ NAME> converts a name field address na to a code field address xt.
\
CRR .( Dictionary Search ) CRR
:: NAME> ( na -- xt )
  DUP @ $3FFFFF LIT AND
  $30000 LIT / + 1+ ;;
:: SAME? ( a a u -- a a f \ -0+ )
  $30000 LIT /
  FOR AFT OVER R@ + @
    OVER R@ + @ - ?DUP
    IF R> DROP EXIT THEN
  THEN NEXT
  0 LIT ;;
:: find ( a va -- xt na | a F )
  SWAP         \ va a
  DUP @ tmp !  \ va a  \ get cell count
  DUP @ >R     \ va a  \ count
  1+ SWAP      \ a' va
  BEGIN @ DUP  \ a' na na
    IF DUP @ $3FFFFF LIT AND
      R@ XOR \ ignore lexicon bits
      IF 1+ -1 LIT
      ELSE 1+ tmp @ SAME?
      THEN
    ELSE R> DROP SWAP 1- SWAP EXIT \ a F
    THEN
  WHILE 1- 1-  \ a' la
  REPEAT R> DROP SWAP DROP
  1- DUP NAME> SWAP ;;
:: NAME? ( a -- xt na | a F )
  CONTEXT find -;'

\ ^H processes the Back Space encountered in the input stream.  It
\ backs up the character pointer and erased the character preceeding
\ the Back Sapce.
\ TAP echoes an input character and deposit it into the terminal
\ input buffer.
\ kTAP Detects a Carriage Return to terminate the input stream.  It
\ also calls ^H to process a Back Space, and TAP to process ordinary
\ characters.
\ These words allows the interpreter to handle a human user on the
\ terminal smoothly, and friendly.
CRR .( Terminal ) CRR
:: ^H ( b b b -- b b b ) \ backspace
  >R OVER R> SWAP OVER XOR
  IF ( =BkSp ) 8 LIT EMIT
     1-         BL EMIT \ distructive
     ( =BkSp ) 8 LIT EMIT \ backspace
  THEN ;;
:: TAP ( bot eot cur c -- bot eot cur )
  DUP EMIT OVER ! 1+ ;;
:: kTAP ( bot eot cur c -- bot eot cur )
  DUP ( =Cr ) 0D LIT XOR
  IF ( =BkSp ) 8 LIT XOR
    IF BL TAP ELSE ^H THEN
    EXIT
  THEN DROP SWAP DROP DUP ;;

\ QUERY accepts a line of characters typed in by the user and
\ put them in the terminal input buffer for interpreting or
\ compiling.  The line is terminated at the 80th input
\ character or a Carriage Return.
\ 'accept' waits for input characters and place them in the
\ terminal input buffer at b with length u.  It returns the
\ same buffer address b with the length of the character string
\ actually received.
\ EXPECT receives the input stream and stores the length in the
\ variable SPAN.
CRR
:: accept ( b u -- b u )
  OVER + OVER
  BEGIN 2DUP XOR
  WHILE  KEY  DUP BL -  5F LIT U<
    IF TAP ELSE kTAP THEN
  REPEAT DROP  OVER - ;;
:: EXPECT ( b u -- ) accept SPAN ! DROP ;;
:: QUERY ( -- )
  TIB 50 LIT accept #TIB !
  DROP 0 LIT >IN ! ;;

\ ABORT actually executes QUIT, which is defined much later.
\ Here it is defined as a vectored execution word which gets
\ the execution address in the system variable 'ABORT.  This
\ mechanism also gives the user some flexibility in how the
\ application should handle an error condition.

\ abort" aborts after a warning message is displayed.

\ ERROR prints the character string store in the TEXT buffer
\ before aborting.  The TEXT buffer contains the word just
\ parsed out of the input stream.  This is the word which
\ the interpreter/compiler fail to recognize.  The natural
\ error message is this word followed by a ? mark.
CRR .( Error handling ) CRR
:: ABORT ( -- ) 'ABORT @EXECUTE ;;
:: abort" ( f -- )
  IF do$ COUNT TYPE ABORT THEN do$ DROP ;;
:: ERROR ( a -- )
  SPACE TEXT COUNT TYPE
  $3F LIT EMIT CR ABORT

\ $INTERPRET interprets the word just parsed out of the input
\ stream.  It searches the dictionary for this word.  If a match
\ is found, executes it, unless the word is marked as a
\ compile-only word.  It a match is now found in the dictionary,
\ convert the word into a number.  If successful, the number is
\ left on the data stack.  If not successful, exit with ERROR.
CRR .( Interpret ) CRR
:: $INTERPRET ( a -- )
  NAME?  ?DUP
  IF @ 400000 LIT AND
    ABORT" $LIT compile only" EXECUTE EXIT
  THEN DROP TEXT NUMBER?
  IF EXIT THEN ERROR
:: [ ( -- )
  forth' $INTERPRET  >body forth@ LIT 'EVAL !
  ;; IMMEDIATE
:: .OK ( -- )
  forth' $INTERPRET >body forth@ LIT 'EVAL @ =
  IF ."| $LIT  OK" CR
  THEN ;;
:: EVAL ( -- )
  BEGIN TOKEN DUP @
  WHILE 'EVAL @EXECUTE \ ?STACK
  REPEAT DROP .OK -;'

CRR .( Shell ) CRR
:: QUIT ( -- )
  ( =TIB) $730 LIT 'TIB !
   [ BEGIN QUERY EVAL AGAIN

CRR .( Compiler Primitives ) CRR
:: ' ( -- xt )
  TOKEN NAME? IF EXIT THEN
  ERROR
:: ALLOT ( n -- ) CP +! ;;
:: , ( w -- ) HERE DUP 1+ CP ! ! ;;
:: [COMPILE] ( -- ; <string> )
  '  $100000 LIT OR , -;' IMMEDIATE

CRR
:: COMPILE ( -- ) R> DUP @ , 1+ >R ;;
:: LITERAL $29E79E LIT , ,
  -;' IMMEDIATE
:: $," ( -- ) ( CHAR " )
  22 LIT WORD @ 1+ ALLOT -;'

CRR .( Name Compiler ) CRR
:: ?UNIQUE ( a -- a )
  DUP NAME?
  IF TEXT COUNT TYPE ."| $LIT  reDef "
  THEN DROP ;;
:: $,n ( a -- )
  DUP @
  IF ?UNIQUE
    ( na) DUP DUP NAME> CP !
    ( na) DUP LAST ! \ for OVERT
    ( na) 1-
    ( la) CONTEXT @ SWAP ! EXIT
  THEN ERROR

\ $COMPILE compiles the word just parsed out of the input
\ stream.  It searches the dictionary for this word.  If a match
\ is found, compiles it, unless the word is marked as an
\ immediate word.  An immediate word is executed by the compiler.
\ If a match is not found in the dictionary, convert the word into
\ a number.  If successful, the number is compile as a literal.
\ If not successful, exit with ERROR.
CRR .( FORTH Compiler ) CRR
:: $COMPILE ( a -- )
  NAME? ?DUP
  IF @ $800000 LIT AND
    IF EXECUTE
    ELSE $3FFFF LIT AND $100000 LIT OR ,
    THEN EXIT
  THEN DROP TEXT NUMBER?
  IF LITERAL EXIT
  THEN ERROR
:: OVERT ( -- ) LAST @ CONTEXT ! ;;
:: ; ( -- )
  $5E79E LIT , [ OVERT -;' IMMEDIATE
:: ] ( -- )
  forth' $COMPILE >body forth@ LIT 'EVAL ! ;;
:: : ( -- ; <string> )
  TOKEN $,n ] -;'

CRR .( Tools ) CRR
:: dm+ ( b u -- b )
  OVER 7 LIT U.R SPACE
  FOR AFT DUP @ 7 LIT U.R 1+
  THEN NEXT ;;
:: DUMP ( b u -- )
  BASE @ >R HEX  8 LIT /
  FOR AFT CR 8 LIT 2DUP dm+
  THEN NEXT DROP R> BASE ! ;;

CRR
:: >NAME ( xt -- na | F )
  CONTEXT
  BEGIN @ DUP
  WHILE 2DUP NAME> XOR
    IF 1-
    ELSE SWAP DROP EXIT
    THEN
  REPEAT SWAP DROP ;;
:: .ID ( a -- )
  TEXT UNPACK$
  COUNT $01F LIT AND TYPE SPACE -;'

CRR
:: SEE ( -- ; <string> )
  ' CR
  BEGIN
    20 LIT FOR
      DUP @ DUP FC0000 LIT AND
      DUP
      IF 100000 LIT XOR THEN
      IF U. SPACE
      ELSE 3FFFF LIT AND >NAME
        ?DUP IF .ID THEN
      THEN 1+
    NEXT KEY 0D LIT =  \ can't use ESC on terminal
  UNTIL DROP ;;
:: WORDS ( -- )
  CR CONTEXT
  BEGIN @ ?DUP
  WHILE DUP SPACE .ID 1-
  REPEAT ;;
CODE .S ( dump all 17 stack items )
  PAD sta stp
  stp stp stp stp
  stp stp stp stp
  stp stp stp stp
  stp stp stp stp
  DROP PAD $10 LIT
  FOR DUP ? 1+ NEXT
  DROP PAD @ CR -;'

CRR .( Hardware reset ) CRR
::   DIAGNOSE     ( - )
     $65 LIT
\ 'F'  prove UM+ 0<         \ carry, TRUE, FALSE
     0 LIT 0< -2 LIT 0<     \ 0 FFFF
     UM+ DROP               \ FFFF ( -1)
     3 LIT UM+ UM+ DROP     \ 3
     $43 LIT UM+ DROP       \ 'F'
\ 'o' logic: XOR AND OR
     $4F LIT $6F LIT XOR    \ 20h
     $F0 LIT AND
     $4F LIT OR
\ 'r' stack: DUP OVER SWAP DROP
      8 LIT 6 LIT SWAP
      OVER XOR 3 LIT AND AND
      $70 LIT UM+ DROP       \ 'r'
\ 't'-- prove BRANCH ?BRANCH
      0 LIT IF $3F LIT THEN
      -1 LIT IF $74 LIT ELSE $21 LIT THEN
\ 'h' -- @ ! test memeory address
      $68 LIT $700 LIT !
      $700 LIT @
\ 'M' -- prove >R R> R@
      $4D LIT >R R@ R> AND
\ 'l'  -- prove 'next' can run
      1 LIT $6A LIT FOR 1 LIT UM+ DROP NEXT
      ;;

CRR
:: COLD ( -- )
   diagnose
   CR ."| $LIT P24 v"
   66 LIT <# # # ( CHAR . ) 2E LIT HOLD # #> TYPE
   CR QUIT

CRR .( Structures ) CRR
:: IF ( -- A )    HERE $80000 LIT , -;' IMMEDIATE
:: FOR ( -- a )   $71E79E LIT , HERE -;' IMMEDIATE
:: BEGIN ( -- a ) HERE -;' IMMEDIATE
:: AHEAD ( -- A ) HERE 0 LIT , -;' IMMEDIATE
CRR
:: AGAIN ( a -- ) , -;' IMMEDIATE
:: THEN ( A -- )  HERE SWAP +! ;; IMMEDIATE
:: NEXT ( a -- )  COMPILE doNEXT , -;' IMMEDIATE
:: UNTIL ( a -- ) $80000 LIT + , -;' IMMEDIATE
CRR
:: REPEAT ( A a -- ) AGAIN THEN -;' IMMEDIATE
:: AFT ( a -- a A )  DROP AHEAD BEGIN SWAP ;; IMMEDIATE
:: ELSE ( A -- A )   AHEAD SWAP THEN -;' IMMEDIATE
:: WHILE ( a -- A a ) IF SWAP ;; IMMEDIATE

CRR .( macro words ) CRR

CODE EXIT pop drop ret
CODE EXECUTE push ret
CODE ! sta st ret
CODE @ sta ld ret

CRR
CODE R> pop sta pop lda push ret
CODE R@ pop sta pop dup push lda push ret
CODE >R sta pop push lda ret

CRR
CODE SWAP
   push sta pop lda ret
CODE OVER
   push dup sta pop
   lda ret
CODE 2DROP
   drop drop ret

CRR
CODE +  add ret
CODE NOT com ret
CODE  NEGATE
   com 1 ldi add ret
CODE 1-
   -1 ldi add ret
CODE 1+
   1 ldi add ret

CRR
CODE BL
   20 ldi ret
CODE +!
   sta ld add st
   ret
CODE -
   com add 1 ldi add
   ret

CRR
CODE DUP dup ret
CODE DROP drop ret
CODE AND and ret
CODE XOR xor ret
CODE COM com ret

CRR
:: ABORT" ( -- ; <string> ) COMPILE abort" $," ;; IMMEDIATE
:: $" ( -- ; <string> ) COMPILE $"| $," ;; IMMEDIATE
:: ." ( -- ; <string> ) COMPILE ."| $," ;; IMMEDIATE
:: CODE ( -- ; <string> ) TOKEN $,n OVERT -;'
:: CREATE ( -- ; <string> ) CODE doVAR ;;
:: VARIABLE ( -- ; <string> ) CREATE 0 LIT , -;'

CRR
:: .( ( -- ) 29 LIT PARSE TYPE -;' IMMEDIATE
:: \ ( -- ) #TIB @ >IN ! ;; IMMEDIATE
:: ( 29 LIT PARSE 2DROP ;; IMMEDIATE
:: IMMEDIATE $800000 LIT LAST @ @ OR LAST @ ! ;;

CRR

