eforth.src

eForth is a small portable Forth design for a wide range of microprocessors. This is the first imple

\ eForth Initial Model (8086)

\ Based on bFORTH 1990 by Bill Muench, 1990
\ Donated to eForth Working Group, Silicon Valley FIG Chapter
\ to serve as a model of portable Forth for experimentation.

\ Conventions
 \
  \ <string>  characters in the input stream
  \
  \ a   aligned address
  \ b   byte address
  \ c   character
  \ ca  code address
  \ cy  carry
  \ d   signed double integer
  \ F   logical false
  \ f   flag 0 or non-zero
  \ la  link address
  \ n   signed integer
  \ na  name address
  \ T   logical true
  \ t   flag T or F
  \ u   unsigned integer
  \ ud  unsigned double integer
  \ va  vocabulary address
  \ w   unspecified weighted value

\ Header: token(ptr)  link(la)  name(na)
 \
  \ Count-byte and Lexicon bits  ioxn nnnn
  \   i - immediate
  \   o - compile-only
  \   x - tag
  \   n - string length  (31 characters MAX)
  \ Compiler does not set bits in the NAME string
  \ 0 < la na < .. < la na <    va < CONTEXT       @
  \ 0 < FORTH < .. < vl va < vl va < CURRENT CELL+ @

.( Equates )

$xxxx EQU =RP   \ return stack base
$xxxx EQU =SP   \ data stack base
$xxxx EQU =UP   \ user base
$xxxx EQU =TIB  \ default Terminal Input Buffer

$0080 EQU =IMED \ lexicom immediate bit
$0040 EQU =COMP \ lexicom compile-only bit
$7F1F EQU =MASK \ lexicon bit mask

$0001 EQU =BYTE \ size of a byte
$0002 EQU =CELL \ size of a cell

$000A EQU =BASE \ default radix
$0008 EQU =VOCS \ vocabulary stack depth

$E890 EQU =CALL \ 8086 CALL opcode (NOP CALL)

\ 8086 register useage
 \
  \ AX BX CX DX DI ES  free
  \ SP              data stack pointer
  \ BP              return stack pointer
  \ SI              interpreter pointer
  \ CS=DS=SS        segment pointers
  \ IP              instruction pointer

\ The Forth inner interpreter
 \
  \ On the 8086 it is more efficient to compile
  \ the inner interpreter as inline code.
  \ On other processors it may be better
  \ to jump to the routine.

MACRO NEXT ( -- )
  LODS WORD \ 1 byte
  JMP AX    \ 2 bytes
END-MACRO

.( Special interpreters )

CODE doLIT ( -- w ) COMPILE-ONLY
  LODS WORD \ r> dup 2+ >r @
  PUSH AX
  NEXT
END-CODE

CODE doLIST ( a -- ) \ call dolist list..
  XCHG BP, SP
  PUSH SI     \ push on return stack
  XCHG BP, SP
  POP SI      \ new list address
  NEXT
END-CODE

CODE COLD ( -- )
  JMP ORIG

CODE BYE
  INT $20

CODE EXECUTE ( a -- )
  POP BX
  JMP BX

CODE EXIT ( -- )
  XCHG BP, SP
  POP SI      \ pop from return stack
  XCHG BP, SP
  NEXT
END-CODE

.( Loop & Branch  16bit absolute address )

\ : next ( -- ) \ hiLevel model  16bit absolute branch
\   r> r> dup if 1 - >r @ >r exit then drop cell+ >r ;

CODE next ( -- ) COMPILE-ONLY \ single index loop
  SUB 0 [BP], # 1 WORD  \ decrement index
  U>= IF                \ test index
    MOV SI, 0 [SI]      \ continue looping, r> @ >r
    NEXT
  THEN
  INC BP  INC BP        \ drop index (pop return stack)
LABEL noBRAN
  INC SI  INC SI        \ exit loop
  NEXT
END-CODE

CODE ?branch ( f -- ) COMPILE-ONLY
  POP BX
  OR BX, BX      \ test flag
  JNZ noBRAN
  MOV SI, 0 [SI] \ branch, r> @ >r
  NEXT
END-CODE

CODE branch ( -- ) COMPILE-ONLY
  MOV SI, 0 [SI] \ r> @ >r
  NEXT
END-CODE

.( Memory fetch & store )

CODE ! ( w a -- )
  POP BX
  POP 0 [BX]
  NEXT
END-CODE

CODE @ ( a -- w )
  POP BX
  PUSH 0 [BX]
  NEXT
END-CODE

CODE C! ( w b -- )
  POP BX
  POP AX
  MOV 0 [BX], AL
  NEXT
END-CODE

CODE C@ ( b -- c )
  POP BX
  XOR AX, AX
  MOV AL, 0 [BX]
  PUSH AX
  NEXT
END-CODE

.( Return Stack )

CODE RP@ ( -- a )
  PUSH BP
  NEXT
END-CODE

CODE RP! ( a -- ) COMPILE-ONLY
  POP BP
  NEXT
END-CODE

CODE R> ( -- w ) COMPILE-ONLY
  PUSH 0 [BP]
  INC BP  INC BP
  NEXT
END-CODE

CODE R@ ( -- w )
  PUSH 0 [BP]
  NEXT
END-CODE

CODE >R ( w -- ) COMPILE-ONLY
  DEC BP  DEC BP
  POP 0 [BP]
  NEXT
END-CODE

.( Data Stack )

CODE SP@ ( -- a )
  MOV BX, SP
  PUSH BX
  NEXT
END-CODE

CODE SP! ( a -- )
  POP SP
  NEXT
END-CODE

CODE DROP ( w -- )
  INC SP  INC SP
  NEXT
END-CODE

CODE DUP ( w -- w w )
  MOV BX, SP
  PUSH 0 [BX]
  NEXT
END-CODE

CODE SWAP ( w1 w2 -- w2 w1 )
  POP BX
  POP AX
  PUSH BX
  PUSH AX
  NEXT
END-CODE

CODE OVER ( w1 w2 -- w1 w2 w1 )
  MOV BX, SP
  PUSH 2 [BX]
  NEXT
END-CODE

: ?DUP ( w -- w w, 0 ) DUP IF DUP THEN ;

: NIP ( w w -- w ) SWAP DROP ;

: ROT ( w1 w2 w3 -- w2 w3 w1 ) >R SWAP R> SWAP ;

: 2DROP ( w w  -- ) DROP DROP ;

: 2DUP ( w1 w2 -- w1 w2 w1 w2 ) OVER OVER ;

.( Logic )

CODE 0< ( n -- t )
  POP AX
  CWD
  PUSH DX
  NEXT
END-CODE

CODE AND ( w w -- w )
  POP BX
  POP AX
  AND BX, AX
  PUSH BX
  NEXT
END-CODE

CODE OR ( w w -- w )
  POP BX
  POP AX
  OR BX, AX
  PUSH BX
  NEXT
END-CODE

CODE XOR ( w w -- w )
  POP BX
  POP AX
  XOR BX, AX
  PUSH BX
  NEXT
END-CODE

: INVERT ( w -- w ) -1 XOR ;

.( Arithmetic )

CODE UM+ ( u u -- u cy ) \ or ( u u -- ud )
  XOR CX, CX
  POP BX
  POP AX
  ADD AX, BX
  RCL CX, # 1 \ pick up carry
  PUSH AX
  PUSH CX
  NEXT
END-CODE

: + ( u u -- u ) UM+ DROP ;

:  NEGATE ( n -- -n ) INVERT 1 + ;
: DNEGATE ( d -- -d ) INVERT >R INVERT 1 UM+ R> + ;

: - ( w w -- w ) NEGATE + ;

: ABS ( n -- +n ) DUP 0< IF NEGATE THEN ;

.( User variables )

: doUSER ( -- a ) R> @ UP @ + ; COMPILE-ONLY

: doVAR ( -- a ) R> ; COMPILE-ONLY

8 \ start offset

DUP USER SP0      1 CELL+ \ initial data stack pointer
DUP USER RP0      1 CELL+ \ initial return stack pointer

DUP USER '?KEY    1 CELL+ \ character input ready vector
DUP USER 'EMIT    1 CELL+ \ character output vector

DUP USER 'EXPECT  1 CELL+ \ line input vector
DUP USER 'TAP     1 CELL+ \ input case vector
DUP USER 'ECHO    1 CELL+ \ input echo vector
DUP USER 'PROMPT  1 CELL+ \ operator prompt vector

DUP USER BASE     1 CELL+ \ number base

DUP USER temp     1 CELL+ \ scratch
DUP USER SPAN     1 CELL+ \ #chars input by EXPECT
DUP USER >IN      1 CELL+ \ input buffer offset
DUP USER #TIB     1 CELL+ \ #chars in the input buffer
      1 CELLS ALLOT \   address  of input buffer

DUP USER UP       1 CELL+ \ user base pointer
DUP USER CSP      1 CELL+ \ save stack pointers
DUP USER 'EVAL    1 CELL+ \ interpret/compile vector
DUP USER 'NUMBER  1 CELL+ \ numeric input vector
DUP USER HLD      1 CELL+ \ formated numeric string
DUP USER HANDLER  1 CELL+ \ error frame pointer

DUP USER CONTEXT  1 CELL+ \ first search vocabulary
  =VOCS CELL+ \ vocabulary stack

DUP USER CURRENT  1 CELL+ \ definitions vocabulary
      1 CELL+ \ newest vocabulary

DUP USER CP       1 CELL+ \ dictionary code pointer
      1 CELL+ \ dictionary name pointer
      1 CELL+ \ last name compiled

?USER

.( Comparison )

: 0= ( w -- t ) IF 0 EXIT THEN -1 ;

: = ( w w -- t ) XOR 0= ;

: U< ( u u -- t ) 2DUP XOR 0< IF  NIP 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 ) OVER - >R - R> U< ;

.( Divide )

: UM/MOD ( udl udh un -- ur uq )
  2DUP U<
  IF NEGATE  15
    FOR >R DUP  UM+  >R >R DUP  UM+  R> + DUP
        R> R@ SWAP >R  UM+  R> OR
      IF >R DROP 1 + R> ELSE DROP THEN R>
    NEXT DROP SWAP EXIT
  THEN DROP 2DROP  -1 DUP ;

: 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 ;

: /MOD ( n n -- r q ) OVER 0< SWAP M/MOD ;
: MOD ( n n -- r ) /MOD DROP ;
: / ( n n -- q ) /MOD NIP ;

.( Multiply )

: UM* ( u1 u2 -- ud )
  0 SWAP ( u1 0 u2 ) 15
  FOR DUP  UM+  >R >R DUP  UM+  R> + R>
    IF >R OVER  UM+  R> + THEN
  NEXT ROT DROP ;

: * ( 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 NIP ;

.( Bits & Bytes )

: BYTE+ ( b -- b ) [ =BYTE ] LITERAL + ;
: CELL+ ( a -- a ) [ =CELL ] LITERAL + ;

: CELLS ( n -- n ) [ =CELL ] LITERAL * ;

: BL ( -- 32 ) 32 ;

: >CHAR ( c -- c )
  127 AND DUP 127 BL WITHIN IF [ CHAR _ ] LITERAL NIP THEN ;

: DEPTH ( -- n ) SP@ SP0 @ SWAP - 2 / ;

: PICK ( +n -- w ) 1 + CELLS SP@ + @ ;

: ALIGNED ( b -- a ) ; IMMEDIATE

.( Memory access )

: +! ( n a -- ) SWAP OVER @ + SWAP ! ;

: 2! ( d a -- ) SWAP OVER ! CELL+ ! ;
: 2@ ( a -- d ) DUP CELL+ @ SWAP @ ;

: COUNT ( b -- b +n ) DUP 1 + SWAP C@ ;

: HERE ( -- a ) CP @ ;
: PAD ( -- a ) HERE 80 + ;
: TIB ( -- a ) #TIB CELL+ @ ;

: NP ( -- a ) CP CELL+ ;