toolbelt

"TOOLBELT - Neil Bawd's common extensions"

toolbelt /* INTO ("EXTENSIONS", 0 ) ? */ [VOID]

[] no special info, see general notes

FORTH/DEF toolbelt immediate constant

* [DEFINED] ( "name" -- flag )

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

FORTH/DEF toolbelt immediate primitive

* [UNDEFINED] ( "name" -- flag )

Search the dictionary for _name_. If _name_ is found,
return FALSE; otherwise return TRUE. Immediate for use in
definitions.

see [DEFINED]

FORTH/DEF toolbelt immediate primitive

* NOT ( x -- flag )

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.

FORTH/DEF toolbelt ordinary primitive

* C+! ( n addr -- )

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

FORTH/DEF toolbelt ordinary primitive

* EMPTY ( -- )

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

FORTH/DEF toolbelt ordinary primitive

* VOCABULARY ( 'name' -- )

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

FORTH/DEF toolbelt ordinary primitive

* BOUNDS ( str len -- str+len str )

Convert _str len_ to range for DO-loop.

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

FORTH/DEF toolbelt ordinary primitive

* OFF ( addr -- )

Store 0 at _addr_. See `ON`.

  : OFF  ( addr -- )  0 SWAP ! ;

FORTH/DEF toolbelt ordinary primitive

* ON ( addr -- )

Store -1 at _addr_. See `OFF`.

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

FORTH/DEF toolbelt ordinary primitive

* APPEND ( str len add2 -- )

Append string _str len_ to the counted string at _addr_.
AKA `+PLACE`.

 : APPEND   2DUP 2>R  COUNT +  SWAP MOVE ( ) 2R> C+! ;

FORTH/DEF toolbelt ordinary primitive

* APPEND-CHAR ( char addr -- )

Append _char_ to the counted string at _addr_.

 : APPEND-CHAR   DUP >R  COUNT  DUP 1+ R> C!  +  C! ;

FORTH/DEF toolbelt ordinary primitive

* PLACE ( str len addr -- )

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 ;

FORTH/DEF toolbelt ordinary primitive

* STRING, ( str len -- )

Store a string in data space as a counted string.

 : STRING, HERE  OVER 1+  ALLOT  PLACE ;

FORTH/DEF toolbelt ordinary primitive

,"

[] no special info, see general notes

FORTH/DEF toolbelt immediate primitive

* THIRD ( x y z -- x y z x )

Copy third element on the stack onto top of stack.

 : THIRD   2 PICK ;

FORTH/DEF toolbelt ordinary primitive

* FOURTH ( w x y z -- w x y z w )

Copy fourth element on the stack onto top of stack.

 : FOURTH  3 PICK ;

FORTH/DEF toolbelt ordinary primitive

* 3DUP ( x y z -- x y z x y z )

Copy top three elements on the stack onto top of stack.

 : 3DUP   THIRD THIRD THIRD ;

 : 3DUP  3 PICK 3 PICK 3 PICK ;

FORTH/DEF toolbelt ordinary primitive

* 3DROP ( x y z -- )

Drop the top three elements from the stack.

 : 3DROP   DROP 2DROP ;

FORTH/DEF toolbelt ordinary primitive

* 2NIP ( w x y z -- y z )

Drop the third and fourth elements from the stack.

 : 2NIP   2SWAP 2DROP ;

FORTH/DEF toolbelt ordinary primitive

* R'@ ( -- x )( R: x y -- x y )

The second element on the return stack.

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

FORTH/DEF toolbelt ordinary primitive

* ANDIF ( p ... -- flag )

Given `p ANDIF q THEN`, _q_ will not be performed if
_p_ is false.

 : ANDIF  S" DUP IF DROP " EVALUATE ; IMMEDIATE

FORTH/DEF toolbelt compiling primitive

* ORIF ( p ... -- flag )

Given `p ORIF q THEN`, _q_ will not be performed if
_p_ is true.

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

FORTH/DEF toolbelt compiling primitive

* SCAN ( str len char -- str+i len-i )

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 ;

FORTH/DEF toolbelt ordinary primitive

* SKIP ( str len char -- str+i len-i )

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 ;

FORTH/DEF toolbelt ordinary primitive

* BACK ( str len char -- str len-i )

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 ;

FORTH/DEF toolbelt ordinary primitive

* /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.

 : /SPLIT  DUP >R  2SWAP  R> - ;

FORTH/DEF toolbelt ordinary primitive

* IS-WHITE ( char -- flag )

Test char for white space.

 : IS-WHITE   33 - 0< ;

FORTH/DEF toolbelt ordinary primitive

* TRIM ( str len -- str len-i )

Trim white space from end of string.

 : TRIM    
    BEGIN  DUP WHILE
        1-  2DUP + C@ IS-WHITE NOT
    UNTIL 1+ THEN ;

FORTH/DEF toolbelt ordinary primitive

* BL-SCAN ( str len -- str+i len-i )

Look for white space from start of string

 : BL-SCAN 
    BEGIN  DUP WHILE  OVER C@ IS-WHITE NOT
    WHILE  1 /STRING  REPEAT THEN ;

FORTH/DEF toolbelt ordinary primitive

* BL-SKIP ( str len -- str+i len-i )

Skip over white space at start of string.

 : BL-SKIP 
    BEGIN  DUP WHILE  OVER C@ IS-WHITE
    WHILE  1 /STRING  REPEAT THEN ;

FORTH/DEF toolbelt ordinary primitive

* STARTS? ( str len pattern len2 -- str len flag )

Check start of string.

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

FORTH/DEF toolbelt ordinary primitive

* ENDS? ( str len pattern len2 -- str len flag )

Check end of string.

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

FORTH/DEF toolbelt ordinary primitive

* IS-DIGIT ( char -- flag )

Test _char_ for digit [0-9].

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

FORTH/DEF toolbelt ordinary primitive

* IS-ALPHA ( char -- flag )

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

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

FORTH/DEF toolbelt ordinary primitive

* IS-ALNUM ( char -- flag )

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

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

FORTH/DEF toolbelt ordinary primitive

#BACKSPACE-CHAR

[] no special info, see general notes

FORTH/DEF toolbelt ordinary constant

#CHARS/LINE

[] no special info, see general notes

FORTH/DEF toolbelt ordinary constant

#EOL-CHAR

[] no special info, see general notes

FORTH/DEF toolbelt ordinary constant

#TAB-CHAR

[] no special info, see general notes

FORTH/DEF toolbelt ordinary constant

MAX-N

[] no special info, see general notes

FORTH/DEF toolbelt ordinary constant

P4_OCoN ("SIGN-BIT", (1 << (sizeof(p4cell)-1))), CELL

[] no special info, see general notes

FORTH/DEF toolbelt ordinary constant

P4_OCoN ("-CELL", - sizeof(p4cell)),

* SPLIT-NEXT-LINE ( src . -- src' . str len )

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.

FORTH/DEF toolbelt ordinary primitive

* VIEW-NEXT-LINE ( src . str len -- src . str len str2 len2 )

Copy next line above current line.

 : VIEW-NEXT-LINE 
    2OVER 2DUP #EOL-CHAR SCAN NIP - ;

FORTH/DEF toolbelt ordinary primitive

OUT

[] no special info, see general notes

FORTH/DEF toolbelt threadstate variable

* NEXT-WORD ( -- str len )

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 ;

FORTH/DEF toolbelt ordinary primitive

* 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.

 : LEXEME             
    BL WORD ( addr) DUP C@ 1 =
        IF  CHAR+ C@ WORD  THEN
    COUNT ;

FORTH/DEF toolbelt ordinary primitive

* H# ( "hexnumber" -- n )

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

FORTH/DEF toolbelt immediate primitive

* \\ ( "..." -- )

Ignore the rest of the input stream.

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

FORTH/DEF toolbelt ordinary primitive

* FILE-CHECK ( n -- )

Check for file access error.

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

FORTH/DEF toolbelt ordinary primitive

* MEMORY-CHECK ( n -- )

Check for memory allocation error.

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

FORTH/DEF toolbelt ordinary primitive

* ++ ( addr -- )

Increment the value at _addr_.

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

FORTH/DEF toolbelt ordinary primitive

* @+ ( addr -- addr' x )

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

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

FORTH/DEF toolbelt ordinary primitive

* !+ ( addr x -- addr' )

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

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

FORTH/DEF toolbelt ordinary primitive

'th

[] no special info, see general notes

FORTH/DEF toolbelt compiling primitive

* (.) ( n -- addr u )

Convert _n_ to characters, without punctuation, as for `.`
(dot), returning the address and length of the resulting
string.

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

FORTH/DEF toolbelt ordinary primitive

* CELL- ( addr -- addr' )

Decrement address by one cell

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

FORTH/DEF toolbelt ordinary primitive

* EMITS ( n char -- )

Emit _char_ _n_ times.

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

FORTH/DEF toolbelt ordinary primitive

* HIWORD ( xxyy -- xx )

The high half of the value.

 : HIWORD  ( xxyy -- xx )  16 RSHIFT ;

FORTH/DEF toolbelt ordinary primitive

* LOWORD ( xxyy -- yy )

The low half of the value.

 : LOWORD  ( xxyy -- yy )  65535 AND ;

FORTH/DEF toolbelt ordinary primitive

* REWIND-FILE ( file-id -- ior )

Rewind the file.

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

FORTH/DEF toolbelt ordinary primitive

ENVIRONMENT ENVIRONMENT TOOLBELT-EXT

[] no special info, see general notes

ENVIRONMENT toolbelt ordinary constant