git.gag.com Git - debian/pforth/blob - strings.fth

   1 \ @(#) strings.fth 98/01/26 1.2
   2 \ String support for PForth
   3 \
   4 \ Copyright Phil Burk 1994
   5
   6 ANEW TASK-STRINGS.FTH
   7
   8 : -TRAILING  ( c-addr u1 -- c-addr u2 , strip trailing blanks )
   9         dup 0>
  10         IF
  11                 BEGIN
  12                         2dup 1- chars + c@ bl =
  13                         over 0> and
  14                 WHILE
  15                         1-
  16                 REPEAT
  17         THEN
  18 ;
  19
  20 \ Structure of string table
  21 : $ARRAY  (  )
  22     CREATE  ( #strings #chars_max --  )
  23         dup ,
  24         2+ * even-up allot
  25     DOES>    ( index -- $addr )
  26         dup @  ( get #chars )
  27         rot * + 4 +
  28 ;
  29
  30 \ Compare two strings
  31 : $= ( $1 $2 -- flag , true if equal )
  32     -1 -rot
  33     dup c@ 1+ 0
  34     DO  dup c@ tolower
  35         2 pick c@ tolower -
  36         IF rot drop 0 -rot LEAVE
  37         THEN
  38                 1+ swap 1+ swap
  39     LOOP 2drop
  40 ;
  41
  42 : TEXT=  ( addr1 addr2 count -- flag )
  43     >r -1 -rot
  44         r> 0
  45     DO  dup c@ tolower
  46         2 pick c@ tolower -
  47         IF rot drop 0 -rot LEAVE
  48         THEN
  49                 1+ swap 1+ swap
  50     LOOP 2drop
  51 ;
  52
  53 : TEXT=?  ( addr1 count addr2 -- flag , for JForth compatibility )
  54         swap text=
  55 ;
  56
  57 : $MATCH?  ( $string1 $string2 -- flag , case INsensitive )
  58         dup c@ 1+ text=
  59 ;
  60
  61
  62 : INDEX ( $string char -- false | address_char true , search for char in string )
  63     >r >r 0 r> r>
  64     over c@ 1+ 1
  65     DO  over i + c@ over =
  66         IF  rot drop
  67             over i + rot rot LEAVE
  68         THEN
  69     LOOP 2drop
  70     ?dup 0= 0=
  71 ;
  72
  73
  74 : $APPEND.CHAR  ( $string char -- ) \ ugly stack diagram
  75     over count chars + c!
  76     dup c@ 1+ swap c!
  77 ;
  78
  79 \ ----------------------------------------------
  80 : ($ROM)  ( index address -- $string )
  81     ( -- index address )
  82     swap 0
  83     DO dup c@ 1+ + aligned
  84     LOOP
  85 ;
  86
  87 : $ROM ( packed array of strings, unalterable )
  88     CREATE ( <name> -- )
  89     DOES> ( index -- $string )  ($rom)
  90 ;
  91
  92 : TEXTROM ( packed array of strings, unalterable )
  93     CREATE ( <name> -- )
  94     DOES> ( index -- address count )  ($rom) count
  95 ;
  96
  97 \ -----------------------------------------------