libguile/strop.c

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