libguile/strop.c

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