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