forth_usual forth_83 misc

"Usual Forth extensions"

forth_usual
There are lots of useful words that do not appear
in any standard. This wordset defines some of them.
Tektronix CTE %version: bln_mpt1!5.26 % GNU LGPL
 FORTH
* the value for BackSpace to be used with EMIT - compare with BL
* #BACKSPACE-CHAR ( -- char )

Backspace character. 
 8 CONSTANT #BACKSPACE-CHAR

forth_usual ordinary constant

* C+! ( n addr -- )

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

forth_usual 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_usual 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_usual ordinary primitive

FORTH OFF!

no special info, see general notes

forth_usual ordinary primitive

* ON! ( addr -- )

Store -1 at _addr_. Defined in f83 as ON. See antonym OFF!. 
  : ON!  ( addr -- )  -1 SWAP ! ;

forth_usual ordinary primitive

* OFF ( addr -- )

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

forth_usual forthword synonym

* ON ( addr -- )

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

forth_usual forthword synonym

* 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_usual ordinary primitive

* +PLACE ( str len add2 -- )

Append string _str len_ to the counted string at _addr_.
a.k.a. APPEND (being a SYNONYM now) 
 : +PLACE   2DUP 2>R  COUNT +  SWAP MOVE ( ) 2R> C+! ;

forth_usual ordinary primitive

* C+PLACE ( char addr -- )

Append _char_ to the counted string at _addr_.
a.k.a. APPEND-CHAR (being a SYNONYM now) 
 : C+PLACE   DUP >R  COUNT  DUP 1+ R> C!  +  C! ;

forth_usual 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_usual forthword synonym

* APPEND-CHAR ( char addr -- )

Append _char_ to the counted string at _addr_. 
 : APPEND-CHAR   DUP >R  COUNT  DUP 1+ R> C!  +  C! ;

forth_usual forthword synonym

* @EXECUTE ( xt -- ? )

same as @ EXECUTE , but checks for null as xt and
silently ignores it. Same as in most forths where defined. 
 simulate:
   : @EXECUTE  @ ?DUP IF EXECUTE THEN ;

forth_usual ordinary primitive

* ?LEAVE ( cond -- )

leave a (innermost) loop if condition is true

forth_usual ordinary primitive

* NOOP ( -- )

do nothing, used as a place-holder where
an execution word is needed

forth_usual ordinary primitive

* RP@ ( -- addr )

returns the return stack pointer 
 example:
   : R@ RP@ @ ;

forth_usual ordinary primitive

* RP! ( addr -- )

sets the return stack pointer, reverse of RP@

forth_usual ordinary primitive

* SP! ( ... addr -- )

sets the stack pointer, reverse of SP@

forth_usual ordinary primitive

* -ROT ( a b c -- c a b )

inverse of ROT

forth_usual ordinary primitive

* CSET ( n addr -- )

set bits in byte at given address 
 simulate:
   : CSET  TUCK @ SWAP OR SWAP ! ;

forth_usual ordinary primitive

* CRESET ( n addr -- )

reset bits in byte at given address 
 simulate:
   : CRESET  TUCK @ SWAP NOT AND SWAP ! ;

forth_usual ordinary primitive

* CTOGGLE ( n addr -- )

toggle bits in byte at given address 
 simulate:
   : CTOGGLE  TUCK @ SWAP XOR SWAP ! ;

forth_usual ordinary primitive

* TOGGLE ( c-addr charmask -- )

toggle the bits given in charmask, see also SMUDGE and = UNSMUDGE 
 example: the fig-style SMUDGE had been defined such
   : FIG-SMUDGE LATEST >FFA (SMUDGE#) TOGGLE ;

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

forth_usual ordinary primitive

* 3DROP ( x y z -- )

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

forth_usual ordinary primitive

* 4DUP ( a b c d -- a b c d a b c d )
 simulate:
  : 4DUP  4 PICK 4 PICK 4 PICK 4 PICK ;

forth_usual ordinary primitive

* 4DROP ( x y z -- )

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

forth_usual ordinary primitive

* TOUPPER ( c1 -- c2 )

convert a single character to upper case 
   : TOUPPER  >R _toupper ;

forth_usual ordinary primitive

* UPPER ( addr cnt -- )

convert string to upper case 
 simulate:
   : UPPER  0 DO  DUP I +  DUP C@ UPC SWAP C!  LOOP  DROP ;

forth_usual ordinary primitive

* LOWER ( addr cnt -- )

convert string to lower case
This is not in LP's F83 but provided for symmetry 
 simulate:
   : LOWER  0 DO  DUP I +  DUP C@ >R _tolower SWAP C!  LOOP  DROP ;

forth_usual ordinary primitive

* ASCII ( [word] -- val )

state smart version of CHAR or [CHAR] resp. 
 simulate:
   : ASCII  [COMPILE] [CHAR] 
            STATE @ IF [COMPILE] LITERAL THEN ;

forth_usual compiling primitive

* CONTROL ( [word] -- val )

see ASCII, but returns char - '@' 
 simulate:
   : CONTROL  [COMPILE] [CHAR]  [CHAR] @ -  
              STATE @ IF [COMPILE] LITERAL THEN ;

forth_usual compiling primitive

* NUMBER? ( addr -- d flag )

convert counted string to number - used in inner interpreter
( INTERPRET ), flags if conversion was successful 
 example:
   BL WORD  HERE NUMBER? 0= IF ." not a number " THEN .

forth_usual ordinary primitive

* VOCS ( -- )

list all vocabularies in the system 
 simulate:
   : VOCS VOC-LINK @ BEGIN DUP WHILE
                           DUP ->WORDLIST.NAME @ ID.
                           ->WORDLIST.LINK @
                     REPEAT DROP ;

forth_usual ordinary primitive

* EMITS ( n char -- )

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

forth_usual ordinary primitive

* FILE-CHECK ( n -- )

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

forth_usual ordinary primitive

* MEMORY-CHECK ( n -- )

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

forth_usual ordinary primitive

* ++ ( addr -- )

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

forth_usual 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_usual ordinary primitive

* !++ ( addr x -- addr' )

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

forth_usual 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_usual forthword synonym

* !+ ( addr x -- addr' )

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

forth_usual forthword synonym

FORTH ENDIF

no special info, see general notes

forth_usual immediate synonym

EXTENSIONS
* >WORDLIST ( xt -- wordl* )

convert a VOCABULARY-xt into its wordlist reference
(as in win32forth)

forth_usual ordinary primitive

* PERFORM ( addr -- ? )

see @EXECUTE which reads better

forth_usual loader code P4_xOLD

EXTENSIONS UPC

no special info, see general notes

forth_usual loader code P4_xOLD