pfe-toolbelt-ext ? TOOLBELT - Neil Bawd's common extensions
[DEFINED] ( "name" -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;[UNDEFINED] ( "name" -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;NOT ( x -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;C+! ( n addr -- ) ?=>? ( | ) ; | ? |
[FORTH]
;EMPTY ( -- ) ?=>? ( | ) ; | ? |
[FORTH]
;VOCABULARY ( "name" -- ) ?=>? ( | ) ; | ? |
[FORTH]
;BOUNDS ( str len -- str+len str ) ?=>? ( | ) ; | ? |
[FORTH]
;OFF ( addr -- ) ?=>? ( | ) ; | ? |
[FORTH]
;ON ( addr -- ) ?=>? ( | ) ; | ? |
[FORTH]
;APPEND ( str len add2 -- ) ?=>? ( | ) ; | ? |
[FORTH]
;APPEND-CHAR ( char addr -- ) ?=>? ( | ) ; | ? |
[FORTH]
;PLACE ( str len addr -- ) ?=>? ( | ) ; | ? |
[FORTH]
;STRING, ( str len -- ) ?=>? ( | ) ; | ? |
[FORTH]
;," ( "<ccc><quote>" -- ) ?=>? ( | ) ; | ? |
[FORTH]
;THIRD ( x y z -- x y z x ) ?=>? ( | ) ; | ? |
[FORTH]
;FOURTH ( w x y z -- w x y z w ) ?=>? ( | ) ; | ? |
[FORTH]
;3DUP ( x y z -- x y z x y z ) ?=>? ( | ) ; | ? |
[FORTH]
;3DROP ( x y z -- ) ?=>? ( | ) ; | ? |
[FORTH]
;2NIP ( w x y z -- y z ) ?=>? ( | ) ; | ? |
[FORTH]
;R'@ ( R: a b -- a R: a b ) ?=>? ( | ) ; | ? |
[FORTH]
;ANDIF ( p ... -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;ORIF ( p ... -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;SCAN ( str len char -- str+i len-i ) ?=>? ( | ) ; | ? |
[FORTH]
;SKIP ( str len char -- str+i len-i ) ?=>? ( | ) ; | ? |
[FORTH]
;BACK ( str len char -- str len-i ) ?=>? ( | ) ; | ? |
[FORTH]
;/SPLIT ( a m a+i m-i -- a+i m-i a i ) ?=>? ( | ) ; | ? |
[FORTH]
;IS-WHITE ( char -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;TRIM ( str len -- str len-i ) ?=>? ( | ) ; | ? |
[FORTH]
;BL-SCAN ( str len -- str+i len-i ) ?=>? ( | ) ; | ? |
[FORTH]
;BL-SKIP ( str len -- str+i len-i ) ?=>? ( | ) ; | ? |
[FORTH]
;STARTS? ( str len pattern len2 -- str len flag ) ?=>? ( | ) ; | ? |
[FORTH]
;ENDS? ( str len pattern len2 -- str len flag ) ?=>? ( | ) ; | ? |
[FORTH]
;IS-DIGIT ( char -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;IS-ALPHA ( char -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;IS-ALNUM ( char -- flag ) ?=>? ( | ) ; | ? |
[FORTH]
;SPLIT-NEXT-LINE ( src . -- src' . str len ) ?=>? ( | ) ; | ? |
[FORTH]
;VIEW-NEXT-LINE ( src . str len -- src . str len str2 len2 ) ?=>? ( | ) ; | ? |
[FORTH]
;NEXT-WORD ( -- str len ) ?=>? ( | ) ; | ? |
[FORTH]
;LEXEME ( "name" -- str len ) ?=>? ( | ) ; | ? |
[FORTH]
;H# ( "hexnumber" -- n ) ?=>? ( | ) ; | ? |
[FORTH]
;\\ ( "...<eof>" -- ) ?=>? ( | ) ; | ? |
[FORTH]
;FILE-CHECK ( n -- ) ?=>? ( | ) ; | ? |
[FORTH]
;MEMORY-CHECK ( n -- ) ?=>? ( | ) ; | ? |
[FORTH]
;++ ( addr -- ) ?=>? ( | ) ; | ? |
[FORTH]
;@+ ( addr -- addr' x ) ?=>? ( | ) ; | ? |
[FORTH]
;!+ ( addr x -- addr' ) ?=>? ( | ) ; | ? |
[FORTH]
;'th ( n "addr" -- &addr[n] ) ?=>? ( | ) ; | ? |
[FORTH]
;(.) ?=>? ( | ) ; | ? |
[FORTH]
;CELL- ( addr -- addr' ) ?=>? ( | ) ; | ? |
[FORTH]
;EMITS ( n char -- ) ?=>? ( | ) ; | ? |
[FORTH]
;HIWORD ( xxyy -- xx ) ?=>? ( | ) ; | ? |
[FORTH]
;LOWORD ( xxyy -- yy ) ?=>? ( | ) ; | ? |
[FORTH]
;REWIND-FILE ( file-id -- ior ) ?=>? ( | ) ; | ? |
[FORTH]
;
[DEFINED] ( "name" -- flag ) => [FORTH]
Search the dictionary for _name_. If _name_ is found, return TRUE; otherwise return FALSE. Immediate for use in definitions.
[DEFINED] word ( -- nfa|0 ) immediate
does check for the word using find (so it does not throw like '
)
and puts it on stack. As it is immediate it does work in compile-mode
too, so it places its argument in the cs-stack then. This is most
useful with a directly following [IF]
clause, so that sth. like
an [IFDEF] word
can be simulated through [DEFINED] word [IF]
: [DEFINED] BL WORD FIND NIP ; IMMEDIATE
[UNDEFINED] ( "name" -- flag ) => [FORTH]
Search the dictionary for _name_. If _name_ is found, return FALSE; otherwise return TRUE. Immediate for use in definitions.
see [DEFINED]
NOT ( x -- flag ) => [FORTH]
Identical to `0=`, used for program clarity to reverse the result of a previous test.
WARNING: PFE's NOT uses bitwise complement INVERT
instead of the logical complement 0=
, so
that loading TOOLBELT will change semantics.
... this difference in semantics has caused dpans94 to
depracate the word. Only if TRUE is -1 it would be identical
but not all words return -1 for true.
C+! ( n addr -- ) => [FORTH]
Add the low-order byte of _n_ to the byte at _addr_, removing both from the stack.
EMPTY ( -- ) => [FORTH]
Reset the dictionary to a predefined golden state, discarding all definitions and releasing all allocated data space beyond that state.
VOCABULARY ( "name" -- ) [FTH] => [FORTH]
create a vocabulary of that name. If the named vocabulary
is called later, it will run ((VOCABULARY))
, thereby
putting it into the current search order.
Special pfe-extensions are accessible via
CASE-SENSITIVE-VOC
and SEARCH-ALSO-VOC
simulate: : VOCABULARY CREATE ALLOT-WORDLIST DOES> ( the ((VOCABULARY)) runtime ) CONTEXT ! ; IMMEDIATE
BOUNDS ( str len -- str+len str ) => [FORTH]
Convert _str len_ to range for DO-loop.
: BOUNDS ( str len -- str+len str ) OVER + SWAP ;
OFF ( addr -- ) => [FORTH]
Store 0 at _addr_. Defined in f84 as OFF
. See antonym ON!
.
: OFF ( addr -- ) 0 SWAP ! ;
ON ( addr -- ) => [FORTH]
Store -1 at _addr_. See `OFF`.
: ON ( addr -- ) -1 SWAP ! ;
APPEND ( str len add2 -- ) => [FORTH]
Append string _str len_ to the counted string at _addr_.
a.k.a. +PLACE
of the PLACE
family
: APPEND 2DUP 2>R COUNT + SWAP MOVE ( ) 2R> C+! ;
APPEND-CHAR ( char addr -- ) => [FORTH]
Append _char_ to the counted string at _addr_.
a.k.a. C+PLACE
of the PLACE
family
: APPEND-CHAR DUP >R COUNT DUP 1+ R> C! + C! ;
PLACE ( str len addr -- ) => [FORTH]
Place the string _str len_ at _addr_, formatting it as a counted string.
: PLACE 2DUP 2>R 1+ SWAP MOVE 2R> C! ; : PLACE 2DUP C! 1+ SWAP CMOVE ;
STRING, ( str len -- ) => [FORTH]
Store a string in data space as a counted string.
: STRING, HERE OVER 1+ ALLOT PLACE ;
," ( "<ccc><quote>" -- ) => [FORTH]
Store a quote-delimited string in data space as a counted string.
: ," [CHAR] " PARSE STRING, ; IMMEDIATE
THIRD ( x y z -- x y z x ) => [FORTH]
Copy third element on the stack onto top of stack.
: THIRD 2 PICK ;
FOURTH ( w x y z -- w x y z w ) => [FORTH]
Copy fourth element on the stack onto top of stack.
: FOURTH 3 PICK ;
3DUP ( x y z -- x y z x y z ) => [FORTH]
Copy top three elements on the stack onto top of stack.
: 3DUP THIRD THIRD THIRD ;
or
: 3DUP 3 PICK 3 PICK 3 PICK ;
3DROP ( x y z -- ) => [FORTH]
Drop the top three elements from the stack.
: 3DROP DROP 2DROP ;
2NIP ( w x y z -- y z ) => [FORTH]
Drop the third and fourth elements from the stack.
: 2NIP 2SWAP 2DROP ;
R'@ ( R: a b -- a R: a b ) [FTH] => [FORTH]
fetch the next-under value from the returnstack.
used to interpret the returnstack to hold two LOCALS|
values.
( R@
/ 2R@
/ R>DROP
/ R"@
)
ANDIF ( p ... -- flag ) => [FORTH]
Given `p ANDIF q THEN`, _q_ will not be performed if _p_ is false.
: ANDIF S" DUP IF DROP " EVALUATE ; IMMEDIATE
ORIF ( p ... -- flag ) => [FORTH]
Given `p ORIF q THEN`, _q_ will not be performed if _p_ is true.
: ORIF S" DUP 0= IF DROP " EVALUATE ; IMMEDIATE
SCAN ( str len char -- str+i len-i ) => [FORTH]
Look for a particular character in the specified string.
: SCAN >R BEGIN DUP WHILE OVER C@ R@ - WHILE 1 /STRING REPEAT THEN R> DROP ;
ie. scan for first occurence of c in string
: SCAN >R BEGIN DUP OVER C@ R@ = 0= OR WHILE 1- SWAP 1- SWAP REPEAT R> DROP ;
SKIP ( str len char -- str+i len-i ) => [FORTH]
Advance past leading characters in the specified string.
: SKIP >R BEGIN DUP WHILE OVER C@ R@ = WHILE 1 /STRING REPEAT THEN R> DROP ;
ie. skip leading characters c
: SKIP >R BEGIN DUP OVER C@ R@ = OR WHILE 1- SWAP 1- SWAP REPEAT R> DROP ;
BACK ( str len char -- str len-i ) => [FORTH]
Look for a particular character in the string from the back toward the front.
: BACK >R BEGIN DUP WHILE 1- 2DUP + C@ R@ = UNTIL 1+ THEN R> DROP ;
/SPLIT ( a m a+i m-i -- a+i m-i a i ) => [FORTH]
Split a character string _a m_ at place given by _a+i m-i_. Called "cut-split" because "slash-split" is a tongue twister.
: /SPLIT DUP >R 2SWAP R> - ;
IS-WHITE ( char -- flag ) => [FORTH]
Test char for white space.
: IS-WHITE 33 - 0< ;
TRIM ( str len -- str len-i ) => [FORTH]
Trim white space from end of string.
: TRIM BEGIN DUP WHILE 1- 2DUP + C@ IS-WHITE NOT UNTIL 1+ THEN ;
BL-SCAN ( str len -- str+i len-i ) => [FORTH]
Look for white space from start of string
: BL-SCAN BEGIN DUP WHILE OVER C@ IS-WHITE NOT WHILE 1 /STRING REPEAT THEN ;
BL-SKIP ( str len -- str+i len-i ) => [FORTH]
Skip over white space at start of string.
: BL-SKIP BEGIN DUP WHILE OVER C@ IS-WHITE WHILE 1 /STRING REPEAT THEN ;
STARTS? ( str len pattern len2 -- str len flag ) => [FORTH]
Check start of string.
: STARTS? DUP >R 2OVER R> MIN COMPARE 0= ;
ENDS? ( str len pattern len2 -- str len flag ) => [FORTH]
Check end of string.
: ENDS? DUP >R 2OVER DUP R> - /STRING COMPARE 0= ;
IS-DIGIT ( char -- flag ) => [FORTH]
Test _char_ for digit [0-9].
: IS-DIGIT [CHAR] 0 - 10 U< ;
IS-ALPHA ( char -- flag ) => [FORTH]
Test _char_ for alphabetic [A-Za-z].
: IS-ALPHA 32 OR [CHAR] a - 26 U< ;
IS-ALNUM ( char -- flag ) => [FORTH]
Test _char_ for alphanumeric [A-Za-z0-9].
: IS-ALNUM DUP IS-ALPHA ORIF DUP IS-DIGIT THEN NIP ;
SPLIT-NEXT-LINE ( src . -- src' . str len ) => [FORTH]
Split the next line from the string.
: SPLIT-NEXT-LINE 2DUP #EOL-CHAR SCAN DUP >R 1 /STRING 2SWAP R> - ;
FIXME: inform Neil Bawd that this is probably not what he wanted. replace /STRING with /SPLIT here.
VIEW-NEXT-LINE ( src . str len -- src . str len str2 len2 ) => [FORTH]
Copy next line above current line.
: VIEW-NEXT-LINE 2OVER 2DUP #EOL-CHAR SCAN NIP - ;
NEXT-WORD ( -- str len ) => [FORTH]
Get the next word across line breaks as a character string. _len_ will be 0 at end of file.
: NEXT-WORD BEGIN BL WORD COUNT ( str len ) DUP IF EXIT THEN REFILL WHILE 2DROP ( ) REPEAT ;
LEXEME ( "name" -- str len ) => [FORTH]
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.
: LEXEME BL WORD ( addr) DUP C@ 1 = IF CHAR+ C@ WORD THEN COUNT ;
H# ( "hexnumber" -- n ) => [FORTH]
Get the next word in the input stream as a hex single-number literal. (Adopted from Open Firmware.)
: H# ( "hexnumber" -- n ) \ Simplified for easy porting. 0 0 BL WORD COUNT BASE @ >R HEX >NUMBER R> BASE ! ABORT" Not Hex " 2DROP ( n) STATE @ IF POSTPONE LITERAL THEN ; IMMEDIATE
\\ ( "...<eof>" -- ) => [FORTH]
Ignore the rest of the input stream.
: \\ BEGIN -1 PARSE 2DROP REFILL 0= UNTIL ;
FILE-CHECK ( n -- ) => [FORTH]
Check for file access error.
\ : FILE-CHECK ( n -- ) THROW ; : FILE-CHECK ( n -- ) ABORT" File Access Error " ;
MEMORY-CHECK ( n -- ) => [FORTH]
Check for memory allocation error.
\ : MEMORY-CHECK ( n -- ) THROW ; : MEMORY-CHECK ( n -- ) ABORT" Memory Allocation Error " ;
++ ( addr -- ) => [FORTH]
Increment the value at _addr_.
: ++ ( addr -- ) 1 SWAP +! ;
@+ ( addr -- addr' x ) => [FORTH]
Fetch the value _x_ from _addr_, and increment the address by one cell.
: @+ ( addr -- addr' x ) DUP CELL+ SWAP @ ;
!+ ( addr x -- addr' ) => [FORTH]
Store the value _x_ into _addr_, and increment the address by one cell.
: !+ ( addr x -- addr' ) OVER ! CELL+ ;
'th ( n "addr" -- &addr[n] ) => [FORTH]
Address `n CELLS addr +`.
: 'th ( n "addr" -- &addr[n] ) S" 2 LSHIFT " EVALUATE BL WORD COUNT EVALUATE S" + " EVALUATE ; IMMEDIATE
(.) - no description, sorry
CELL- ( addr -- addr' ) => [FORTH]
Decrement address by one cell
: CELL- ( addr -- addr' ) CELL - ;
EMITS ( n char -- ) => [FORTH]
Emit _char_ _n_ times.
: EMITS ( n char -- ) SWAP 0 ?DO DUP EMIT LOOP DROP ;
also compare
: SPACES BL EMITS ; : SPACE BL EMIT ;
HIWORD ( xxyy -- xx ) => [FORTH]
The high half of the value.
: HIWORD ( xxyy -- xx ) 16 RSHIFT ;
LOWORD ( xxyy -- yy ) => [FORTH]
The low half of the value.
: LOWORD ( xxyy -- yy ) 65535 AND ;
REWIND-FILE ( file-id -- ior ) => [FORTH]
Rewind the file.
: REWIND-FILE ( file-id -- ior ) 0 0 ROT REPOSITION-FILE ;