Tool Belt for MPE ProForth VFX

Reviewed by Stephen Pelc 2000-08-14

These are common tools used in several source files. They are all given here so you can avoid duplicate definitions. Comment out those that you already have or are enhancing. Many of them should be CODE definitions.

0 [IF] is the convention used for commentary, so comment out with \ or FALSE [IF] or [VOID] [IF].

[VOID] is an immediate constant of FALSE. It is defined first so it can be used to comment out sections of code.

Definitions in Standard Forth by Wil Baden. Any similarity with anyone else's code is coincidental, historical, or inevitable.

!+   #BACKSPACE-CHAR   #CHARS/LINE   #EOL-CHAR   #TAB-CHAR   'th   (.)   ++   ,"   -CELL   /SPLIT   2NIP   3DROP   3DUP   @+   ANDIF   APPEND   APPEND-CHAR   BACK   BL-SCAN   BL-SKIP   BOUNDS   C+!   CELL   CELL-   EMITS   EMPTY   ENDS?   FILE-CHECK   FOURTH   H#   HIWORD   IS-ALNUM   IS-ALPHA   IS-DIGIT   IS-WHITE   LEXEME   LOWORD   MAX-N   MEMORY-CHECK   NEXT-WORD   NOT   OFF   ON   ORIF   OUT   PLACE   R'@   REWIND-FILE   SCAN   SIGN-BIT   SKIP   SPLIT-NEXT-LINE   STARTS?   STRING,   TEMP   THIRD   TRIM   VIEW-NEXT-LINE   VOCABULARY   [DEFINED]   [UNDEFINED]   [VOID]   \\  
 
TEXT

[VOID]              ( -- flag )
Immediate FALSE. Used to comment out sections of code. IMMEDIATE so it can be inside definitions.
Program Text 1
FALSE CONSTANT [VOID] IMMEDIATE


Forth Programmer's Handbook, Conklin and Rather

NOT                 ( x -- flag )
Identical to 0=, used for program clarity to reverse the result of a previous test.
[DEFINED]           ( "name" -- flag )
Search the dictionary for name. If name is found, return TRUE; otherwise return FALSE. Immediate for use in definitions.
[UNDEFINED]         ( "name" -- flag )
Search the dictionary for name. If name is found, return FALSE; otherwise return TRUE. Immediate for use in definitions.
C+!                 ( n addr -- )
Add the low-order byte of n to the byte at addr, removing both from the stack.
EMPTY               ( -- )
Reset the dictionary to a predefined golden state, discarding all definitions and releasing all allocated data space beyond that state.
VOCABULARY          ( "name" -- )
Create a word list name. Subsequent execution of name replaces the first word list in the search order with name. When name is made the compilation word list, new definitions will be added to name's list.
Program Text 2
\  NOT   [DEFINED]   [UNDEFINED]   C+!   EMPTY   VOCABULARY

: not       \ x -- flag ; same as 0=
  0=
;

: empty     \ -- ; same as COLD
  cold
;



Common Use

BOUNDS              ( str len -- str+len str )
Convert str len to range for DO-loop.
OFF                 ( addr -- )
Store 0 at addr. See ON.
ON                  ( addr -- )
Store -1 at addr. See OFF.
Program Text 3
\ : BOUNDS  ( str len -- str+len str )  OVER + SWAP ;

\ : OFF  ( addr -- )  0 SWAP ! ;

\ : ON  ( addr -- )  -1 SWAP ! ;


APPEND              ( str len add2 -- )
Append string str len to the counted string at addr. AKA +PLACE.
APPEND-CHAR         ( char addr -- )
Append char to the counted string at addr.
PLACE               ( str len addr -- )
Place the string str len at addr, formatting it as a counted string.
STRING,             ( str len -- )
Store a string in data space as a counted string.
,"                  ( "<ccc><quote>" -- )
Store a quote-delimited string in data space as a counted string.
Program Text 4
: APPEND              ( addr1 u addr2 -- )
    2DUP 2>R  COUNT +  SWAP MOVE ( ) 2R> C+! ;

: APPEND-CHAR         ( char addr -- )
    DUP >R  COUNT  DUP 1+ R> C!  +  C! ;

\ : PLACE               ( str len addr -- )
\     2DUP 2>R  1+  SWAP  MOVE  2R> C! ;

: STRING,             ( str len -- )
    HERE  OVER 1+  ALLOT  PLACE ;

: ," [CHAR] " PARSE  STRING, ; IMMEDIATE


Stack Handling

THIRD               ( x y z -- x y z x )
Copy third element on the stack onto top of stack.
FOURTH              ( w x y z -- w x y z w )
Copy fourth element on the stack onto top of stack.
3DUP                ( x y z -- x y z x y z )
Copy top three elements on the stack onto top of stack.
3DROP               ( x y z -- )
Drop the top three elements from the stack.
2NIP                ( w x y z -- y z )
Drop the third and fourth elements from the stack.
R'@                 ( -- x )( R: x y -- x y )
The second element on the return stack.

These should all be CODE definitions.

Program Text 5
\ The ProForth VFX optimiser will eat all these. R'@ can be coded
\ but this will only save one instruction.

: THIRD  ( x y z -- x y z x )  2 PICK ;

: FOURTH ( w x y z -- w x y z w )  3 PICK ;

\ : 3DUP  ( x y z -- x y z x y z )  THIRD THIRD THIRD ;

\ : 3DROP ( x y z -- )  DROP 2DROP ;

: 2NIP  ( w x y z -- y z )  2SWAP 2DROP ;

: R'@   S" 2R@ DROP " EVALUATE ; IMMEDIATE



Short-Circuit Conditional

ANDIF               ( p ... -- flag )
Given p ANDIF q THEN, q will not be performed if p is false.
ORIF                ( p ... -- flag )
Given p ORIF q THEN, q will not be performed if p is true.
Program Text 6
: ANDIF  S" DUP IF DROP " EVALUATE ; IMMEDIATE

: ORIF   S" DUP 0= IF DROP " EVALUATE ; IMMEDIATE


String Handling

SCAN                ( str len char -- str+i len-i )
Look for a particular character in the specified string.
SKIP                ( str len char -- str+i len-i )
Advance past leading characters in the specified string.
BACK                ( str len char -- str len-i )
Look for a particular character in the string from the back toward the front.
/SPLIT              ( a m a+i m-i -- a+i m-i a i )
Split a character string a m at place given by a+i m-i. Called "cut-split" because "slash-split" is a tongue twister.
Program Text 7
0 [if]
: SCAN           ( str len char -- str+i len-i )
    >R  BEGIN  DUP WHILE  OVER C@ R@ -
        WHILE  1 /STRING  REPEAT THEN
    R> DROP ;

: SKIP           ( str len char -- str+i len-i )
   >R  BEGIN  DUP WHILE  OVER C@ R@ =
        WHILE  1 /STRING  REPEAT THEN
    R> DROP ;
[then]

: BACK           ( str len char -- str len-i )
    >R  BEGIN  DUP WHILE
        1-  2DUP + C@  R@ =
    UNTIL 1+ THEN
    R> DROP ;

: /SPLIT  ( a m b n -- b n a m-n )  DUP >R  2SWAP  R> - ;


IS-WHITE            ( char -- flag )
Test char for white space.
TRIM                ( str len -- str len-i )
Trim white space from end of string.
BL-SCAN             ( str len -- str+i len-i )
Look for white space from start of string
BL-SKIP             ( str len -- str+i len-i )
Skip over white space at start of string.
Program Text 8
: IS-WHITE       ( char -- flag )  33 - 0< ;

: TRIM           ( str len -- str len-i )
    BEGIN  DUP WHILE
        1-  2DUP + C@ IS-WHITE NOT
    UNTIL 1+ THEN ;

: BL-SCAN        ( str len -- str+i len-i )
    BEGIN  DUP WHILE  OVER C@ IS-WHITE NOT
    WHILE  1 /STRING  REPEAT THEN ;

: BL-SKIP        ( str len -- str+i len-i )
    BEGIN  DUP WHILE  OVER C@ IS-WHITE
    WHILE  1 /STRING  REPEAT THEN ;


STARTS?             ( str len pattern len2 -- str len flag )
Check start of string.
ENDS?               ( str len pattern len2 -- str len flag )
Check end of string.
Program Text 9
: STARTS?  ( str len pattern len2 -- str len flag )
    DUP >R  2OVER  R> MIN  COMPARE 0= ;

: ENDS?  ( str len pattern len2 -- str len flag )
    DUP >R  2OVER  DUP R> - /STRING  COMPARE 0= ;


Character Tests

IS-DIGIT            ( char -- flag )
Test char for digit [0-9].
IS-ALPHA            ( char -- flag )
Test char for alphabetic [A-Za-z].
IS-ALNUM            ( char -- flag )
Test char for alphanumeric [A-Za-z0-9].
Program Text 10
: IS-DIGIT  ( char -- flag )  [CHAR] 0 -  10 U< ;
: IS-ALPHA  ( char -- flag )  32 OR  [CHAR] a -  26 U< ;
: IS-ALNUM  ( char -- flag )
    DUP IS-ALPHA  ORIF  DUP IS-DIGIT  THEN  NIP ;


Common Constants

#BACKSPACE-CHAR     ( -- char )
Backspace character.
#CHARS/LINE         ( -- n )
Preferred width of line in source files. Suit yourself.
#EOL-CHAR           ( -- char )
End-of-line character. 13 for Mac and DOS, 10 for Unix.
#TAB-CHAR           ( -- char )
Tab character.
MAX-N               ( -- n )
Largest usable signed integer.
SIGN-BIT            ( -- n )
1-bit mask for the sign bit.
CELL                ( -- n )
Address units (i.e. bytes) in a cell.
-CELL               ( -- n )
Negative of address units in a cell.
Program Text 11
 8 CONSTANT #BACKSPACE-CHAR
62 VALUE    #CHARS/LINE
13 CONSTANT #EOL-CHAR
 9 CONSTANT #TAB-CHAR

TRUE 1 RSHIFT        CONSTANT MAX-N
TRUE 1 RSHIFT INVERT CONSTANT SIGN-BIT

 1 CELLS CONSTANT CELL
-1 CELLS CONSTANT -CELL


Filter Handling

SPLIT-NEXT-LINE     ( src . -- src' . str len )
Split the next line from the string.
VIEW-NEXT-LINE     ( src . str len -- src . str len str2 len2 )
Copy next line above current line.
OUT                 ( -- addr )
Promiscuous variable.
TEMP                ( -- addr )
Promiscuous variable.
Program Text 12
: SPLIT-NEXT-LINE   ( src . -- src' . str len )
    2DUP #EOL-CHAR SCAN  DUP >R  1 /STRING  2SWAP R> - ;

: VIEW-NEXT-LINE  ( src . str len -- src . str len str2 len2 )
    2OVER 2DUP #EOL-CHAR SCAN NIP - ;

VARIABLE OUT
VARIABLE TEMP


Input Stream

NEXT-WORD           ( -- str len )
Get the next word across line breaks as a character string. len will be 0 at end of file.
LEXEME              ( "name" -- str len )
Get the next word on the line as a character string. If it's a single character, use it as the delimiter to get a phrase.
H#                  ( "hexnumber" -- n )
Get the next word in the input stream as a hex single-number literal. (Adopted from Open Firmware.)
\\                  ( "...<eof>" -- )
Ignore the rest of the input stream.
Program Text 13
: NEXT-WORD           ( -- str len )
    BEGIN   BL WORD COUNT      ( str len)
        DUP IF EXIT THEN
        REFILL
    WHILE  2DROP ( ) REPEAT ;  ( str len)

: LEXEME              ( "name" -- str len )
    BL WORD ( addr) DUP C@ 1 =
        IF  CHAR+ C@ WORD  THEN
    COUNT ;

: H#  ( "hexnumber" -- n )  \  Simplified for easy porting.
    0 0 BL WORD COUNT                   ( str len)
    BASE @ >R  HEX  >NUMBER  R> BASE !
        ABORT" Not Hex " 2DROP          ( n)
    STATE @ IF  POSTPONE LITERAL  THEN
    ; IMMEDIATE

: \\              ( "...<eof>" -- )
    BEGIN  -1 PARSE  2DROP  REFILL 0= UNTIL ;


Error Checking

FILE-CHECK          ( n -- )
Check for file access error.
MEMORY-CHECK        ( n -- )
Check for memory allocation error.

These words should be tailored for your system.

Program Text 14
\ : FILE-CHECK    ( n -- )  THROW ;
\ : MEMORY-CHECK  ( n -- )  THROW ;

: FILE-CHECK      ( n -- )  ABORT" File Access Error " ;
: MEMORY-CHECK    ( n -- )  ABORT" Memory Allocation Error " ;

\ : FILE-CHECK    ( n -- )  SHOWERROR ;
\ : MEMORY-CHECK  ( n -- )  SHOWERROR ;



Generally Useful

++                  ( addr -- )
Increment the value at addr.
@+                  ( addr -- addr' x )
Fetch the value x from addr, and increment the address by one cell.
!+                  ( addr x -- addr' )
Store the value x into addr, and increment the address by one cell.
Program Text 15
\ The ProForth VFX optimiser will eat these
: ++  ( addr -- )  1 SWAP +! ;

: @+  ( addr -- addr' x )  DUP CELL+ SWAP  @ ;

: !+  ( addr x -- addr' )  OVER !  CELL+ ;


Miscellaneous

'th                 ( n "addr" -- &addr[n] )
Address n CELLS addr +.
(.)                 ( n -- addr u )
Convert n to characters, without punctuation, as for . (dot), returning the address and length of the resulting string.
CELL-               ( addr -- addr' )
Decrement address by one cell
EMITS               ( n char -- )
Emit char n times.
HIWORD              ( xxyy -- xx )
The high half of the value.
LOWORD              ( xxyy -- yy )
The low half of the value.
REWIND-FILE         ( file-id -- ior )
Rewind the file.
Program Text 16
: 'th     ( n "addr" -- &addr[n] )
    S" 2 LSHIFT " EVALUATE
    BL WORD COUNT EVALUATE
    S" + " EVALUATE
    ; IMMEDIATE

: (.)  ( n -- addr u )  DUP ABS 0 <# #S ROT SIGN #> ;

\ : CELL-  ( addr -- addr' )  CELL - ;

: EMITS             ( n char -- )
    SWAP 0 ?DO  DUP EMIT  LOOP DROP ;

\ : HIWORD  ( xxyy -- xx )  16 RSHIFT ;
\ : LOWORD  ( xxyy -- yy )  65535 AND ;

: REWIND-FILE       ( file-id -- ior )
    0 0 ROT REPOSITION-FILE ;


\ ****************************************************
\ ProForth VFX extensions for other non-ANS words used
\ ****************************************************

also sourcefiles  context @  previous
  constant widSources

: requires  \ " filename" -- ; as INCLUDE if file not already compiled
  >in @
  get-token count widSources search-wordlist if
    drop
  else
    >in !  include
  endif
;

: <plaintext>   \ --
;

-short-branches \ prevent optimiser from complaining



Go back to Neil Bawd's home page.