PFE 0.33.70

generated
(C) Guido U. Draheim
guidod@gmx.de

TOOLBELT

- Neil Bawd's common extensions

---

[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
  

immediate code = [p4_defined]

---

[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]

immediate code = [p4_undefined]

---

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.

primitive code = [p4_zero_equal]

---

C+!( n addr -- )  => [FORTH]

Add the low-order byte of _n_ to the byte at _addr_, removing both from the stack.

primitive code = [p4_c_plus_store]

---

EMPTY( -- )  => [FORTH]

Reset the dictionary to a predefined golden state, discarding all definitions and releasing all allocated data space beyond that state.

primitive code = [p4_empty]

---

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
  

primitive code = [p4_vocabulary]

---

BOUNDS( str len -- str+len str )  => [FORTH]

Convert _str len_ to range for DO-loop.

  : BOUNDS  ( str len -- str+len str )  OVER + SWAP ;
  

primitive code = [p4_bounds]

---

OFF( addr -- )  => [FORTH]

Store 0 at _addr_. Defined in f84 as OFF. See antonym ON!.

   : OFF  ( addr -- )  0 SWAP ! ;
  

primitive code = [p4_off_store]

---

ON( addr -- )  => [FORTH]

Store -1 at _addr_. See `OFF`.

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

primitive code = [p4_on_store]

---

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+! ;
  

primitive code = [p4_append]

---

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! ;
  

primitive code = [p4_append_char]

---

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 ;
  

primitive code = [p4_place]

---

STRING,( str len -- )  => [FORTH]

Store a string in data space as a counted string.

  : STRING, HERE  OVER 1+  ALLOT  PLACE ;
  

primitive code = [p4_parse_comma]

---

,"( "<ccc><quote>" -- )  => [FORTH]

Store a quote-delimited string in data space as a counted string.

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

immediate code = [p4_parse_comma_quote]

---

THIRD( x y z -- x y z x )  => [FORTH]

Copy third element on the stack onto top of stack.

  : THIRD   2 PICK ;
  

primitive code = [p4_third]

---

FOURTH( w x y z -- w x y z w )  => [FORTH]

Copy fourth element on the stack onto top of stack.

  : FOURTH  3 PICK ;
  

primitive code = [p4_fourth]

---

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 ;
  

primitive code = [p4_three_dup]

---

3DROP( x y z -- )  => [FORTH]

Drop the top three elements from the stack.

  : 3DROP   DROP 2DROP ;
  

primitive code = [p4_three_drop]

---

2NIP( w x y z -- y z )  => [FORTH]

Drop the third and fourth elements from the stack.

  : 2NIP   2SWAP 2DROP ;
  

primitive code = [p4_two_nip]

---

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"@)

primitive code = [p4_r_tick_fetch]

---

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
  

compiling word = [p4_andif]

---

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
  

compiling word = [p4_orif]

---

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 ;
  

primitive code = [p4_scan]

---

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 ;
  

primitive code = [p4_skip]

---

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 ;
  

primitive code = [p4_back]

---

/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> - ;
  

primitive code = [p4_div_split]

---

IS-WHITE( char -- flag )  => [FORTH]

Test char for white space.

  : IS-WHITE   33 - 0< ;
  

primitive code = [p4_is_white]

---

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 ;
  

primitive code = [p4_trim]

---

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 ;
  

primitive code = [p4_bl_scan]

---

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 ;
 
  

primitive code = [p4_bl_skip]

---

STARTS?( str len pattern len2 -- str len flag )  => [FORTH]

Check start of string.

  : STARTS?   DUP >R  2OVER  R> MIN  COMPARE 0= ;
  

primitive code = [p4_starts_Q]

---

ENDS?( str len pattern len2 -- str len flag )  => [FORTH]

Check end of string.

  : ENDS?   DUP >R  2OVER  DUP R> - /STRING  COMPARE 0= ;
  

primitive code = [p4_ends_Q]

---

IS-DIGIT( char -- flag )  => [FORTH]

Test _char_ for digit [0-9].

  : IS-DIGIT   [CHAR] 0 -  10 U< ;
  

primitive code = [p4_is_digit]

---

IS-ALPHA( char -- flag )  => [FORTH]

Test _char_ for alphabetic [A-Za-z].

  : IS-ALPHA  32 OR  [CHAR] a -  26 U< ;
  

primitive code = [p4_is_alpha]

---

IS-ALNUM( char -- flag )  => [FORTH]

Test _char_ for alphanumeric [A-Za-z0-9].

  : IS-ALNUM  
     DUP IS-ALPHA  ORIF  DUP IS-DIGIT  THEN  NIP ;
  

primitive code = [p4_is_alnum]

---

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.

primitive code = [p4_split_next_line]

---

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 - ;
  

primitive code = [p4_view_next_line]

---

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 ;  
  

primitive code = [p4_next_word]

---

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 ;
  

primitive code = [p4_lexeme]

---

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
  

immediate code = [p4_h_sh]

---

\\( "...<eof>" -- )  => [FORTH]

Ignore the rest of the input stream.

  : \\   BEGIN  -1 PARSE  2DROP  REFILL 0= UNTIL ;
  

primitive code = [p4_backslash_backslash]

---

FILE-CHECK( n -- )  => [FORTH]

Check for file access error.

  \ : FILE-CHECK    ( n -- )  THROW ;
  : FILE-CHECK      ( n -- )  ABORT" File Access Error " ;
  

primitive code = [p4_file_check]

---

MEMORY-CHECK( n -- )  => [FORTH]

Check for memory allocation error.

  \ : MEMORY-CHECK  ( n -- )  THROW ;
  : MEMORY-CHECK    ( n -- )  ABORT" Memory Allocation Error " ;
  

primitive code = [p4_memory_check]

---

++( addr -- )  => [FORTH]

Increment the value at _addr_.

  : ++  ( addr -- )  1 SWAP +! ;
  

primitive code = [p4_plus_plus]

---

@+( addr -- addr' x )  => [FORTH]

Fetch the value _x_ from _addr_, and increment the address by one cell.

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

primitive code = [p4_fetch_plus_plus]

---

!+( addr x -- addr' )  => [FORTH]

Store the value _x_ into _addr_, and increment the address by one cell.

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

primitive code = [p4_store_plus_plus]

---

'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
  

compiling word = [p4_tick_th]

---

(.)  => [FORTH]

(no description)

primitive code = [p4_paren_dot]

---

CELL-( addr -- addr' )  => [FORTH]

Decrement address by one cell

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

primitive code = [p4_cell_minus]

---

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 ;
  

primitive code = [p4_emits]

---

HIWORD( xxyy -- xx )  => [FORTH]

The high half of the value.

  : HIWORD  ( xxyy -- xx )  16 RSHIFT ;
  

primitive code = [p4_hiword]

---

LOWORD( xxyy -- yy )  => [FORTH]

The low half of the value.

  : LOWORD  ( xxyy -- yy )  65535 AND ;
  

primitive code = [p4_loword]

---

REWIND-FILE( file-id -- ior )  => [FORTH]

Rewind the file.

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

primitive code = [p4_rewind_file]