Reviewed by Marcel Hendrix 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]
\
FALSE [IF]
[VOID] [IF]
[VOID]
Definitions in Standard Forth by Wil Baden. Any similarity with anyone else's code is coincidental, historical, or inevitable.
[VOID]
( -- flag )
FALSE CONSTANT [VOID] IMMEDIATE
NOT
( x -- flag )
0=
[DEFINED]
( "name" -- flag )
[UNDEFINED]
( "name" -- flag )
C+!
( n addr -- )
EMPTY
( -- )
VOCABULARY
( "name" -- )
\ NOT [DEFINED] [UNDEFINED] C+! EMPTY VOCABULARY
BOUNDS
( str len -- str+len str )
OFF
( addr -- )
ON
ON
( addr -- )
OFF
\ : BOUNDS ( str len -- str+len str ) OVER + SWAP ; \ : OFF ( addr -- ) 0 SWAP ! ; \ : ON ( addr -- ) -1 SWAP ! ;
APPEND
( str len add2 -- )
+PLACE
APPEND-CHAR
( char addr -- )
PLACE
( str len addr -- )
STRING,
( str len -- )
,"
( "<ccc><quote>" -- )
: APPEND PLACE+ ; ( addr1 u addr2 -- ) : APPEND-CHAR ( char addr -- ) DUP >R COUNT DUP 1+ R> C! + C! ; : PLACE PACK DROP ; ( str len addr -- ) : STRING, ( str len -- ) HERE OVER 1+ ALLOT PLACE ; \ : ," [CHAR] " PARSE STRING, ; IMMEDIATE
THIRD
( x y z -- x y z x )
FOURTH
( w x y z -- w x y z w )
3DUP
( x y z -- x y z x y z )
3DROP
( x y z -- )
2NIP
( w x y z -- y z )
R'@
( -- x )( R: x y -- x y )
These should all be CODE definitions.
Program Text 5: 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
ANDIF
( p ... -- flag )
p ANDIF q THEN
ORIF
( p ... -- flag )
p ORIF q THEN
: ANDIF S" DUP IF DROP " EVALUATE ; IMMEDIATE : ORIF S" DUP 0= IF DROP " EVALUATE ; IMMEDIATE
SCAN
( str len char -- str+i len-i )
SKIP
( str len char -- str+i len-i )
BACK
( str len char -- str len-i )
/SPLIT
( a m a+i m-i -- a+i m-i a i )
\ : 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 ; : BACK ( str len char -- str len-i ) >R BEGIN DUP WHILE 1- 2DUP + C@ R@ = UNTIL 1+ THEN -R ; : /SPLIT ( a m b n -- b n a m-n ) DUP >R 2SWAP R> - ;
IS-WHITE
( char -- flag )
TRIM
( str len -- str len-i )
BL-SCAN
( str len -- str+i len-i )
BL-SKIP
( str len -- str+i len-i )
: 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 )
ENDS?
( str len pattern len2 -- str len flag )
: 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= ;
IS-DIGIT
( char -- flag )
IS-ALPHA
( char -- flag )
IS-ALNUM
( char -- flag )
: 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 ;
#BACKSPACE-CHAR
( -- char )
#CHARS/LINE
( -- n )
#EOL-CHAR
( -- char )
#TAB-CHAR
( -- char )
MAX-N
( -- n )
SIGN-BIT
( -- n )
CELL
( -- n )
-CELL
( -- n )
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
SPLIT-NEXT-LINE
( src . -- src' . str len )
VIEW-NEXT-LINE
( src . str len -- src . str len str2 len2 )
OUT
( -- addr )
TEMP
( -- addr )
: 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
NEXT-WORD
( -- str len )
LEXEME
( "name" -- str len )
H#
( "hexnumber" -- n )
\\
( "...<eof>" -- )
: NEXT-WORD ( -- str len ) BEGIN BL <WORD> ( str len) DUP IF EXIT THEN REFILL WHILE 2DROP ( ) REPEAT ; ( str len) : LEXEME ( "name" -- str len ) BL <WORD> DUP 1 = IF DROP C@ <WORD> THEN ; : H# ( "hexnumber" -- n ) \ Simplified for easy porting. 0 0 BL <WORD> ( 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 ;
FILE-CHECK
( n -- )
MEMORY-CHECK
( n -- )
These words should be tailored for your system.
Program Text 14: FILE-CHECK ( n -- ) ?FILE ; : MEMORY-CHECK ( n -- ) ?ALLOCATE ;
++
( addr -- )
@+
( addr -- addr' x )
!+
( addr x -- addr' )
: ++ ( addr -- ) 1 SWAP +! ; \ : @+ ( addr -- addr' x ) DUP CELL+ SWAP @ ; \ : !+ ( addr x -- addr' ) OVER ! CELL+ ;
'th
( n "addr" -- &addr[n] )
n CELLS addr +
(.)
( n -- addr u )
.
CELL-
( addr -- addr' )
EMITS
( n char -- )
HIWORD
( xxyy -- xx )
LOWORD
( xxyy -- yy )
REWIND-FILE
( file-id -- ior )
: 'th ( n "addr" -- &addr[n] ) EVAL" []CELL " ; 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 ;