toolbelt edit struct

"TOOLBELT - Neil Bawd's common extensions"

toolbelt:
Words as defined by Neil Bawd's toolbelt, quite a few of these
have been around for a while, invented and implemented independently.
Some of these were also present as PFE's extensions words, and they
are referenced here due to the fact that Neil Bawd's website
had been given quite some attention, hence these words should be
assembled in a wordset to clarify their behaviour is compatible.
Comments taken from toolbelt.txt
INTO ("EXTENSIONS", 0 ) ?
* [VOID] ( -- flag )

Immediate FALSE. Used to comment out sections of code.
IMMEDIATE so it can be inside definitions.

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

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]

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.

toolbelt ordinary primitive

* C+! ( n addr -- )

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

toolbelt ordinary primitive

* EMPTY ( -- )

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

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

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 ;

toolbelt ordinary primitive

* OFF ( addr -- )

Store 0 at _addr_. See `ON`. 
  : OFF  ( addr -- )  0 SWAP ! ;

toolbelt ordinary primitive

* ON ( addr -- )

Store -1 at _addr_. See `OFF`. 
  : ON  ( addr -- )  -1 SWAP ! ;

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

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

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 ;

toolbelt ordinary primitive

* STRING, ( str len -- )

Store a string in data space as a counted string. 
 : STRING, HERE  OVER 1+  ALLOT  PLACE ;

toolbelt ordinary primitive

,"

no special info, see general notes

toolbelt immediate primitive

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

Copy third element on the stack onto top of stack. 
 : THIRD   2 PICK ;

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 ;

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 ;

or 
 : 3DUP  3 PICK 3 PICK 3 PICK ;

toolbelt ordinary primitive

* 3DROP ( x y z -- )

Drop the top three elements from the stack. 
 : 3DROP   DROP 2DROP ;

toolbelt ordinary primitive

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

Drop the third and fourth elements from the stack. 
 : 2NIP   2SWAP 2DROP ;

toolbelt ordinary primitive

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

The second element on the return stack. 
 : R'@   S" 2R@ DROP " EVALUATE ; IMMEDIATE

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

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

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 ;

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 ;

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 ;

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

toolbelt ordinary primitive

* IS-WHITE ( char -- flag )

Test char for white space. 
 : IS-WHITE   33 - 0< ;

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 ;

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 ;

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 ;

toolbelt ordinary primitive

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

Check start of string. 
 : STARTS?   DUP >R  2OVER  R> MIN  COMPARE 0= ;

toolbelt ordinary primitive

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

Check end of string. 
 : ENDS?   DUP >R  2OVER  DUP R> - /STRING  COMPARE 0= ;

toolbelt ordinary primitive

* IS-DIGIT ( char -- flag )

Test _char_ for digit [0-9]. 
 : IS-DIGIT   [CHAR] 0 -  10 U< ;

toolbelt ordinary primitive

* IS-ALPHA ( char -- flag )

Test _char_ for alphabetic [A-Za-z]. 
 : IS-ALPHA  32 OR  [CHAR] a -  26 U< ;

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 ;

toolbelt ordinary primitive

* #BACKSPACE-CHAR ( -- char )

Backspace character. 
 8 CONSTANT #BACKSPACE-CHAR

toolbelt ordinary constant

* #CHARS/LINE ( -- n )

Preferred width of line in source files. Suit yourself. 
 62 VALUE    #CHARS/LINE

toolbelt ordinary constant

* #EOL-CHAR ( -- char )

End-of-line character. 13 for Mac and DOS, 10 for Unix. 
 13 CONSTANT #EOL-CHAR

toolbelt ordinary constant

* #TAB-CHAR ( -- char )

Tab character. 
 9 CONSTANT #TAB-CHAR

toolbelt ordinary constant

* MAX-N ( -- n )

Largest usable signed integer. 
 TRUE 1 RSHIFT        CONSTANT MAX-N

toolbelt ordinary constant

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

Address units (i.e. bytes) in a cell. 
 1 CELLS CONSTANT CELL

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.

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

toolbelt ordinary primitive

* OUT ( -- addr )

Promiscuous variable. 
 VARIABLE OUT

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 ;

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 ;

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

toolbelt immediate primitive

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

Ignore the rest of the input stream. 
 : \\   BEGIN  -1 PARSE  2DROP  REFILL 0= UNTIL ;

toolbelt ordinary primitive

* FILE-CHECK ( n -- )

Check for file access error. 
 \ : FILE-CHECK    ( n -- )  THROW ;
 : FILE-CHECK      ( n -- )  ABORT" File Access Error " ;

toolbelt ordinary primitive

* MEMORY-CHECK ( n -- )

Check for memory allocation error. 
 \ : MEMORY-CHECK  ( n -- )  THROW ;
 : MEMORY-CHECK    ( n -- )  ABORT" Memory Allocation Error " ;

toolbelt ordinary primitive

* ++ ( addr -- )

Increment the value at _addr_. 
 : ++  ( addr -- )  1 SWAP +! ;

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

toolbelt ordinary primitive

* !+ ( addr x -- addr' )

Store the value _x_ into _addr_, and increment the address
by one cell. 
 : !+  ( addr x -- addr' )  OVER !  CELL+ ;

toolbelt ordinary primitive

'th

no special info, see general notes

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

toolbelt ordinary primitive

* CELL- ( addr -- addr' )

Decrement address by one cell 
 : CELL-  ( addr -- addr' )  CELL - ;

toolbelt ordinary primitive

* EMITS ( n char -- )

Emit _char_ _n_ times. 
 : EMITS             ( n char -- )
    SWAP 0 ?DO  DUP EMIT  LOOP DROP ;

toolbelt ordinary primitive

* HIWORD ( xxyy -- xx )

The high half of the value. 
 : HIWORD  ( xxyy -- xx )  16 RSHIFT ;

toolbelt ordinary primitive

* LOWORD ( xxyy -- yy )

The low half of the value. 
 : LOWORD  ( xxyy -- yy )  65535 AND ;

toolbelt ordinary primitive

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

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

toolbelt ordinary primitive

ENVIRONMENT ENVIRONMENT TOOLBELT-EXT

no special info, see general notes

toolbelt ordinary constant