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

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