libguile/strop.c

   1 /* classes: src_files */
   2
   3 /*      Copyright (C) 1994, 1996, 1997, 1999 Free Software Foundation, Inc.
   4
   5 This program is free software; you can redistribute it and/or modify
   6 it under the terms of the GNU General Public License as published by
   7 the Free Software Foundation; either version 2, or (at your option)
   8 any later version.
   9
  10 This program is distributed in the hope that it will be useful,
  11 but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 GNU General Public License for more details.
  14
  15 You should have received a copy of the GNU General Public License
  16 along with this software; see the file COPYING.  If not, write to the
  17 Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  18 02111-1307 USA */
  19
  20 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  21    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  22
  23
  24 \f
  25
  26 #include <stdio.h>
  27 #include "_scm.h"
  28 #include "chars.h"
  29
  30 #include "scm_validate.h"
  31 #include "strop.h"
  32 #include "read.h" /*For SCM_CASE_INSENSITIVE_P*/
  33 \f
  34
  35
  36 /* implements index if direction > 0 otherwise rindex.  */
  37 static int
  38 scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start,
  39              SCM sub_end, const char *why)
  40 {
  41   unsigned char * p;
  42   int x;
  43   int lower;
  44   int upper;
  45   int ch;
  46
  47   SCM_ASSERT (SCM_ROSTRINGP (*str), *str, SCM_ARG1, why);
  48   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, why);
  49
  50   if (sub_start == SCM_BOOL_F)
  51     sub_start = SCM_MAKINUM (0);
  52
  53   SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why);
  54   lower = SCM_INUM (sub_start);
  55   if (lower < 0
  56       || lower > SCM_ROLENGTH (*str))
  57     scm_out_of_range (why, sub_start);
  58
  59   if (sub_end == SCM_BOOL_F)
  60     sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str));
  61
  62   SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why);
  63   upper = SCM_INUM (sub_end);
  64   if (upper < SCM_INUM (sub_start)
  65       || upper > SCM_ROLENGTH (*str))
  66     scm_out_of_range (why, sub_end);
  67
  68   if (direction > 0)
  69     {
  70       p = (unsigned char *)SCM_ROCHARS (*str) + lower;
  71       ch = SCM_ICHR (chr);
  72
  73       for (x = SCM_INUM (sub_start); x < upper; ++x, ++p)
  74         if (*p == ch)
  75           return x;
  76     }
  77   else
  78     {
  79       p = upper - 1 + (unsigned char *)SCM_ROCHARS (*str);
  80       ch = SCM_ICHR (chr);
  81       for (x = upper - 1; x >= lower; --x, --p)
  82         if (*p == ch)
  83           return x;
  84     }
  85
  86   return -1;
  87 }
  88
  89 GUILE_PROC(scm_string_index, "string-index", 2, 2, 0,
  90            (SCM str, SCM chr, SCM frm, SCM to),
  91 "Return the index of the first occurrence of @var{chr} in @var{str}.  The
  92 optional integer arguments @var{frm} and @var{to} limit the search to
  93 a portion of the string.  This procedure essentially implements the
  94 @code{index} or @code{strchr} functions from the C library.")
  95 #define FUNC_NAME s_scm_string_index
  96 {
  97   int pos;
  98
  99   if (frm == SCM_UNDEFINED)
 100     frm = SCM_BOOL_F;
 101   if (to == SCM_UNDEFINED)
 102     to = SCM_BOOL_F;
 103   pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME);
 104   return (pos < 0
 105           ? SCM_BOOL_F
 106           : SCM_MAKINUM (pos));
 107 }
 108 #undef FUNC_NAME
 109
 110 GUILE_PROC(scm_string_rindex, "string-rindex", 2, 2, 0,
 111            (SCM str, SCM chr, SCM frm, SCM to),
 112 "Like @code{string-index}, but search from the right of the string rather
 113 than from the left.  This procedure essentially implements the
 114 @code{rindex} or @code{strrchr} functions from the C library.")
 115 #define FUNC_NAME s_scm_string_rindex
 116 {
 117   int pos;
 118
 119   if (frm == SCM_UNDEFINED)
 120     frm = SCM_BOOL_F;
 121   if (to == SCM_UNDEFINED)
 122     to = SCM_BOOL_F;
 123   pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME);
 124   return (pos < 0
 125           ? SCM_BOOL_F
 126           : SCM_MAKINUM (pos));
 127 }
 128 #undef FUNC_NAME
 129
 130
 131 SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
 132 SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
 133
 134
 135 GUILE_PROC(scm_substring_move_x, "substring-move!", 5, 0, 0,
 136            (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
 137 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}
 138 into @var{str2} beginning at position @var{end2}.
 139 @code{substring-move-right!} begins copying from the rightmost character
 140 and moves left, and @code{substring-move-left!} copies from the leftmost
 141 character moving right.
 142
 143 It is useful to have two functions that copy in different directions so
 144 that substrings can be copied back and forth within a single string.  If
 145 you wish to copy text from the left-hand side of a string to the
 146 right-hand side of the same string, and the source and destination
 147 overlap, you must be careful to copy the rightmost characters of the
 148 text first, to avoid clobbering your data.  Hence, when @var{str1} and
 149 @var{str2} are the same string, you should use
 150 @code{substring-move-right!} when moving text from left to right, and
 151 @code{substring-move-left!}  otherwise.  If @code{str1} and @samp{str2}
 152 are different strings, it does not matter which function you use.")
 153 #define FUNC_NAME s_scm_substring_move_x
 154 {
 155   long s1, s2, e, len;
 156
 157   SCM_VALIDATE_STRING(1,str1);
 158   SCM_VALIDATE_INUM_COPY(2,start1,s1);
 159   SCM_VALIDATE_INUM_COPY(3,end1,e);
 160   SCM_VALIDATE_STRING(4,str2);
 161   SCM_VALIDATE_INUM_COPY(5,start2,s2);
 162   len = e - s1;
 163   SCM_ASSERT_RANGE (3,end1,len >= 0);
 164   SCM_ASSERT_RANGE (2,start1,s1 <= SCM_LENGTH (str1) && s1 >= 0);
 165   SCM_ASSERT_RANGE (5,start2,s2 <= SCM_LENGTH (str2) && s2 >= 0);
 166   SCM_ASSERT_RANGE (3,end1,e <= SCM_LENGTH (str1) && e >= 0);
 167   SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_LENGTH (str2));
 168
 169   SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2)[s2])),
 170                       (void *)(&(SCM_CHARS(str1)[s1])),
 171                       len));
 172
 173   return scm_return_first(SCM_UNSPECIFIED, str1, str2);
 174 }
 175 #undef FUNC_NAME
 176
 177
 178 GUILE_PROC(scm_substring_fill_x, "substring-fill!", 4, 0, 0,
 179            (SCM str, SCM start, SCM end, SCM fill),
 180 "Change every character in @var{str} between @var{start} and @var{end} to
 181 @var{fill-char}.")
 182 #define FUNC_NAME s_scm_substring_fill_x
 183 {
 184   long i, e;
 185   char c;
 186   SCM_VALIDATE_STRING(1,str);
 187   SCM_VALIDATE_INUM_COPY(2,start,i);
 188   SCM_VALIDATE_INUM_COPY(3,end,e);
 189   SCM_VALIDATE_CHAR_COPY(4,fill,c);
 190   SCM_ASSERT_RANGE (2,start,i <= SCM_LENGTH (str) && i >= 0);
 191   SCM_ASSERT_RANGE (3,end,e <= SCM_LENGTH (str) && e >= 0);
 192   while (i<e) SCM_CHARS (str)[i++] = c;
 193   return SCM_UNSPECIFIED;
 194 }
 195 #undef FUNC_NAME
 196
 197
 198 GUILE_PROC(scm_string_null_p, "string-null?", 1, 0, 0,
 199            (SCM str),
 200 "Return @code{#t} if @var{str}'s length is nonzero, and @code{#f}
 201 otherwise.")
 202 #define FUNC_NAME s_scm_string_null_p
 203 {
 204   SCM_VALIDATE_ROSTRING(1,str);
 205   return SCM_NEGATE_BOOL(SCM_ROLENGTH (str));
 206 }
 207 #undef FUNC_NAME
 208
 209
 210 GUILE_PROC(scm_string_to_list, "string->list", 1, 0, 0,
 211            (SCM str),
 212 "")
 213 #define FUNC_NAME s_scm_string_to_list
 214 {
 215   long i;
 216   SCM res = SCM_EOL;
 217   unsigned char *src;
 218   SCM_VALIDATE_ROSTRING(1,str);
 219   src = SCM_ROUCHARS (str);
 220   for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res);
 221   return res;
 222 }
 223 #undef FUNC_NAME
 224
 225
 226
 227 GUILE_PROC(scm_string_copy, "string-copy", 1, 0, 0,
 228            (SCM str),
 229 "")
 230 #define FUNC_NAME s_scm_string_copy
 231 {
 232   SCM_VALIDATE_STRINGORSUBSTR(1,str);
 233   return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0);
 234 }
 235 #undef FUNC_NAME
 236
 237
 238 GUILE_PROC(scm_string_fill_x, "string-fill!", 2, 0, 0,
 239            (SCM str, SCM chr),
 240 "")
 241 #define FUNC_NAME s_scm_string_fill_x
 242 {
 243   register char *dst, c;
 244   register long k;
 245   SCM_VALIDATE_STRING_COPY(1,str,dst);
 246   SCM_VALIDATE_CHAR_COPY(2,chr,c);
 247   for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c;
 248   return SCM_UNSPECIFIED;
 249 }
 250 #undef FUNC_NAME
 251
 252 GUILE_PROC(scm_string_upcase_x, "string-upcase!", 1, 0, 0,
 253            (SCM v),
 254 "@deffnx primitive string-downcase! str
 255 Upcase or downcase every character in @code{str}, respectively.")
 256 #define FUNC_NAME s_scm_string_upcase_x
 257 {
 258   register long k;
 259   register unsigned char *cs;
 260   SCM_ASRTGO (SCM_NIMP (v), badarg1);
 261   k = SCM_LENGTH (v);
 262   switch SCM_TYP7
 263     (v)
 264     {
 265     case scm_tc7_string:
 266       cs = SCM_UCHARS (v);
 267       while (k--)
 268         cs[k] = scm_upcase(cs[k]);
 269       break;
 270     default:
 271     badarg1:SCM_WTA (1,v);
 272     }
 273   return v;
 274 }
 275 #undef FUNC_NAME
 276
 277 GUILE_PROC(scm_string_upcase, "string-upcase", 1, 0, 0,
 278            (SCM str),
 279 "")
 280 #define FUNC_NAME s_scm_string_upcase
 281 {
 282   return scm_string_upcase_x(scm_string_copy(str));
 283 }
 284 #undef FUNC_NAME
 285
 286 GUILE_PROC(scm_string_downcase_x, "string-downcase!", 1, 0, 0,
 287            (SCM v),
 288 "")
 289 #define FUNC_NAME s_scm_string_downcase_x
 290 {
 291   register long k;
 292   register unsigned char *cs;
 293   SCM_ASRTGO (SCM_NIMP (v), badarg1);
 294   k = SCM_LENGTH (v);
 295   switch (SCM_TYP7(v))
 296     {
 297       case scm_tc7_string:
 298         cs = SCM_UCHARS (v);
 299         while (k--)
 300           cs[k] = scm_downcase(cs[k]);
 301         break;
 302       default:
 303     badarg1:SCM_WTA (1,v);
 304     }
 305   return v;
 306 }
 307 #undef FUNC_NAME
 308
 309 GUILE_PROC(scm_string_downcase, "string-downcase", 1, 0, 0,
 310            (SCM str),
 311 "")
 312 #define FUNC_NAME s_scm_string_downcase
 313 {
 314   SCM_VALIDATE_STRING(1,str);
 315   return scm_string_downcase_x(scm_string_copy(str));
 316 }
 317 #undef FUNC_NAME
 318
 319 GUILE_PROC(scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
 320            (SCM s),
 321 "")
 322 #define FUNC_NAME s_scm_string_capitalize_x
 323 {
 324   char *str;
 325   int i, len, in_word=0;
 326   SCM_VALIDATE_STRING(1,s);
 327   len = SCM_LENGTH(s);
 328   str = SCM_CHARS(s);
 329   for(i=0; i<len;  i++) {
 330     if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKICHR(str[i])))) {
 331       if(!in_word) {
 332         str[i] = scm_upcase(str[i]);
 333         in_word = 1;
 334       } else {
 335         str[i] = scm_downcase(str[i]);
 336       }
 337     }
 338     else in_word = 0;
 339   }
 340   return s;
 341 }
 342 #undef FUNC_NAME
 343
 344 GUILE_PROC(scm_string_capitalize, "string-capitalize", 1, 0, 0,
 345            (SCM s),
 346 "")
 347 #define FUNC_NAME s_scm_string_capitalize
 348 {
 349   SCM_VALIDATE_STRING(1,s);
 350   return scm_string_capitalize_x(scm_string_copy(s));
 351 }
 352 #undef FUNC_NAME
 353
 354 GUILE_PROC(scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
 355            (SCM str),
 356 "")
 357 #define FUNC_NAME s_scm_string_ci_to_symbol
 358 {
 359   return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
 360                                ? scm_string_downcase(str)
 361                                : str);
 362 }
 363 #undef FUNC_NAME
 364
 365 void
 366 scm_init_strop ()
 367 {
 368 #include "strop.x"
 369 }