Tool Belt for PowerMacForth

Wil Baden 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.

For potential definitions, see FPH Common Usage.

Program Text 2 \ : NOT ( x -- flag ) S" 0= " EVALUATE ; IMMEDIATE : [DEFINED] ( "name" -- flag ) BL WORD FIND NIP 0<> ; IMMEDIATE : [UNDEFINED] ( "name" -- flag ) BL WORD FIND NIP 0= ; IMMEDIATE \ : C+! ( n addr -- ) DUP >R C@ + R> C! ; CODE C+! ( n addr -- ) rx 0 rdsp lwz, ry 0 rtos lbz, ry ry rx add, ry 0 rtos stb, rtos 4 rdsp lwz, rdsp rdsp 8 addi, NEXT, END-CODE : EMPTY ( -- ) S" ANEW --- DECIMAL ONLY FORTH DEFINITIONS " EVALUATE ; IMMEDIATE [undefined] mfvocabulary [if] : mfvocabulary vocabulary ; [then] : VOCABULARY 400 VOCABULARY ;

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 [undefined] mfappend [if] : mfappend append ; [then] : APPEND ( addr1 u addr2 -- ) 2DUP 2>R COUNT CHARS + SWAP CHARS MOVE ( ) 2R> C+! ; : APPEND-CHAR ( char addr -- ) DUP >R COUNT DUP 1+ R> C! + C! ; : PLACE ( str len addr -- ) 2DUP 2>R CHAR+ SWAP CHARS MOVE 2R> C! ; : STRING, ( str len -- ) HERE OVER 1+ CHARS 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 \ : THIRD ( x y z -- x y z x ) 2 PICK ; CODE THIRD ( x y z -- x y z x ) rtos -4 rdsp stwu, rtos 8 rdsp lwz, NEXT, End-Code \ : FOURTH ( w x y z -- w x y z w ) 3 PICK ; CODE FOURTH ( x y z w -- x y z w x ) rtos -4 rdsp stwu, rtos 12 rdsp lwz, NEXT, End-Code : 3DUP ( x y z -- x y z x y z ) THIRD THIRD THIRD ; \ : 3DROP ( x y z -- ) DROP 2DROP ; CODE 3DROP ( x y z -- ) rtos 8 rdsp lwz, rdsp 12 addi, NEXT, End-Code \ : 2NIP ( w x y z -- y z ) 2SWAP 2DROP ; CODE 2NIP ( w z y z -- y z ) rx 0 rdsp lwz, rdsp 8 addi, rx 0 rdsp stwu, NEXT, End-Code \ : R'@ S" 2R@ DROP " EVALUATE ; IMMEDIATE CODE R'@ ( -- x )( R: x y -- same ) rtos -4 rdsp stwu, rtos 4 rrsp lwz, NEXT, End-Code

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 [undefined] mfscan [if] : mfscan scan ; [then] \ : SCAN ( str len char -- str+i len-i ) \ >R BEGIN DUP WHILE OVER C@ R@ - \ WHILE 1 /STRING REPEAT THEN \ R> DROP ; CODE SCAN ( str len char -- str+i len-i ) r31 -4 rrsp stwu, r31 rtos move, poptos, ( str len) rx 0 rdsp lwz, rx -1 addi, rtos 1 addi, begin, rtos -1 addic., ry 1 rx lbzu, gt while, ry r31 cmp, eq until, rx 0 rdsp stw, r31 0 rrsp stw, rrsp 4 addi, NEXT, END-CODE \ : SKIP ( str len char -- str+i len-i ) \ >R BEGIN DUP WHILE OVER C@ R@ = \ WHILE 1 /STRING REPEAT THEN \ R> DROP ; CODE SKIP ( str len char -- str+i len-i ) r31 -4 rrsp stwu, r31 rtos move, poptos, ( str len) rx 0 rdsp lwz, rx -1 addi, rtos 1 addi, begin, rtos -1 addic., ry 1 rx lbzu, gt while, ry r31 cmp, ne until, rx 0 rdsp stw, r31 0 rrsp stw, rrsp 4 addi, NEXT, END-CODE : 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 ; CODE BL-SCAN ( str len -- str+i len-i ) rx 0 rdsp lwz, rx -1 addi, rtos 1 addi, begin, rtos -1 addic., ry 1 rx lbzu, gt while, ry 32 cmpi, le until, rx 0 rdsp stw, NEXT, END-CODE \ : BL-SKIP ( str len -- str+i len-i ) \ BEGIN DUP WHILE OVER C@ IS-WHITE \ WHILE 1 /STRING REPEAT THEN ; CODE BL-SKIP ( str len -- str+i len-i ) rx 0 rdsp lwz, rx -1 addi, rtos 1 addi, begin, rtos -1 addic., ry 1 rx lbzu, gt while, ry 32 cmpi, gt until, rx 0 rdsp stw, NEXT, END-CODE

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 ; : \\ PRIOR.STREAM ;

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 \ : ++ ( addr -- ) 1 SWAP +! ; CODE ++ ( a -- ) rx 0 rtos lwz, rx 1 addi, rx 0 rtos stw, poptos, NEXT, End-Code \ : @+ ( addr -- addr' x ) DUP CELL+ SWAP @ ; CODE @+ ( a -- a+cell x ) rx rtos 4 addi, rx -4 rdsp stwu, rtos 0 rtos lwz, NEXT, End-Code \ : !+ ( addr x -- addr' ) OVER ! CELL+ ; CODE !+ ( a x -- a+cell ) rx 0 rdsp lwz, rtos 0 rx stw, rtos rx 4 addi, rdsp 4 addi, NEXT, End-Code

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 ;

MOD ( dividend divisor -- remainder ): Redefinition of MOD.

Program Text 17 CODE MOD ( dividend divisor -- remainder ) rtos 0 cmpi, rx 0 rdsp lwz, rdsp rdsp 4 addi, ne if, ry rx rtos divw, ry ry rtos mullw, rtos ry rx subf, then, NEXT, End-Code

Go back to Neil Bawd's home page.