\*
 *   ZEN 1.10  Compiler operators
 *     C 1990  by Martin Tracy
 *             Last modified  1.1.90
 *\

\ Allocate n bytes of array memory.
: ALLOT ( n) \ CORE
   VP +! ;

\ Add low byte of w to table memory.
: C, ( w) \ CORE
   TP @ C!  1 TP +! ;

\ Add w to table memory.
: , ( w) \ CORE
   TP @ !  CELL TP +! ;


\ Read one byte from CODE space at address a.
CODE XC@ ( a - b)
        mov   bl,cs:[bx]
        sub   bh,bh
        NEXT
END-CODE

\ Write lower byte into CODE space at address a.
CODE XC! ( w a)
        pop   ax
        mov   cs:[bx],al
        pop   bx
        NEXT
END-CODE

\ Read one word from CODE space at address a.
CODE X@ ( a - w)
        mov   bx,cs:[bx]
        NEXT
END-CODE

\ Write word into CODE space at address a.
CODE X! ( w a)
        pop   cs:[bx]
        pop   bx
        NEXT
END-CODE

\ Force the dictionary to the next aligned address.
: ALIGN
   ;
IMMEDIATE


\ Compile execution token.
: ['] ( "ccc ") ( - w) \ CORE
   '  POSTPONE Tic  X, ;
IMMEDIATE

\ Convert execution token into data field address.
: >BODY ( w - a) \ CORE
   PFA X@ ;

\ Parse ccc and compile the integer value of its first character.
: [CHAR] ( "ccc ") ( - c) \ CORE
   CHAR  POSTPONE LITERAL ;
IMMEDIATE


\ Parse a character-delimited string.
: PARSE ( c "xxxc" - a u)
   >R  SOURCE  >IN @ /STRING  OVER SWAP
   R> SCAN  >R  OVER -  DUP R> IF  1+  THEN  >IN +! ;

\ Scratch string area.
: PAD ( - a) \ EXT CORE
   THERE 34 + ;

: ", ( a u)
   HERE  OVER 1+ TP +!  PLACE ( ALIGN) ;

\ String literal, eg " ccc"
: " ( 'ccc"') ( - a u) \ CORE
   [CHAR] " PARSE
   STATE @ IF  POSTPONE SLit  HERE X,  ",
           ELSE  PAD PLACE  PAD COUNT  THEN ;
IMMEDIATE

\ Message literal, eg ." ccc"
: ." ( 'ccc"') \ CORE
   POSTPONE "  POSTPONE TYPE ;
IMMEDIATE

\ Compile error handler and message.
: ABORT" ( 'ccc"') ( ) \ CORE
   POSTPONE IF  POSTPONE "  POSTPONE ERR  POSTPONE THEN ;
IMMEDIATE

\ Comments
: ( \ CORE
   [CHAR] ) PARSE  2DROP ;
IMMEDIATE

\ Messages
: .( \ CORE
   [CHAR] ) PARSE  TYPE ;
IMMEDIATE


2VARIABLE 'WARN   \ Redefinition and locate field actions
2VARIABLE  LAST   \ Newest lfa and cfa

\ Create link and name fields.
: HEADER ( "<name> ")
   ( ALIGN)  BL WORD  COUNT DUP HUH?  2DUP UPCASE
   'WARN       PERFORM ( Redefinition?)
   'WARN CELL+ PERFORM ( Locate field )
   DP @  DUP LAST !  CURRENT @ DUP @ X, !  ( link field)
   DP @  1+ SWAP  DUP >R  0                ( name field)
   DO  OVER C@ OVER XC!  SWAP 1+ SWAP 1+  LOOP  2DROP
   R@ 1+ DP +!  R> 128 OR  LAST @ CELL+ XC! ;

\ Marks the newest dictionary entry as immediate.
: IMMEDIATE ( ) \ CORE
   LAST @ CELL+  DUP XC@ BL ( ie 32) OR  SWAP XC! ;


| 233 CONSTANT #JMP   \ JMP  Op code
| 232 CONSTANT #CALL  \ CALL Op code

\ Build code field as JMP or CALL to 'code.
| : CODE, ( 'code op)
   DP @  DUP LAST CELL+ !  XC!  1 DP +!  DP @ CELL+ -  X, ;

\ Make 'code the new action of the given code field.
: PATCH ( 'code cfa)
   #JMP  OVER XC!  1+  DUP >R  CELL+ -  R> X! ;


\ Create a table.
: CREATE ( "<name> ") ( - a) \ CORE
   HEADER  ['] DoCreate  #JMP CODE,
   HERE X, ;

\ Create a variable or array
: VARIABLE ( "<name> ") ( - a) \ CORE
   HEADER  ['] DoVariable  #JMP CODE,
   THERE X,  THERE OFF  CELL ALLOT ;

\ Create a constant
: CONSTANT ( w "<name> " ) ( - w) \ CORE
   HEADER  ['] DoConstant  #JMP CODE,
   X, ;


VOX? \*IF
\ Create a vocabulary
: VOCABULARY   \ VOCABULARY
   VARIABLE
   DOES> CONTEXT ! ;
*\

\ Create a value
: VALUE ( "<name> " ) ( - w) \ CORE EXT
   HEADER  ['] DoValue  #JMP CODE,
           ['] DoValTo  #JMP CODE,
   THERE X,  0 THERE !  CELL ALLOT ;


\ Store w into the data field of the VALUE or LOCAL .  State-smart.
: TO ( "<name> ") ( w)
   '  PFA  STATE @ IF  X,  ELSE  EXECUTE  THEN ;
IMMEDIATE


LOX? \*IF
| CODE LOCT
ISLOCAL 0
ISLOCAL 1
ISLOCAL 2
ISLOCAL 3
ISLOCAL 4
ISLOCAL 5
ISLOCAL 6
ISLOCAL 7
END-CODE

| VARIABLE XFrame   \ Local : or DOES> code field

\ Return stack frame support for locals.
| : SF
   XFrame @  LAST CELL+ @ 1+  DUP >R  CELL+ -  R> X! ;

: LOCAL
   BL WORD COUNT  2DUP UPCASE  TUCK  LOC$ @ PLACE  1+ LOC$ +!
   ['] LOCT LOCS @ [ #CFA 2* ] LITERAL * + PFA X,  1  LOCS +! ;
IMMEDIATE
*\


\ Keep together
| VARIABLE BAL    \ Compiler security.
| VARIABLE BAL2   \ Used by  RAKE

\ Start support.
| : ::
[ LOX? ] \IF  LOCS OFF  LOC$ CELL+ LOC$ !
   0 0 BAL 2!  ] ;

\ Start a colon definition.
: : ( "<name> " ) ( ) \ CORE
   HEADER     ['] DoColon  #CALL CODE,
[ LOX? ] \IF  ['] DoFrame  XFrame !
   LAST @ X@ CURRENT @ !  ::  ] ;

\ End support.
| : ;;
[ LOX? ] \IF  LOCS @ IF  SF  THEN
   BAL 2@ OR ABORT" Unbalanced" ;

\ Terminate a colon definition.
: ; ( ) \ CORE
   ;;  LAST @ CURRENT @ !  POSTPONE EXIT  POSTPONE [ ;
IMMEDIATE


\ Connect the most recently defined word to the following code.
| : PIPE ( )
   R> LAST CELL+ @ PATCH ;

\ Add action to most recently defined word.
: DOES> ( ) ( - a) \ CORE
   ;;  POSTPONE PIPE  ['] DoDoes  #CALL CODE,
[ LOX? ] \IF          ['] DoFramD XFrame !
   :: ;
IMMEDIATE


\ Begin an indefinite loop.
: BEGIN ( - sys) ( ) \ CORE
   DP @  1 BAL +! ;
IMMEDIATE

\ Decrement BAL factor.
| : -BAL ( )
  -1 BAL +! ;

\ Begin IF ... ELSE ... THEN
: IF ( - sys) ( f) \ CORE
   POSTPONE ZBranch  POSTPONE BEGIN  0 X, ;
IMMEDIATE

\ End IF ... ELSE ... THEN
: THEN ( sys) ( ) \ CORE
   -BAL  DP @ SWAP X! ;
IMMEDIATE

\ Used in IF ... ELSE ... THEN
: ELSE ( sys - sys2) ( ) \ CORE
   POSTPONE Branch  POSTPONE BEGIN  0 X,  SWAP  POSTPONE THEN ;
IMMEDIATE

\ End BEGIN ... UNTIL
: UNTIL ( sys) ( f) \ CORE
   -BAL  POSTPONE ZBranch  X, ;
IMMEDIATE

\ End BEGIN ... AGAIN
: AGAIN ( sys) ( ) \ EXT CORE
   -BAL  POSTPONE Branch  X, ;
IMMEDIATE

\ Used in BEGIN ... WHILE ... REPEAT
: WHILE ( sys - sys2) ( f) \ CORE
   BAL @ HUH?  POSTPONE IF  SWAP ;
IMMEDIATE

\ End BEGIN ... WHILE ... REPEAT
: REPEAT ( sys) ( ) \ CORE
   POSTPONE AGAIN  POSTPONE THEN ;
IMMEDIATE


\ Begin a definite loop
: DO ( - sys) ( n n2; R: n n2) \ CORE
   POSTPONE BEGIN  POSTPONE RDo ;
IMMEDIATE

\ Begin a definite loop if indices are unequal.
: ?DO ( - sys) ( n n2; R: n n2) \ CORE
   POSTPONE ?>  POSTPONE ZBranch
   BAL2 @ X,  DP @ BAL2 !
   POSTPONE DO  ;  IMMEDIATE

\ Terminate definite loop immediately.
: LEAVE ( sys - sys2) ( ) \ CORE
   POSTPONE UNLOOP  POSTPONE Branch
   DP @  BAL2 @ X,  BAL2 ! ;
IMMEDIATE

\ Gathers LEAVEs.  Courtesy of Wil Baden.
| : RAKE ( sys) ( 'RDo)
   DUP CELL+ X,  BAL2 @
   BEGIN  2DUP 1+ U<
   WHILE  2DUP = CELL AND -  DUP X@ DP @ ROT X!
   REPEAT  BAL2 ! DROP ;

\ End DO ... LOOP
: LOOP ( sys) ( ; R: | n n2) \ CORE
   -BAL  POSTPONE RLoop  RAKE ;
IMMEDIATE

\ End DO ... +LOOP
: +LOOP ( sys) ( n; R: | n n2) \ CORE
   -BAL  POSTPONE PLoop  RAKE ;
IMMEDIATE


\ Compile a self-reference.
: RECURSE ( ?) \ CORE
   LAST CELL+ @ X, ;
IMMEDIATE

\ Postpone execution of this word.
: POSTPONE ( "ccc ") ( ?) \ CORE
   BL WORD  DUP C@ HUH?  FIND  DUP HUH?  0<
   IF  POSTPONE LITERAL  POSTPONE X,  ELSE  X,  THEN ;
IMMEDIATE


\ Display words in search order.
: WORDS ( ) \ RESERVED
   CONTEXT @ @
   BEGIN  ?DUP
   WHILE  CR  DUP CELL+  THERE  OVER XC@ 31 AND  DUP THERE C!  0
     DO  SWAP 1+ SWAP 1+  OVER XC@ OVER C!  LOOP  2DROP
     THERE COUNT TYPE
     ?KEY IF  2DROP EXIT  THEN
     DUP X@
   REPEAT ;
