libguile/strop.c

   1 /* classes: src_files */
   2
   3 /* Copyright (C) 1994,1996,1997,1999,2000,2001 Free Software Foundation, Inc.
   4
   5  * This library is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU Lesser General Public
   7  * License as published by the Free Software Foundation; either
   8  * version 2.1 of the License, or (at your option) any later version.
   9  *
  10  * This library 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 GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18  */
  19
  20 \f
  21 #if HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include <errno.h>
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/chars.h"
  29 #include "libguile/strings.h"
  30
  31 #include "libguile/validate.h"
  32 #include "libguile/strop.h"
  33 #include "libguile/read.h" /*For SCM_CASE_INSENSITIVE_P*/
  34
  35 #ifdef HAVE_STRING_H
  36 #include <string.h>
  37 #endif
  38
  39 \f
  40
  41 /*
  42 xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0,
  43            (SCM str, SCM chr, SCM frm, SCM to),
  44            "@deftypefn {Internal C Function} {static int} scm_i_index (SCM *@var{str},\n"
  45            "SCM @var{chr}, int @var{direction}, SCM @var{sub_start}, SCM @var{sub_end}, char *@var{why})
  46            "This is a workhorse function that performs either an @code{index} or\n"
  47            "@code{rindex} function, depending on the value of @var{direction}."
  48 */
  49 /* implements index if direction > 0 otherwise rindex.  */
  50 static long
  51 scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start,
  52              SCM sub_end, const char *why)
  53 {
  54   unsigned char * p;
  55   long x;
  56   long lower;
  57   long upper;
  58   int ch;
  59
  60   SCM_ASSERT (SCM_STRINGP (*str), *str, SCM_ARG1, why);
  61   SCM_ASSERT (SCM_CHARP (chr), chr, SCM_ARG2, why);
  62
  63   if (scm_is_false (sub_start))
  64     sub_start = SCM_I_MAKINUM (0);
  65
  66   SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why);
  67   lower = SCM_INUM (sub_start);
  68   if (lower < 0 || lower > SCM_STRING_LENGTH (*str))
  69     scm_out_of_range (why, sub_start);
  70
  71   if (scm_is_false (sub_end))
  72     sub_end = SCM_I_MAKINUM (SCM_STRING_LENGTH (*str));
  73
  74   SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why);
  75   upper = SCM_INUM (sub_end);
  76   if (upper < SCM_INUM (sub_start) || upper > SCM_STRING_LENGTH (*str))
  77     scm_out_of_range (why, sub_end);
  78
  79   if (direction > 0)
  80     {
  81       p = SCM_STRING_UCHARS (*str) + lower;
  82       ch = SCM_CHAR (chr);
  83
  84       for (x = SCM_INUM (sub_start); x < upper; ++x, ++p)
  85         if (*p == ch)
  86           return x;
  87     }
  88   else
  89     {
  90       p = upper - 1 + SCM_STRING_UCHARS (*str);
  91       ch = SCM_CHAR (chr);
  92       for (x = upper - 1; x >= lower; --x, --p)
  93         if (*p == ch)
  94           return x;
  95     }
  96
  97   return -1;
  98 }
  99
 100 SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
 101            (SCM str, SCM chr, SCM frm, SCM to),
 102             "Return the index of the first occurrence of @var{chr} in\n"
 103             "@var{str}.  The optional integer arguments @var{frm} and\n"
 104             "@var{to} limit the search to a portion of the string.  This\n"
 105             "procedure essentially implements the @code{index} or\n"
 106             "@code{strchr} functions from the C library.\n"
 107             "\n"
 108             "@lisp\n"
 109             "(string-index \"weiner\" #\\e)\n"
 110             "@result{} 1\n\n"
 111             "(string-index \"weiner\" #\\e 2)\n"
 112             "@result{} 4\n\n"
 113             "(string-index \"weiner\" #\\e 2 4)\n"
 114             "@result{} #f\n"
 115             "@end lisp")
 116 #define FUNC_NAME s_scm_string_index
 117 {
 118   long pos;
 119
 120   if (SCM_UNBNDP (frm))
 121     frm = SCM_BOOL_F;
 122   if (SCM_UNBNDP (to))
 123     to = SCM_BOOL_F;
 124   pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME);
 125   return (pos < 0
 126           ? SCM_BOOL_F
 127           : SCM_I_MAKINUM (pos));
 128 }
 129 #undef FUNC_NAME
 130
 131 SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0,
 132            (SCM str, SCM chr, SCM frm, SCM to),
 133             "Like @code{string-index}, but search from the right of the\n"
 134             "string rather than from the left.  This procedure essentially\n"
 135             "implements the @code{rindex} or @code{strrchr} functions from\n"
 136             "the C library.\n"
 137             "\n"
 138             "@lisp\n"
 139             "(string-rindex \"weiner\" #\\e)\n"
 140             "@result{} 4\n\n"
 141             "(string-rindex \"weiner\" #\\e 2 4)\n"
 142             "@result{} #f\n\n"
 143             "(string-rindex \"weiner\" #\\e 2 5)\n"
 144             "@result{} 4\n"
 145             "@end lisp")
 146 #define FUNC_NAME s_scm_string_rindex
 147 {
 148   long pos;
 149
 150   if (SCM_UNBNDP (frm))
 151     frm = SCM_BOOL_F;
 152   if (SCM_UNBNDP (to))
 153     to = SCM_BOOL_F;
 154   pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME);
 155   return (pos < 0
 156           ? SCM_BOOL_F
 157           : SCM_I_MAKINUM (pos));
 158 }
 159 #undef FUNC_NAME
 160
 161 SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0,
 162            (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
 163             "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
 164             "into @var{str2} beginning at position @var{start2}.\n"
 165             "@var{str1} and @var{str2} can be the same string.")
 166 #define FUNC_NAME s_scm_substring_move_x
 167 {
 168   unsigned long s1, s2, e, len;
 169
 170   SCM_VALIDATE_STRING (1, str1);
 171   SCM_VALIDATE_STRING (4, str2);
 172   s1 = scm_to_unsigned_integer (start1, 0, SCM_STRING_LENGTH(str1));
 173   e = scm_to_unsigned_integer (end1, s1, SCM_STRING_LENGTH(str1));
 174   len = e - s1;
 175   s2 = scm_to_unsigned_integer (start2, 0, SCM_STRING_LENGTH(str2)-len);
 176
 177   SCM_SYSCALL(memmove((void *)(&(SCM_STRING_CHARS(str2)[s2])),
 178                       (void *)(&(SCM_STRING_CHARS(str1)[s1])),
 179                       len));
 180
 181   return scm_return_first(SCM_UNSPECIFIED, str1, str2);
 182 }
 183 #undef FUNC_NAME
 184
 185
 186 SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0,
 187            (SCM str, SCM start, SCM end, SCM fill),
 188             "Change every character in @var{str} between @var{start} and\n"
 189             "@var{end} to @var{fill}.\n"
 190             "\n"
 191             "@lisp\n"
 192             "(define y \"abcdefg\")\n"
 193             "(substring-fill! y 1 3 #\\r)\n"
 194             "y\n"
 195             "@result{} \"arrdefg\"\n"
 196             "@end lisp")
 197 #define FUNC_NAME s_scm_substring_fill_x
 198 {
 199   size_t i, e;
 200   char c;
 201   SCM_VALIDATE_STRING (1, str);
 202   i = scm_to_unsigned_integer (start, 0, SCM_STRING_LENGTH (str));
 203   e = scm_to_unsigned_integer (end, i, SCM_STRING_LENGTH (str));
 204   SCM_VALIDATE_CHAR_COPY (4, fill, c);
 205   while (i<e) SCM_STRING_CHARS (str)[i++] = c;
 206   return SCM_UNSPECIFIED;
 207 }
 208 #undef FUNC_NAME
 209
 210
 211 SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0,
 212            (SCM str),
 213             "Return @code{#t} if @var{str}'s length is zero, and\n"
 214             "@code{#f} otherwise.\n"
 215             "@lisp\n"
 216             "(string-null? \"\")  @result{} #t\n"
 217             "y                    @result{} \"foo\"\n"
 218             "(string-null? y)     @result{} #f\n"
 219             "@end lisp")
 220 #define FUNC_NAME s_scm_string_null_p
 221 {
 222   SCM_VALIDATE_STRING (1, str);
 223   return scm_from_bool (SCM_STRING_LENGTH (str) == 0);
 224 }
 225 #undef FUNC_NAME
 226
 227
 228 SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0,
 229            (SCM str),
 230             "Return a newly allocated list of the characters that make up\n"
 231             "the given string @var{str}. @code{string->list} and\n"
 232             "@code{list->string} are inverses as far as @samp{equal?} is\n"
 233             "concerned.")
 234 #define FUNC_NAME s_scm_string_to_list
 235 {
 236   long i;
 237   SCM res = SCM_EOL;
 238   unsigned char *src;
 239   SCM_VALIDATE_STRING (1, str);
 240   src = SCM_STRING_UCHARS (str);
 241   for (i = SCM_STRING_LENGTH (str)-1;i >= 0;i--) res = scm_cons (SCM_MAKE_CHAR (src[i]), res);
 242   return res;
 243 }
 244 #undef FUNC_NAME
 245
 246
 247 /* Helper function for the string copy and string conversion functions.
 248  * No argument checking is performed.  */
 249 static SCM
 250 string_copy (SCM str)
 251 {
 252   const char* chars = SCM_STRING_CHARS (str);
 253   size_t length = SCM_STRING_LENGTH (str);
 254   SCM new_string = scm_mem2string (chars, length);
 255   scm_remember_upto_here_1 (str);
 256   return new_string;
 257 }
 258
 259
 260 SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0,
 261             (SCM str),
 262             "Return a newly allocated copy of the given @var{string}.")
 263 #define FUNC_NAME s_scm_string_copy
 264 {
 265   SCM_VALIDATE_STRING (1, str);
 266
 267   return string_copy (str);
 268 }
 269 #undef FUNC_NAME
 270
 271
 272 SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0,
 273            (SCM str, SCM chr),
 274             "Store @var{char} in every element of the given @var{string} and\n"
 275             "return an unspecified value.")
 276 #define FUNC_NAME s_scm_string_fill_x
 277 {
 278   register char *dst, c;
 279   register long k;
 280   SCM_VALIDATE_STRING_COPY (1, str, dst);
 281   SCM_VALIDATE_CHAR_COPY (2, chr, c);
 282   for (k = SCM_STRING_LENGTH (str)-1;k >= 0;k--) dst[k] = c;
 283   return SCM_UNSPECIFIED;
 284 }
 285 #undef FUNC_NAME
 286
 287
 288 /* Helper function for the string uppercase conversion functions.
 289  * No argument checking is performed.  */
 290 static SCM
 291 string_upcase_x (SCM v)
 292 {
 293   unsigned long k;
 294
 295   for (k = 0; k < SCM_STRING_LENGTH (v); ++k)
 296     SCM_STRING_UCHARS (v) [k] = scm_c_upcase (SCM_STRING_UCHARS (v) [k]);
 297
 298   return v;
 299 }
 300
 301
 302 SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0,
 303             (SCM str),
 304             "Destructively upcase every character in @var{str} and return\n"
 305             "@var{str}.\n"
 306             "@lisp\n"
 307             "y                  @result{} \"arrdefg\"\n"
 308             "(string-upcase! y) @result{} \"ARRDEFG\"\n"
 309             "y                  @result{} \"ARRDEFG\"\n"
 310             "@end lisp")
 311 #define FUNC_NAME s_scm_string_upcase_x
 312 {
 313   SCM_VALIDATE_STRING (1, str);
 314
 315   return string_upcase_x (str);
 316 }
 317 #undef FUNC_NAME
 318
 319
 320 SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0,
 321             (SCM str),
 322             "Return a freshly allocated string containing the characters of\n"
 323             "@var{str} in upper case.")
 324 #define FUNC_NAME s_scm_string_upcase
 325 {
 326   SCM_VALIDATE_STRING (1, str);
 327
 328   return string_upcase_x (string_copy (str));
 329 }
 330 #undef FUNC_NAME
 331
 332
 333 /* Helper function for the string lowercase conversion functions.
 334  * No argument checking is performed.  */
 335 static SCM
 336 string_downcase_x (SCM v)
 337 {
 338   unsigned long k;
 339
 340   for (k = 0; k < SCM_STRING_LENGTH (v); ++k)
 341     SCM_STRING_UCHARS (v) [k] = scm_c_downcase (SCM_STRING_UCHARS (v) [k]);
 342
 343   return v;
 344 }
 345
 346
 347 SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0,
 348             (SCM str),
 349             "Destructively downcase every character in @var{str} and return\n"
 350             "@var{str}.\n"
 351             "@lisp\n"
 352             "y                     @result{} \"ARRDEFG\"\n"
 353             "(string-downcase! y)  @result{} \"arrdefg\"\n"
 354             "y                     @result{} \"arrdefg\"\n"
 355             "@end lisp")
 356 #define FUNC_NAME s_scm_string_downcase_x
 357 {
 358   SCM_VALIDATE_STRING (1, str);
 359
 360   return string_downcase_x (str);
 361 }
 362 #undef FUNC_NAME
 363
 364
 365 SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0,
 366             (SCM str),
 367             "Return a freshly allocation string containing the characters in\n"
 368             "@var{str} in lower case.")
 369 #define FUNC_NAME s_scm_string_downcase
 370 {
 371   SCM_VALIDATE_STRING (1, str);
 372
 373   return string_downcase_x (string_copy (str));
 374 }
 375 #undef FUNC_NAME
 376
 377
 378 /* Helper function for the string capitalization functions.
 379  * No argument checking is performed.  */
 380 static SCM
 381 string_capitalize_x (SCM str)
 382 {
 383   unsigned char *sz;
 384   long i, len;
 385   int in_word=0;
 386
 387   len = SCM_STRING_LENGTH(str);
 388   sz = SCM_STRING_UCHARS (str);
 389   for(i=0; i<len;  i++) {
 390     if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i])))) {
 391       if(!in_word) {
 392         sz[i] = scm_c_upcase(sz[i]);
 393         in_word = 1;
 394       } else {
 395         sz[i] = scm_c_downcase(sz[i]);
 396       }
 397     }
 398     else in_word = 0;
 399   }
 400   return str;
 401 }
 402
 403
 404 SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
 405             (SCM str),
 406             "Upcase the first character of every word in @var{str}\n"
 407             "destructively and return @var{str}.\n"
 408             "\n"
 409             "@lisp\n"
 410             "y                      @result{} \"hello world\"\n"
 411             "(string-capitalize! y) @result{} \"Hello World\"\n"
 412             "y                      @result{} \"Hello World\"\n"
 413             "@end lisp")
 414 #define FUNC_NAME s_scm_string_capitalize_x
 415 {
 416   SCM_VALIDATE_STRING (1, str);
 417
 418   return string_capitalize_x (str);
 419 }
 420 #undef FUNC_NAME
 421
 422
 423 SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
 424             (SCM str),
 425             "Return a freshly allocated string with the characters in\n"
 426             "@var{str}, where the first character of every word is\n"
 427             "capitalized.")
 428 #define FUNC_NAME s_scm_string_capitalize
 429 {
 430   SCM_VALIDATE_STRING (1, str);
 431
 432   return string_capitalize_x (string_copy (str));
 433 }
 434 #undef FUNC_NAME
 435
 436
 437 SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
 438             (SCM str, SCM chr),
 439             "Split the string @var{str} into the a list of the substrings delimited\n"
 440             "by appearances of the character @var{chr}.  Note that an empty substring\n"
 441             "between separator characters will result in an empty string in the\n"
 442             "result list.\n"
 443             "\n"
 444             "@lisp\n"
 445             "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
 446             "@result{}\n"
 447             "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
 448             "\n"
 449             "(string-split \"::\" #\\:)\n"
 450             "@result{}\n"
 451             "(\"\" \"\" \"\")\n"
 452             "\n"
 453             "(string-split \"\" #\\:)\n"
 454             "@result{}\n"
 455             "(\"\")\n"
 456             "@end lisp")
 457 #define FUNC_NAME s_scm_string_split
 458 {
 459   long idx, last_idx;
 460   char * p;
 461   int ch;
 462   SCM res = SCM_EOL;
 463
 464   SCM_VALIDATE_STRING (1, str);
 465   SCM_VALIDATE_CHAR (2, chr);
 466
 467   idx = SCM_STRING_LENGTH (str);
 468   p = SCM_STRING_CHARS (str);
 469   ch = SCM_CHAR (chr);
 470   while (idx >= 0)
 471     {
 472       last_idx = idx;
 473       while (idx > 0 && p[idx - 1] != ch)
 474         idx--;
 475       if (idx >= 0)
 476         {
 477           res = scm_cons (scm_mem2string (p + idx, last_idx - idx), res);
 478           idx--;
 479         }
 480     }
 481   scm_remember_upto_here_1 (str);
 482   return res;
 483 }
 484 #undef FUNC_NAME
 485
 486
 487 SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
 488             (SCM str),
 489             "Return the symbol whose name is @var{str}.  @var{str} is\n"
 490             "converted to lowercase before the conversion is done, if Guile\n"
 491             "is currently reading symbols case-insensitively.")
 492 #define FUNC_NAME s_scm_string_ci_to_symbol
 493 {
 494   return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
 495                                ? scm_string_downcase(str)
 496                                : str);
 497 }
 498 #undef FUNC_NAME
 499
 500 void
 501 scm_init_strop ()
 502 {
 503 #include "libguile/strop.x"
 504 }
 505
 506 /*
 507   Local Variables:
 508   c-file-style: "gnu"
 509   End:
 510 */