ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/MISC/ZEN1_10.ZIP/INTRPRET.SRC

Text File | 1990-01-25 | 8.7 KB | 339 lines

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

\ Address space pointers.  Keep together.
  VARIABLE DP     \ Dictionary pointer
| VARIABLE TP     \ Table area pointer
| VARIABLE VP     \ Array area pointer

\ Next available table location.
: HERE ( - a) \ CORE
   TP @ ;

\ Next available array location.
: THERE ( - a)
   VP @ ;

\ Add w to the dictionary
CODE X, ( w)
        mov   di,[_DPv]
        mov   cs:[di],bx
        add   [_DPv],2
        pop   bx
        NEXT
END-CODE


\ Keep together
VARIABLE BLK    \ Input stream switch CORE
VARIABLE >IN    \ Input stream offset CORE

\ Keep together
  VARIABLE #TIB   \ Count of characters in TIB CORE
| VARIABLE  TUB   \ TIB pointer
  80 ALLOT        \ Default Terminal Input Buffer (TIB)

\ Terminal Input Buffer
: TIB ( - a) \ CORE
   TUB @ ;

\ Terminal input stream.
| : SOURCE ( - a u)
   TUB @ #TIB @ ;

\ Parse a character-delimited string.
\ Leading delimiters are accepted and skipped;
\ the string is counted and followed by an uncounted blank.
: WORD ( c " ccc " - a) \ CORE
   >R  SOURCE  >IN @ /STRING  OVER R> 2>R
   R@ SKIP  OVER SWAP
   R> SCAN  OVER R> -  SWAP  IF  1+  THEN  >IN +!
   OVER -  31 MIN  THERE  DUP >R
   PLACE   BL R@ COUNT + C!   R> ;

\ Parse ccc and return the integer value of its first character.
: CHAR ( "ccc " ; - c) \ CORE
   BL WORD  COUNT HUH?  C@ ;

\ Search vocabulary for a match with the packed name at  a .
CODE THREAD ( a w - a 0 , cfa -1 , cfa 1)
        pop   dx
        push  si
        mov   ax,cs
        mov   es,ax
        jmp   Thr2
Thr1:   mov   bx,cs:[bx] ; chain thru dictionary
Thr2:   or    bx,bx
        jz    Thr5       ; jump if end of thread
        mov   si,dx      ; 'string
        mov   di,bx
        add   di,2       ; si -> nfa
        mov   cl,cs:[di]
        and   cx,01Fh
        cmp   cl,[si]    ; counts equal?
        jnz   Thr1
        inc   si         ; -> body of 'string
        inc   di
        repe cmpsb       ; names equal?
        jnz   Thr1
        pop   si
        push  di         ; cfa
        test  BYTE PTR cs:[bx+2],020h ; immediate bit
        mov   bx,TRUTH
        jz    Thr4
        neg   bx
Thr4:   NEXT
Thr5:   pop   si
        push  dx         ; bx = 0
        NEXT
END-CODE

\ Convert string to upper case in place.
CODE UPCASE ( a u)
        xchg  cx,bx
        pop   bx
        jcxz  UpC3
UpC1:   mov   al,[bx]
        cmp   al,'a'
        jb    UpC2
        cmp   al,'z'
        ja    UpC2
        xor   al,32
        mov   [bx],al
UpC2:   inc   bx
        loop  UpC1
UpC3:   pop   bx
        NEXT
END-CODE

\*
\ Convert string to upper case in place.
: UPCASE ( a u)
   0 ?DO  DUP C@  DUP [CHAR] a [CHAR] z 1+ WITHIN
          IF  BL XOR  THEN  OVER C!  1+
      LOOP  DROP ;
*\

\ STATE variables.  Keep together.
  VARIABLE STATE   \ True if compiling CORE
| VARIABLE SBCTR   \ SB pointer in STRINGS2.SRC
| VARIABLE EVCTR   \ EVAL index in FILES.SRC
  CELL ALLOT       \ Spare

\ Stop interpreting; start compiling.
: ] ( ) \ CORE
   STATE ON ;

\ Stop compiling; start interpreting.
: [ ( ) \ CORE
   STATE OFF ;
IMMEDIATE

LOX? \*IF
| VARIABLE LOCS   \ Locals index counter.
| VARIABLE LOC$   \ Locals name array.  Max 8 names.
32 8 * ALLOT      \ Names go here.

\ Find local in local name array.
| : LOCAL? ( a - a 0 | w -1)
   LOCS  @ 0= IF  0  EXIT THEN
   STATE @ DUP
   IF  DROP  DUP C@ 1+  LOC$ CELL+  LOCS @  0
      DO  ( a n+1 a2) >R  2DUP R@  -TEXT 0=
         IF  R> DROP 2DROP  I 6 * ['] LOCT +  TRUE  UNLOOP EXIT  THEN
         R> COUNT +
      LOOP   2DROP 0
   THEN ;
*\


VOX? \*IF
8 EQU #VOCS   \ Maximum 8 vocabularies in the search order

VARIABLE CURRENT   \ Pointer to definition  VOCABULARY
VARIABLE CONTEXT   \ Pointer to search link VOCABULARY
#VOCS CELLS ALLOT

: DEFINITIONS   \ VOCABULARY
   CONTEXT @ CURRENT ! ;

VOCABULARY ROOT    \ Put search order words here
ROOT DEFINITIONS

VOCABULARY FORTH   \ VOCABULARY

\ Adds CONTEXT to the fixed search order.
: ALSO   \ VOC EXT
   CONTEXT  DUP CELL+ [ #VOCS 1- CELLS ] LITERAL CMOVE> ;

\ Sets vocabulary stack to ROOT only.
: ONLY   \ VOC EXT
   CONTEXT CELL+ [ #VOCS CELLS ] LITERAL ERASE  ROOT ALSO ;

\ Remove the transient first vocabulary from the search order.
\ Must be the last definition in the ROOT vocabulary.
: PREVIOUS   \ VOC EXT
   CONTEXT  DUP CELL+ SWAP [ #VOCS CELLS ] LITERAL CMOVE ;

FORTH DEFINITIONS

\ Search dictionary for a match with the given counted name.
\ Return execution address and -1 or 1 ( IMMEDIATE) if found;
\ ['] EXIT 1 if  a  has zero length;  a 0  if not found.
: FIND ( a - a 0 | a - w -1 | a - w 1) \ CORE
   DUP C@ IF  DUP COUNT UPCASE
[ LOX? ] \IF  LOCAL?              ?DUP IF  EXIT  THEN
              CONTEXT @ @ THREAD  ?DUP IF  EXIT  THEN  CONTEXT
   BEGIN  DUP CELL+  DUP @ 0= IF  2DROP  0 EXIT  THEN  SWAP 2@ -
      IF  ( 'string 'thread)  TUCK @ @ THREAD
          ?DUP IF  ROT DROP  EXIT  THEN  SWAP
      THEN
   AGAIN ( stops at sentinel)
   ELSE  DROP  ['] EXIT 1  THEN ;
*\

VOX? NOT \*IF
\ Keep together
  VARIABLE CONTEXT   \ Pointer to search link VOCABULARY
| VARIABLE CURRENT   \ Pointer to definition  VOCABULARY
| VARIABLE 'FORTH    \ Forth VOCABULARY body

\ Search dictionary for a match with the given counted name.
\ Return execution address and -1 or 1 ( IMMEDIATE) if found;
\ ['] EXIT 1 if  a  has zero length;  a 0  if not found.
: FIND ( a - a 0 | a - w -1 | a - w 1) \ CORE
   DUP C@ IF  DUP COUNT UPCASE
[ LOX? ] \IF  LOCAL?             ?DUP IF  EXIT  THEN
              CONTEXT @ @ THREAD  DUP IF  EXIT  THEN
              CONTEXT @ 'FORTH -
              IF  DROP  'FORTH  @ THREAD  THEN  EXIT
          ELSE  DROP  ['] EXIT 1  THEN ;
*\


\ # items on stack before DEPTH is executed.
CODE DEPTH ( - n) \ CORE
        push bx
        mov  bx,(OFFSET DGROUP: SP0)-2
        sub  bx,sp
        sar  bx,1
        NEXT
END-CODE

\ Empty data stack.
CODE BARE ( )
        sti
        mov   sp,OFFSET DGROUP: SP0
        cli
        NEXT
END-CODE

\ Reset return stack and STATE variables.
\ Used for error recovery.
: RESET ( )
   STATE 4 CELLS 0 FILL [
ASSEMBLER
        dw    Res1
Res1:   mov   si,[bp]
        mov   bp,OFFSET DGROUP: RP0
        NEXT
END-CODE


\ Keep together
  VARIABLE 'MAIN   \ Main entry point.  Default error handler comes here.
| VARIABLE 'ERR    \ ERR transfer vector

\ Default error recovery used by ABORT"
| : ERR ( )
   'ERR PERFORM ;

\ Error action of several words.
| : HUH? ( w)
   0= ABORT" ?" ;

\ Compile w as a literal.
: LITERAL ( - w) \ CORE
   POSTPONE Lit  ( w) X, ;
IMMEDIATE

\ Compile the top w stack items as numeric literals.
| : VAL, ( ... w)
   DUP BEGIN  ROT >R                1- ?DUP 0= UNTIL
       BEGIN  R>  POSTPONE LITERAL  1- ?DUP 0= UNTIL ;

\ Return the execution token for the following word.
: ' ( " name " ; - w) \ CORE
   BL WORD  DUP C@ HUH?  FIND HUH? ;

\ The interpreter proper.
| : INTERPRET ( )
   BEGIN  BL WORD  FIND  ?DUP ( found?)
     IF    STATE @ = ( Imm?)
           IF  X,  ELSE  EXECUTE  THEN
     ELSE  COUNT VAL?  DUP HUH?
           STATE @ IF  VAL,  ELSE  DROP  THEN
     THEN
   AGAIN ;

\ Interpret a string.
: EVALUATE ( a u) \ CORE
   #TIB 2@ 2>R  #TIB 2!  BLK 2@ 2>R  0 0 BLK 2!  INTERPRET
   2R> BLK 2!  2R> #TIB 2! ;


\ Fill TIB from next line of input stream.
: QUERY \ EXT CORE
   0 0 BLK 2!  TUB CELL+ TUB !  TIB 80 EXPECT  SPAN @ #TIB ! ;

\ Status check.
| : OK? ( )
   DEPTH 0< ABORT" Stack?"
   STATE @ 0= IF  ." Ok"  THEN ;

\ Default main program.
: QUIT ( ) \ CORE
   RESET  'MAIN PERFORM
   BEGIN  CR QUERY  SPACE INTERPRET  OK?  AGAIN ;

\ Default main program,
: ABORT ( ?) \ CORE
   BARE  QUIT ;

\ Default error handler.
| : GRIPE ( a u)
   THERE COUNT 1+ TYPE ( msg ) TYPE  ABORT ;


\ Print signed if decimal, unsigned otherwise.
| : X. ( n)
   BASE @ 10 = IF  .  EXIT  THEN  U. ;

\ Print contents at address.
: ? ( a) \ EXT CORE
   @ X. ;

\ Print stack contents.
: .S ( ?) \ RESERVED
   CR  DEPTH 0 MAX  ?DUP 0= IF  ." Empty "  EXIT THEN
   ." --> "  DUP 0 DO  DUP I - PICK X.  LOOP  DROP ;

\ Display n bytes from address a.
: DUMP ( a n) \ RESERVED
   0 ?DO  I 7 AND 0= IF  CR  THEN  DUP C@ U.  1+ LOOP  DROP ;

\ For Your Information.
: FYI ( )
     CR ." Bytes remaining" [
ASSEMBLER
        dw    Lit, Table_Area_Size, Lit, OFFSET TP0
        dw    Lit, Array_Area_Size, Lit, OFFSET VP0
        dw    Lit, Dictionary_Size, Lit, OFFSET DP0
END-CODE
   ] CR ." Dict : " - U.
     CR ." Array: " - U.
     CR ." Table: " - U.  SPACE ;