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