fth/flkstring.fs

   1 \  FLK cell counted string tools
   2 \
   3 \  Copyright (C) 1998 Lars Krueger
   4 \
   5 \  This file is part of FLK.
   6 \
   7 \  FLK is free software; you can redistribute it and/or
   8 \  modify it under the terms of the GNU General Public License
   9 \  as published by the Free Software Foundation; either version 2
  10 \  of the License, or (at your option) any later version.
  11 \
  12 \  This program is distributed in the hope that it will be useful,
  13 \  but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 \  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 \  GNU General Public License for more details.
  16 \
  17 \  You should have received a copy of the GNU General Public License
  18 \  along with this program; if not, write to the Free Software
  19 \  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 \ $Id: flkstring.fs,v 1.8 1998/06/01 17:51:42 root Exp $
  22 \ $Log: flkstring.fs,v $
  23 \ Revision 1.8  1998/06/01 17:51:42  root
  24 \ SEE shows the sourcefile using VIEW
  25 \
  26 \ Revision 1.7  1998/05/27 18:52:12  root
  27 \ \: commants added for SEE and HELP
  28 \
  29 \ Revision 1.6  1998/05/16 16:19:24  root
  30 \ direct terminfo access
  31 \
  32 \ Revision 1.5  1998/05/03 12:06:37  root
  33 \ added macro support
  34 \
  35 \ Revision 1.4  1998/05/01 18:11:25  root
  36 \ GNU license text added
  37 \ comments checked
  38 \
  39 \ Revision 1.3  1998/04/29 18:26:32  root
  40 \ >UPPER removed (already in flkkern.fs)
  41 \
  42 \ Revision 1.2  1998/04/24 20:23:34  root
  43 \ upper-case converter
  44 \
  45 \ Revision 1.1  1998/04/11 11:55:44  root
  46 \ Initial revision
  47 \
  48
  49 \ Allocate a piece of memory long enough to hold a cell-counted string
  50 : $ALLOCATE       ( n -- addr )
  51   CHARS CELL+ ALLOCATE THROW
  52   DUP OFF
  53 ;
  54
  55 \ resize a dynamically allocated string
  56 : $RESIZE       ( addr1 n -- addr2)
  57   CHARS CELL+ RESIZE THROW
  58 ;
  59
  60 \ copy a string to a stringvar
  61 : $copy       ( src len dst -- )
  62   2DUP        \ src len dst len dst
  63   !
  64   CELL+ SWAP      \ src dst+1 len
  65   MOVE
  66 ;
  67
  68 \ allocate and copy
  69 : $ALLOCOPY       ( src slen -- addr )
  70   DUP $ALLOCATE DUP >R $copy R>
  71 ;
  72
  73 \ Append a string to a stringvar without resizing.
  74 : $cat        ( addr len str -- )
  75   DUP         \ s sl d d
  76   @         \ s sl d dl
  77   PLUCK       \ s sl d dl sl
  78   OVER +      \ s sl d dl nl
  79   PLUCK       \ s sl d dl nl d
  80   !         \ s sl d dl
  81   CHARS + CELL+     \ s sl de
  82   SWAP MOVE
  83 ;
  84
  85 \ Append a string to a stringvar and resize it.
  86 : $resize-cat       ( str addr len -- )
  87 ( OK )
  88   ROT DUP @       \ addr len str slen
  89   PLUCK +       \ addr len str total
  90   $RESIZE       \ addr len str
  91   DUP -TURN $cat ;
  92
  93 \ print a the contents of an address as a cell-counted string
  94 : ?$        ( addr -- )
  95   @ ?DUP 0<> IF
  96     $COUNT TYPE
  97   THEN
  98 ;
  99
 100 10 CONSTANT LINESEP
 101
 102 \ Split a string at the first character c. The new strings don't contain
 103 \ the separator. If no separator is found, the string s1 contains
 104 \ the whole original string, the string s2 has a zero length and its address
 105 \ might be illegal.
 106 : $split      ( str lstr c -- s1 ls1 s2 ls2 )
 107   0         \ str lstr c ind
 108   BEGIN
 109     PLUCK OVER      \ str lstr c ind lstr ind
 110     >
 111   WHILE         \ str lstr c ind
 112     3 PICK OVER       \ str lstr c ind str ind
 113     CHARS + C@      \ str lstr c ind char
 114     PLUCK = IF      \ str lstr c ind
 115       NIP       \ str lstr ind
 116       PLUCK       \ str lstr ind str
 117       SWAP 2SWAP    \ str ind str lstr
 118       PLUCK 1+      \ str ind str lstr ind+1
 119       ROT OVER +    \ str ind lstr ind+1 str+ind+1
 120       -ROT      \ str ind str+ind+1 lstr ind+1
 121       -
 122       EXIT      \ str ind str+ind+1 lstr-(ind+1)
 123     THEN      \ str lstr c ind
 124     1+
 125   REPEAT      \ str lstr c ind
 126   2DROP 2DUP + 0
 127 ;
 128
 129 \ Print a string containing CRs by breaking in lines. Prepend the first line
 130 \ with s1 and any other lines with s2. The user is responsible that the lines
 131 \ are short enough to fit into one line with the prepended string. It will
 132 \ work when the TYPEd lines are longer than the physical line but it will
 133 \ look bad.
 134 : $.broken      ( s1 ls1 s2 ls2 str lstr -- )
 135   2ROT TYPE       \ s2 ls2 str lstr
 136   LINESEP $split    \ s2 ls2 str1 lstr1 str2 lstr2
 137   2SWAP TYPE CR
 138   BEGIN         \ s2 ls2 str lstr
 139     DUP 0<>
 140   WHILE
 141     2OVER TYPE
 142     LINESEP $split    \ s2 ls2 str1 lstr1 str2 lstr2
 143     2SWAP TYPE CR
 144   REPEAT
 145   2DROP 2DROP
 146 ;
 147
 148 \ concat the strings and return the allocated result
 149 : $allo-cat       ( s1 l1 s2 l2 -- addr )
 150   ROT         \ s1 s2 l2 l1
 151   2DUP + $ALLOCATE    \ s1 s2 l2 l1 addr
 152   >R >R ROT R> R>     \ s2 l2 s1 l1 addr
 153   DUP >R $copy R@     \ s2 l2 addr
 154   $cat R>
 155 ;