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