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
  34 #ifdef HAVE_STRING_H
  35 #include <string.h>
  36 #endif
  37
  38 \f
  39
  40 /*
  41 xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0,
  42            (SCM str, SCM chr, SCM frm, SCM to),
  43            "@deftypefn {Internal C Function} {static int} scm_i_index (SCM *@var{str}, \n"
  44            "SCM @var{chr}, int @var{direction}, SCM @var{sub_start}, SCM @var{sub_end}, char *@var{why})
  45            "This is a workhorse function that performs either an @code{index} or\n"
  46            "@code{rindex} function, depending on the value of @var{direction}. I'm\n"
  47            "not at all clear on the usage of the pos arguments, though the purpose\n"
  48            "seems to be correct reporting of which argument values are reporting\n"
  49            "errors. Why you would do that, rather than just use @code{SCM_ARG[1234]}\n"
  50            "explicitly is beyond me. Anyone holding any enlightenment?"
  51 */
  52 /* implements index if direction > 0 otherwise rindex.  */
  53 static int
  54 scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start,
  55              SCM sub_end, const char *why)
  56 {
  57   unsigned char * p;
  58   int x;
  59   int lower;
  60   int upper;
  61   int ch;
  62
  63   SCM_ASSERT (SCM_ROSTRINGP (*str), *str, SCM_ARG1, why);
  64   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, why);
  65
  66   if (sub_start == SCM_BOOL_F)
  67     sub_start = SCM_MAKINUM (0);
  68
  69   SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why);
  70   lower = SCM_INUM (sub_start);
  71   if (lower < 0
  72       || lower > SCM_ROLENGTH (*str))
  73     scm_out_of_range (why, sub_start);
  74
  75   if (sub_end == SCM_BOOL_F)
  76     sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str));
  77
  78   SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why);
  79   upper = SCM_INUM (sub_end);
  80   if (upper < SCM_INUM (sub_start)
  81       || upper > SCM_ROLENGTH (*str))
  82     scm_out_of_range (why, sub_end);
  83
  84   if (direction > 0)
  85     {
  86       p = (unsigned char *)SCM_ROCHARS (*str) + lower;
  87       ch = SCM_ICHR (chr);
  88
  89       for (x = SCM_INUM (sub_start); x < upper; ++x, ++p)
  90         if (*p == ch)
  91           return x;
  92     }
  93   else
  94     {
  95       p = upper - 1 + (unsigned char *)SCM_ROCHARS (*str);
  96       ch = SCM_ICHR (chr);
  97       for (x = upper - 1; x >= lower; --x, --p)
  98         if (*p == ch)
  99           return x;
 100     }
 101
 102   return -1;
 103 }
 104
 105 SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
 106            (SCM str, SCM chr, SCM frm, SCM to),
 107             "Return the index of the first occurrence of @var{chr} in @var{str}.  The\n"
 108             "optional integer arguments @var{frm} and @var{to} limit the search to\n"
 109             "a portion of the string.  This procedure essentially implements the\n"
 110             "@code{index} or @code{strchr} functions from the C library.\n\n"
 111             "(qdocs:)  Returns the index of @var{char} in @var{str}, or @code{#f} if the\n"
 112             "@var{char} isn't in @var{str}. If @var{frm} is given and not @code{#f},\n"
 113             "it is used as the starting index; if @var{to} is given and not @var{#f},\n"
 114             "it is used as the ending index (exclusive).\n\n"
 115             "@example\n"
 116             "(string-index "weiner" #\e)\n"
 117             "@result{} 1\n\n"
 118             "(string-index "weiner" #\e 2)\n"
 119             "@result{} 4\n\n"
 120             "(string-index "weiner" #\e 2 4)\n"
 121             "@result{} #f\n"
 122             "@end example")
 123 #define FUNC_NAME s_scm_string_index
 124 {
 125   int pos;
 126
 127   if (frm == SCM_UNDEFINED)
 128     frm = SCM_BOOL_F;
 129   if (to == SCM_UNDEFINED)
 130     to = SCM_BOOL_F;
 131   pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME);
 132   return (pos < 0
 133           ? SCM_BOOL_F
 134           : SCM_MAKINUM (pos));
 135 }
 136 #undef FUNC_NAME
 137
 138 SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0,
 139            (SCM str, SCM chr, SCM frm, SCM to),
 140             "Like @code{string-index}, but search from the right of the string rather\n"
 141             "than from the left.  This procedure essentially implements the\n"
 142             "@code{rindex} or @code{strrchr} functions from the C library.\n\n"
 143             "(qdocs:) The same as @code{string-index}, except it gives the rightmost occurance\n"
 144             "of @var{char} in the range [@var{frm}, @var{to}-1], which defaults to\n"
 145             "the entire string.\n\n"
 146             "@example\n"
 147             "(string-rindex "weiner" #\e)\n"
 148             "@result{} 4\n\n"
 149             "(string-rindex "weiner" #\e 2 4)\n"
 150             "@result{} #f\n\n"
 151             "(string-rindex "weiner" #\e 2 5)\n"
 152             "@result{} 4\n"
 153             "@end example")
 154 #define FUNC_NAME s_scm_string_rindex
 155 {
 156   int pos;
 157
 158   if (frm == SCM_UNDEFINED)
 159     frm = SCM_BOOL_F;
 160   if (to == SCM_UNDEFINED)
 161     to = SCM_BOOL_F;
 162   pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME);
 163   return (pos < 0
 164           ? SCM_BOOL_F
 165           : SCM_MAKINUM (pos));
 166 }
 167 #undef FUNC_NAME
 168
 169
 170 SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
 171 SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
 172
 173 /*
 174 @defun substring-move-left! str1 start1 end1 str2 start2
 175 @end defun
 176 @deftypefn {C Function} SCM scm_substring_move_left_x (SCM @var{str1}, SCM @var{start1}, SCM @var{end1}, SCM @var{str2}, SCM @var{start2})
 177 [@strong{Note:} this is only valid if you've applied the strop patch].
 178
 179 Moves a substring of @var{str1}, from @var{start1} to @var{end1}
 180 (@var{end1} is exclusive), into @var{str2}, starting at
 181 @var{start2}. Allows overlapping strings.
 182
 183 @example
 184 (define x (make-string 10 #\a))
 185 (define y "bcd")
 186 (substring-move-left! x 2 5 y 0)
 187 y
 188 @result{} "aaa"
 189
 190 x
 191 @result{} "aaaaaaaaaa"
 192
 193 (define y "bcdefg")
 194 (substring-move-left! x 2 5 y 0)
 195 y
 196 @result{} "aaaefg"
 197
 198 (define y "abcdefg")
 199 (substring-move-left! y 2 5 y 3)
 200 y
 201 @result{} "abccccg"
 202 @end example
 203 */
 204
 205 /*
 206 @defun substring-move-right! str1 start1 end1 str2 start2
 207 @end defun
 208 @deftypefn {C Function} SCM scm_substring_move_right_x (SCM @var{str1}, SCM @var{start1}, SCM @var{end1}, SCM @var{str2}, SCM @var{start2})
 209 [@strong{Note:} this is only valid if you've applied the strop patch, if
 210 it hasn't made it into the guile tree].
 211
 212 Does much the same thing as @code{substring-move-left!}, except it
 213 starts moving at the end of the sequence, rather than the beginning.
 214 @example
 215 (define y "abcdefg")
 216 (substring-move-right! y 2 5 y 0)
 217 y
 218 @result{} "ededefg"
 219
 220 (define y "abcdefg")
 221 (substring-move-right! y 2 5 y 3)
 222 y
 223 @result{} "abccdeg"
 224 @end example
 225 */
 226
 227 SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0,
 228            (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
 229             "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
 230             "into @var{str2} beginning at position @var{end2}.\n"
 231             "@code{substring-move-right!} begins copying from the rightmost character\n"
 232             "and moves left, and @code{substring-move-left!} copies from the leftmost\n"
 233             "character moving right.\n\n"
 234             "It is useful to have two functions that copy in different directions so\n"
 235             "that substrings can be copied back and forth within a single string.  If\n"
 236             "you wish to copy text from the left-hand side of a string to the\n"
 237             "right-hand side of the same string, and the source and destination\n"
 238             "overlap, you must be careful to copy the rightmost characters of the\n"
 239             "text first, to avoid clobbering your data.  Hence, when @var{str1} and\n"
 240             "@var{str2} are the same string, you should use\n"
 241             "@code{substring-move-right!} when moving text from left to right, and\n"
 242             "@code{substring-move-left!}  otherwise.  If @code{str1} and @samp{str2}\n"
 243             "are different strings, it does not matter which function you use.")
 244 #define FUNC_NAME s_scm_substring_move_x
 245 {
 246   long s1, s2, e, len;
 247
 248   SCM_VALIDATE_STRING (1,str1);
 249   SCM_VALIDATE_INUM_COPY (2,start1,s1);
 250   SCM_VALIDATE_INUM_COPY (3,end1,e);
 251   SCM_VALIDATE_STRING (4,str2);
 252   SCM_VALIDATE_INUM_COPY (5,start2,s2);
 253   len = e - s1;
 254   SCM_ASSERT_RANGE (3,end1,len >= 0);
 255   SCM_ASSERT_RANGE (2,start1,s1 <= SCM_LENGTH (str1) && s1 >= 0);
 256   SCM_ASSERT_RANGE (5,start2,s2 <= SCM_LENGTH (str2) && s2 >= 0);
 257   SCM_ASSERT_RANGE (3,end1,e <= SCM_LENGTH (str1) && e >= 0);
 258   SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_LENGTH (str2));
 259
 260   SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2)[s2])),
 261                       (void *)(&(SCM_CHARS(str1)[s1])),
 262                       len));
 263
 264   return scm_return_first(SCM_UNSPECIFIED, str1, str2);
 265 }
 266 #undef FUNC_NAME
 267
 268
 269 SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0,
 270            (SCM str, SCM start, SCM end, SCM fill),
 271             "Change every character in @var{str} between @var{start} and @var{end} to\n"
 272             "@var{fill-char}.\n\n"
 273             "(qdocs:) Destructively fills @var{str}, from @var{start} to @var{end}, with @var{fill}.\n\n"
 274             "@example\n"
 275             "(define y \"abcdefg\")\n"
 276             "(substring-fill! y 1 3 #\r)\n"
 277             "y\n"
 278             "@result{} \"arrdefg\"\n"
 279             "@end example")
 280 #define FUNC_NAME s_scm_substring_fill_x
 281 {
 282   long i, e;
 283   char c;
 284   SCM_VALIDATE_STRING (1,str);
 285   SCM_VALIDATE_INUM_COPY (2,start,i);
 286   SCM_VALIDATE_INUM_COPY (3,end,e);
 287   SCM_VALIDATE_ICHR_COPY (4,fill,c);
 288   SCM_ASSERT_RANGE (2,start,i <= SCM_LENGTH (str) && i >= 0);
 289   SCM_ASSERT_RANGE (3,end,e <= SCM_LENGTH (str) && e >= 0);
 290   while (i<e) SCM_CHARS (str)[i++] = c;
 291   return SCM_UNSPECIFIED;
 292 }
 293 #undef FUNC_NAME
 294
 295
 296 SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0,
 297            (SCM str),
 298             "Return @code{#t} if @var{str}'s length is nonzero, and @code{#f}\n"
 299             "otherwise.\n\n"
 300             "(qdocs:) Returns @code{#t} if @var{str} is empty, else returns @code{#f}.\n\n"
 301             "@example\n"
 302             "(string-null? \"\")\n"
 303             "@result{} #t\n\n"
 304             "(string-null? y)\n"
 305             "@result{} #f\n"
 306             "@end example")
 307 #define FUNC_NAME s_scm_string_null_p
 308 {
 309   SCM_VALIDATE_ROSTRING (1,str);
 310   return SCM_NEGATE_BOOL(SCM_ROLENGTH (str));
 311 }
 312 #undef FUNC_NAME
 313
 314
 315 SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0,
 316            (SCM str),
 317             "@samp{String->list} returns a newly allocated list of the\n"
 318             "characters that make up the given string.  @samp{List->string}\n"
 319             "returns a newly allocated string formed from the characters in the list\n"
 320             "@var{list}, which must be a list of characters. @samp{String->list}\n"
 321             "and @samp{list->string} are\n"
 322             "inverses so far as @samp{equal?} is concerned.  (r5rs)")
 323 #define FUNC_NAME s_scm_string_to_list
 324 {
 325   long i;
 326   SCM res = SCM_EOL;
 327   unsigned char *src;
 328   SCM_VALIDATE_ROSTRING (1,str);
 329   src = SCM_ROUCHARS (str);
 330   for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res);
 331   return res;
 332 }
 333 #undef FUNC_NAME
 334
 335
 336
 337 SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0,
 338            (SCM str),
 339             "Returns a newly allocated copy of the given @var{string}. (r5rs)")
 340 #define FUNC_NAME s_scm_string_copy
 341 {
 342   SCM_VALIDATE_STRINGORSUBSTR (1,str);
 343   return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0);
 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             "Stores @var{char} in every element of the given @var{string} and returns an\n"
 351             "unspecified value.  (r5rs)")
 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_ICHR_COPY (2,chr,c);
 358   for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c;
 359   return SCM_UNSPECIFIED;
 360 }
 361 #undef FUNC_NAME
 362
 363 SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0,
 364            (SCM v),
 365             "Destructively upcase every character in @code{str}.\n\n"
 366             "(qdocs:) Converts each element in @var{str} to upper case.\n\n"
 367             "@example\n"
 368             "(string-upcase! y)\n"
 369             "@result{} \"ARRDEFG\"\n\n"
 370             "y\n"
 371             "@result{} \"ARRDEFG\"\n"
 372             "@end example")
 373 #define FUNC_NAME s_scm_string_upcase_x
 374 {
 375   register long k;
 376   register unsigned char *cs;
 377   SCM_ASRTGO (SCM_NIMP (v), badarg1);
 378   k = SCM_LENGTH (v);
 379   switch SCM_TYP7
 380     (v)
 381     {
 382     case scm_tc7_string:
 383       cs = SCM_UCHARS (v);
 384       while (k--)
 385         cs[k] = scm_upcase(cs[k]);
 386       break;
 387     default:
 388     badarg1:SCM_WTA (1,v);
 389     }
 390   return v;
 391 }
 392 #undef FUNC_NAME
 393
 394 SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0,
 395            (SCM str),
 396             "Upcase every character in @code{str}.")
 397 #define FUNC_NAME s_scm_string_upcase
 398 {
 399   return scm_string_upcase_x(scm_string_copy(str));
 400 }
 401 #undef FUNC_NAME
 402
 403 SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0,
 404            (SCM v),
 405             "Destructively downcase every character in @code{str}.\n\n"
 406             "(qdocs:) Converts each element in @var{str} to lower case.\n\n"
 407             "@example\n"
 408             "y\n"
 409             "@result{} \"ARRDEFG\"\n\n"
 410             "(string-downcase! y)\n"
 411             "@result{} \"arrdefg\"\n\n"
 412             "y\n"
 413             "@result{} \"arrdefg\"\n"
 414             "@end example")
 415 #define FUNC_NAME s_scm_string_downcase_x
 416 {
 417   register long k;
 418   register unsigned char *cs;
 419   SCM_ASRTGO (SCM_NIMP (v), badarg1);
 420   k = SCM_LENGTH (v);
 421   switch (SCM_TYP7(v))
 422     {
 423       case scm_tc7_string:
 424         cs = SCM_UCHARS (v);
 425         while (k--)
 426           cs[k] = scm_downcase(cs[k]);
 427         break;
 428       default:
 429     badarg1:SCM_WTA (1,v);
 430     }
 431   return v;
 432 }
 433 #undef FUNC_NAME
 434
 435 SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0,
 436            (SCM str),
 437             "Downcase every character in @code{str}.")
 438 #define FUNC_NAME s_scm_string_downcase
 439 {
 440   SCM_VALIDATE_STRING (1,str);
 441   return scm_string_downcase_x(scm_string_copy(str));
 442 }
 443 #undef FUNC_NAME
 444
 445 SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
 446            (SCM str),
 447             "Destructively capitalize every character in @code{str}.")
 448 #define FUNC_NAME s_scm_string_capitalize_x
 449 {
 450   char *sz;
 451   int i, len, in_word=0;
 452   SCM_VALIDATE_STRING (1,str);
 453   len = SCM_LENGTH(str);
 454   sz = SCM_CHARS(str);
 455   for(i=0; i<len;  i++) {
 456     if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKICHR(sz[i])))) {
 457       if(!in_word) {
 458         sz[i] = scm_upcase(sz[i]);
 459         in_word = 1;
 460       } else {
 461         sz[i] = scm_downcase(sz[i]);
 462       }
 463     }
 464     else in_word = 0;
 465   }
 466   return str;
 467 }
 468 #undef FUNC_NAME
 469
 470 SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
 471            (SCM str),
 472             "Capitalize every character in @code{str}.")
 473 #define FUNC_NAME s_scm_string_capitalize
 474 {
 475   SCM_VALIDATE_STRING (1,str);
 476   return scm_string_capitalize_x(scm_string_copy(str));
 477 }
 478 #undef FUNC_NAME
 479
 480 SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
 481            (SCM str),
 482             "Return the symbol whose name is @var{str}, downcased in necessary(???).")
 483 #define FUNC_NAME s_scm_string_ci_to_symbol
 484 {
 485   return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
 486                                ? scm_string_downcase(str)
 487                                : str);
 488 }
 489 #undef FUNC_NAME
 490
 491 void
 492 scm_init_strop ()
 493 {
 494 #include "strop.x"
 495 }