eforth.src

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

: LAST ( -- a ) NP CELL+ ;

: @EXECUTE ( a -- ) @ ?DUP IF EXECUTE THEN ;

: CMOVE ( b b u -- )
  FOR AFT >R COUNT R@ C! R> 1 + THEN NEXT 2DROP ;

: -TRAILING ( b u -- b u )
  FOR AFT DUP R@ + C@  BL XOR
    IF R> 1 + EXIT THEN THEN
  NEXT 0 ;

: FILL ( b u c -- )
  SWAP FOR SWAP AFT 2DUP C! 1 + THEN NEXT 2DROP ;

: ERASE ( b u -- ) 0 FILL ;

: PACK$ ( b u a -- a ) \ null terminated
  DUP >R  2DUP C! 1 + 2DUP +  0  SWAP ! SWAP CMOVE  R> ;

.( Numeric Output ) \ single precision

: DIGIT ( u -- c ) 9 OVER < 7 AND + [ CHAR 0 ] LITERAL + ;
: EXTRACT ( n base -- n c ) 0 SWAP UM/MOD SWAP DIGIT ;

: <# ( -- ) PAD HLD ! ;

: HOLD ( c -- ) HLD @ 1 - DUP HLD ! C! ;

: # ( u -- u ) BASE @ EXTRACT HOLD ;

: #S ( u -- 0 ) BEGIN # DUP WHILE REPEAT ;

: SIGN ( n -- ) 0< IF [ CHAR - ] LITERAL HOLD THEN ;

: #> ( w -- b u ) DROP HLD @ PAD OVER - ;

: str ( w -- b u ) DUP >R ABS <# #S R> SIGN #> ;

: HEX ( -- ) 16 BASE ! ;
: DECIMAL ( -- ) 10 BASE ! ;

.( Numeric Input ) \ single precision

: DIGIT? ( c base -- u t )
  >R [ CHAR 0 ] LITERAL - 9 OVER <
  IF 7 - DUP 10 < OR THEN DUP R> U< ;

: NUMBER? ( a -- n T, a F )
  BASE @ >R  0 OVER COUNT ( a 0 b n)
  OVER C@ [ CHAR $ ] LITERAL =
  IF HEX SWAP BYTE+ SWAP 1 - THEN ( a 0 b' n')
  OVER C@ [ CHAR - ] LITERAL = >R ( a 0 b n)
  SWAP R@ - SWAP R@ + ( a 0 b" n") ?DUP
  IF 1 - ( a 0 b n)
    FOR DUP >R C@ BASE @ DIGIT?
      WHILE SWAP BASE @ * +  R> BYTE+
    NEXT R@ ( ?sign) NIP ( b) IF NEGATE THEN SWAP
      ELSE R> R> ( b index) 2DROP ( digit number) 2DROP 0
      THEN DUP
  THEN R> ( n ?sign) 2DROP R> BASE ! ;

.( Basic I/O )

: KEY? ( -- f ) '?KEY @EXECUTE ;
: KEY ( -- c ) BEGIN '?KEY UNTIL ;
: EMIT ( c -- ) 'EMIT @EXECUTE ;

: NUF? ( -- f ) KEY? DUP IF KEY 2DROP KEY 13 = THEN ;

:  PACE ( -- ) 11 EMIT ;
: SPACE ( -- ) BL EMIT ;

: CHARS ( +n c -- ) SWAP 0 MAX FOR AFT DUP EMIT THEN NEXT DROP ;

: SPACES ( +n -- ) BL CHARS ;

: do$ ( -- a )
  R> R@ R> COUNT + ALIGNED >R SWAP >R ; COMPILE-ONLY

: $"| ( -- a ) do$ ; COMPILE-ONLY

: TYPE ( b u -- ) FOR AFT COUNT EMIT THEN NEXT DROP ;

: .$ ( a -- ) COUNT TYPE ;

: ."| ( -- ) do$ .$ ; COMPILE-ONLY

: CR ( -- ) 13 EMIT 10 EMIT ;

:  .R ( n +n -- ) >R str      R> OVER - SPACES TYPE ;
: U.R ( u +n -- ) >R <# #S #> R> OVER - SPACES TYPE ;

: U. ( u -- ) <# #S #> SPACE TYPE ;
:  . ( w -- ) BASE @ 10 XOR IF U. EXIT THEN str SPACE TYPE ;

: ? ( a -- ) @ . ;

.( Parsing )

: parse ( b u c -- b u delta \ <string> )
  temp !  OVER >R  DUP \ b u u
  IF 1 -  temp @ BL =
    IF \ b u' \ 'skip'
      FOR COUNT temp @  SWAP - 0< INVERT  WHILE
      NEXT ( b) R> DROP 0 DUP EXIT \ all delim
        THEN  1 -  R>
    THEN OVER SWAP \ b' b' u' \ 'scan'
    FOR COUNT temp @ SWAP -  temp @ BL =
      IF 0< THEN WHILE
    NEXT DUP >R  ELSE R> DROP DUP >R 1 -
                 THEN OVER -  R>  R> - EXIT
  THEN ( b u) OVER R> - ;

: PARSE ( c -- b u \ <string> )
  >R  TIB >IN @ +  #TIB @ >IN @ -  R> parse >IN +! ;

: .( ( -- ) [ CHAR ) ] LITERAL PARSE TYPE ; IMMEDIATE
: ( ( -- ) [ CHAR ) ] LITERAL PARSE 2DROP ; IMMEDIATE
: \ ( -- ) #TIB @ >IN ! ; IMMEDIATE

: CHAR ( -- c ) BL PARSE DROP C@ ;
: CTRL ( -- c ) CHAR $001F AND ;

: TOKEN ( -- a \ <string> )
  BL PARSE 31 MIN NP @ OVER - 2 - PACK$ ;

: WORD ( c -- a \ <string> ) PARSE HERE PACK$ ;

.( Dictionary Search )

: NAME> ( na -- ca ) 2 CELLS - @ ;

: SAME? ( a a u -- a a f \ -0+ )
  FOR AFT OVER R@ CELLS + @
          OVER R@ CELLS + @ -  ?DUP
    IF R> DROP EXIT THEN THEN
  NEXT 0 ;

: find ( a va -- ca na, a F )
  SWAP              \ va a
  DUP C@ 2 / temp ! \ va a  \ get cell count
  DUP @ >R          \ va a  \ count byte & 1st char
  CELL+ SWAP        \ a' va
  BEGIN @ DUP       \ a' na na
    IF DUP @ [ =MASK ] LITERAL AND  R@ XOR \ ignore lexicon bits
      IF CELL+ -1 ELSE CELL+ temp @ SAME? THEN
    ELSE R> DROP EXIT
    THEN
  WHILE 2 CELLS -   \ a' la
  REPEAT R> DROP NIP 1 CELLS -  DUP NAME> SWAP ;

: NAME? ( a -- ca na, a F )
  CONTEXT  DUP 2@ XOR IF 1 CELLS - THEN >R \ context<>also
  BEGIN R>  CELL+  DUP >R  @  ?DUP
  WHILE find  ?DUP
  UNTIL R> DROP EXIT THEN R> DROP  0 ;

.( Terminal )

: ^H ( b b b -- b b b ) \ backspace
  >R OVER R@ < DUP
  IF [ CTRL H ] LITERAL 'ECHO @EXECUTE THEN R> + ;

: TAP ( bot eot cur key -- bot eot cur )
  DUP 'ECHO @EXECUTE OVER C! 1 + ;

: kTAP ( bot eot cur key -- bot eot cur )
  DUP 13 XOR
  IF [ CTRL H ] LITERAL XOR IF BL TAP ELSE ^H THEN EXIT
  THEN DROP NIP DUP ;

: accept ( b u -- b u )
  OVER + OVER
  BEGIN 2DUP XOR
  WHILE  KEY  DUP BL -  95 U<
    IF TAP ELSE 'TAP @EXECUTE THEN
  REPEAT DROP  OVER - ;

: EXPECT ( b u -- ) 'EXPECT @EXECUTE SPAN ! DROP ;

: QUERY ( -- )
  TIB 80 'EXPECT @EXECUTE #TIB !  0 NIP >IN ! ;

.( Error handling )

: CATCH ( ca -- err#/0 )
  SP@ >R  HANDLER @ >R  RP@ HANDLER !
  EXECUTE
  R> HANDLER !  R> DROP  0 ;

: THROW ( err# -- err# )
  HANDLER @ RP!  R> HANDLER !  R> SWAP >R SP! DROP R> ;
                        
CREATE NULL$ 0 ,

: ABORT ( -- ) NULL$ THROW ;

: abort" ( f -- ) IF do$ THROW THEN do$ DROP ; COMPILE-ONLY

.( Interpret )

: $INTERPRET ( a -- )
  NAME?  ?DUP
  IF @ [ =COMP ] LITERAL AND
    ABORT" compile ONLY" EXECUTE EXIT
  THEN
  'NUMBER @EXECUTE
  IF EXIT THEN THROW ;

: [ ( -- ) [ ' $INTERPRET ] LITERAL 'EVAL ! ; IMMEDIATE

: .OK ( -- ) [ ' $INTERPRET ] LITERAL 'EVAL @ = IF ."  ok" THEN CR ;

: ?STACK ( -- ) DEPTH 0< IF $" underflow" THROW THEN ;

: EVAL ( -- )
  BEGIN TOKEN DUP C@
  WHILE 'EVAL @EXECUTE ?STACK
  REPEAT DROP 'PROMPT @EXECUTE ;

.( Device I/O )

CODE IO? ( -- f ) \ FFFF is an impossible character
  XOR BX, BX
  MOV DL, # $0FF  \ input
  MOV AH, # 6     \ MS-DOS Direct Console I/O
  INT $021
  0<> IF          \ ?key ready
    OR AL, AL
    0= IF         \ ?extended ascii code
      INT $021
      MOV BH, AL  \ extended code in msb
    ELSE MOV BL, AL
    THEN
    PUSH BX
    MOVE BX, # -1
  THEN
  PUSH BX
  NEXT
END-CODE

CODE TX! ( c -- )
  POP DX
  CMP DL, # $0FF
  0= IF          \ do NOT allow input
    MOV DL, # 32  \ change to blank
  THEN
  MOV AH, # 6    \ MS-DOS Direct Console I/O
  INT $021
  NEXT
END-CODE

: !IO ( -- ) ; IMMEDIATE \ initialize I/O device

.( Shell )

: PRESET ( -- ) SP0 @ SP!  [ =TIB ] LITERAL #TIB CELL+ ! ;

: XIO ( a a a -- ) \ reset 'EXPECT 'TAP 'ECHO 'PROMPT
  [ ' accept ] LITERAL 'EXPECT !
  'TAP !  'ECHO !  'PROMPT ! ;

: FILE ( -- )
  [ ' PACE ] LITERAL [ ' DROP ] LITERAL [ ' kTAP ] LITERAL XIO ;

: HAND ( -- )
  [ ' .OK  ] LITERAL 'EMIT @ [ ' kTAP ] LITERAL XIO ;

CREATE I/O  ' RX? , ' TX! , \ defaults

: CONSOLE ( -- ) I/O 2@ 'KEY? 2! HAND ;

: que ( -- ) QUERY EVAL ;

: QUIT ( -- ) \ clear return stack ONLY
  RP0 @ RP!
  BEGIN [COMPILE] [
    BEGIN [ ' que ] LITERAL CATCH ?DUP
    UNTIL ( a)
    CONSOLE  NULL$ OVER XOR
    IF CR TIB #TIB @ TYPE
       CR >IN @ [ CHAR ^ ] LITERAL CHARS
       CR .$ ."  ? "
    THEN PRESET
  AGAIN ;

.( Compiler Primitives )

: ' ( -- ca ) TOKEN NAME? IF EXIT THEN THROW ;

: ALLOT ( n -- ) CP +! ;

: , ( w -- ) HERE ALIGNED DUP CELL+ CP ! ! ;

: [COMPILE] ( -- \ <string> ) ' , ; IMMEDIATE

: COMPILE ( -- ) R> DUP @ , CELL+ >R ; COMPILE-ONLY

: LITERAL ( w -- ) COMPILE doLIT , ; IMMEDIATE

: $," ( -- ) [ CHAR " ] LITERAL PARSE HERE PACK$ C@ 1 + ALLOT ;

: RECURSE ( -- ) LAST @ CURRENT @ ! ; IMMEDIATE

.( Structures )

: FOR ( -- a ) COMPILE >R HERE ; IMMEDIATE
: BEGIN ( -- a ) HERE ; IMMEDIATE
: NEXT ( a -- ) COMPILE next , ; IMMEDIATE
: UNTIL ( a -- ) COMPILE ?branch , ; IMMEDIATE
: AGAIN ( a -- ) COMPILE  branch , ; IMMEDIATE
: IF ( -- A )   COMPILE ?branch HERE 0 , ; IMMEDIATE
: AHEAD ( -- A ) COMPILE branch HERE 0 , ; IMMEDIATE
: REPEAT ( A a -- ) [COMPILE] AGAIN HERE SWAP ! ; IMMEDIATE
: THEN ( A -- ) HERE SWAP ! ; IMMEDIATE
: AFT ( a -- a A ) DROP [COMPILE] AHEAD [COMPILE] BEGIN SWAP ; IMMEDIATE
: ELSE ( A -- A )  [COMPILE] AHEAD SWAP [COMPILE] THEN ; IMMEDIATE
: WHILE ( a -- A a )    [COMPILE] IF SWAP ; IMMEDIATE

: ABORT" ( -- \ <string> ) COMPILE abort" $," ; IMMEDIATE

: $" ( -- \ <string> ) COMPILE $"| $," ; IMMEDIATE
: ." ( -- \ <string> ) COMPILE ."| $," ; IMMEDIATE

.( Name Compiler )

: ?UNIQUE ( a -- a )
  DUP NAME? IF ."  reDef " OVER .$ THEN DROP ;

: $,n ( na -- )
  DUP C@
  IF ?UNIQUE
    ( na) DUP LAST ! \ for OVERT
    ( na) HERE ALIGNED SWAP
    ( cp na) 1 CELLS -
    ( cp la) CURRENT @ @
    ( cp la na') OVER !
    ( cp la) 1 CELLS - DUP NP ! ( ptr) ! EXIT
  THEN $" name" THROW ;

.( FORTH Compiler )

: $COMPILE ( a -- )
  NAME? ?DUP
  IF C@ [ =IMED ] LITERAL AND
    IF EXECUTE ELSE , THEN EXIT
  THEN
  'NUMBER @EXECUTE
  IF [COMPILE] LITERAL EXIT
  THEN THROW ;

: OVERT ( -- ) LAST @ CURRENT @  ! ;

: ; ( -- )
  COMPILE EXIT [COMPILE] [ OVERT ; COMPILE-ONLY IMMEDIATE

: ] ( -- ) [ ' $COMPILE ] LITERAL 'EVAL ! ;

: CALL, ( ca -- ) \  DTC 8086 relative call
  [ =CALL ] LITERAL , HERE CELL+ - , ;

: : ( -- \ <string> ) TOKEN $,n [ ' doLIST ] LITERAL CALL, ] ;

: IMMEDIATE ( -- ) [ =IMED ] LITERAL LAST @ C@ OR LAST @ C! ;

.( Defining Words )

: USER ( u -- \ <string> ) TOKEN $,n OVERT COMPILE doUSER , ;

: CREATE ( -- \ <string> ) TOKEN $,n OVERT COMPILE doVAR ;

: VARIABLE ( -- \ <string> ) CREATE 0 , ;

.( Tools )

: _TYPE ( b u -- ) FOR AFT COUNT >CHAR EMIT THEN NEXT DROP ;

: dm+ ( b u -- b )
  OVER 4 U.R SPACE FOR AFT COUNT 3 U.R THEN NEXT ;

: DUMP ( b u -- )
  BASE @ >R HEX  16 /
  FOR CR 16 2DUP dm+ -ROT 2 SPACES _TYPE NUF? 0= WHILE
  NEXT ELSE R> DROP THEN DROP  R> BASE ! ;

: .S ( -- ) CR DEPTH FOR AFT R@ PICK . THEN NEXT ."  <tos" ;

: !CSP ( -- ) SP@ CSP ! ;
: ?CSP ( -- ) SP@ CSP @ XOR ABORT" stack depth" ;

: >NAME ( ca -- na, F )
  CURRENT
  BEGIN CELL+ @ ?DUP WHILE 2DUP
    BEGIN @ DUP WHILE 2DUP NAME> XOR
    WHILE 1 CELLS -
    REPEAT      THEN NIP ?DUP
  UNTIL NIP NIP EXIT THEN 0 NIP ;

: .ID ( na -- )
  ?DUP IF COUNT $001F AND TYPE EXIT THEN ." {noName}" ;

: WORDS ( -- )
  CR  CONTEXT @
  BEGIN @ ?DUP
  WHILE DUP SPACE .ID 1 CELLS -  NUF?
  UNTIL DROP THEN ;

.( Hardware reset )

\ version

$100 CONSTANT VER ( -- u )
  \ hi byte = major revision in decimal
  \ lo byte = minor revision in decimal

: hi ( -- )
  !IO \ initialize IO device & sign on
  CR ." eForth v1.0"
  ; COMPILE-ONLY

CREATE 'BOOT  ' hi , \ application vector

: COLD ( -- )
  \ init CPU
  \ init stacks
  \ init user area
  \ init IP
  PRESET  'BOOT @EXECUTE
  QUIT ;