PFE - Portable Forth Environment - pfe Forth Wordsets

  PFE 0.33.71 Homepage SourceForge Download Documentation -Overview -The PFE Manual old manual / (book) -ChangeLog -Authors -License (LGPL) -Wordsets / (book) -Functions .. (book) -Dp of ANS Forth -The 4thTutor -Forthprimer.pdf - Old Wordsets - Old Words List Forth Links * Forth Repository * Taygeta Compilation * TinyBoot FirmWare * FiCL, Free Forth * Research Vienna * Research Bournemouth * zForth WebRing Other Links * Tektronix/MPT * Forth Org. (FIG) * Forth Inc. * MPE Ltd. Forths * SF Win32Forth * PD Win32Forth * Neil Bawd 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]