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 /* Helper function for the string copy and string conversion functions.
 334  * No argument checking is performed.  */
 335 static SCM
 336 string_copy (SCM str)
 337 {
 338   return scm_makfromstr (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), 0);
 339 }
 340
 341
 342 SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0,
 343             (SCM str),
 344             "Returns a newly allocated copy of the given @var{string}. (r5rs)")
 345 #define FUNC_NAME s_scm_string_copy
 346 {
 347   SCM_VALIDATE_STRING (1, str);
 348
 349   return string_copy (str);
 350 }
 351 #undef FUNC_NAME
 352
 353
 354 SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0,
 355            (SCM str, SCM chr),
 356             "Stores @var{char} in every element of the given @var{string} and returns an\n"
 357             "unspecified value.  (r5rs)")
 358 #define FUNC_NAME s_scm_string_fill_x
 359 {
 360   register char *dst, c;
 361   register long k;
 362   SCM_VALIDATE_STRING_COPY (1,str,dst);
 363   SCM_VALIDATE_CHAR_COPY (2,chr,c);
 364   for (k = SCM_STRING_LENGTH (str)-1;k >= 0;k--) dst[k] = c;
 365   return SCM_UNSPECIFIED;
 366 }
 367 #undef FUNC_NAME
 368
 369
 370 /* Helper function for the string uppercase conversion functions.
 371  * No argument checking is performed.  */
 372 static SCM
 373 string_upcase_x (SCM v)
 374 {
 375   unsigned long k;
 376
 377   for (k = 0; k < SCM_STRING_LENGTH (v); ++k)
 378     SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]);
 379
 380   return v;
 381 }
 382
 383
 384 SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0,
 385             (SCM str),
 386             "Destructively upcase every character in @code{str}.\n\n"
 387             "(qdocs:) Converts each element in @var{str} to upper case.\n\n"
 388             "@example\n"
 389             "(string-upcase! y)\n"
 390             "@result{} \"ARRDEFG\"\n\n"
 391             "y\n"
 392             "@result{} \"ARRDEFG\"\n"
 393             "@end example")
 394 #define FUNC_NAME s_scm_string_upcase_x
 395 {
 396   SCM_VALIDATE_STRING (1, str);
 397
 398   return string_upcase_x (str);
 399 }
 400 #undef FUNC_NAME
 401
 402
 403 SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0,
 404             (SCM str),
 405             "Upcase every character in @code{str}.")
 406 #define FUNC_NAME s_scm_string_upcase
 407 {
 408   SCM_VALIDATE_STRING (1, str);
 409
 410   return string_upcase_x (string_copy (str));
 411 }
 412 #undef FUNC_NAME
 413
 414
 415 /* Helper function for the string lowercase conversion functions.
 416  * No argument checking is performed.  */
 417 static SCM
 418 string_downcase_x (SCM v)
 419 {
 420   unsigned long k;
 421
 422   for (k = 0; k < SCM_STRING_LENGTH (v); ++k)
 423     SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]);
 424
 425   return v;
 426 }
 427
 428
 429 SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0,
 430             (SCM str),
 431             "Destructively downcase every character in @code{str}.\n\n"
 432             "(qdocs:) Converts each element in @var{str} to lower case.\n\n"
 433             "@example\n"
 434             "y\n"
 435             "@result{} \"ARRDEFG\"\n\n"
 436             "(string-downcase! y)\n"
 437             "@result{} \"arrdefg\"\n\n"
 438             "y\n"
 439             "@result{} \"arrdefg\"\n"
 440             "@end example")
 441 #define FUNC_NAME s_scm_string_downcase_x
 442 {
 443   SCM_VALIDATE_STRING (1, str);
 444
 445   return string_downcase_x (str);
 446 }
 447 #undef FUNC_NAME
 448
 449
 450 SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0,
 451             (SCM str),
 452             "Downcase every character in @code{str}.")
 453 #define FUNC_NAME s_scm_string_downcase
 454 {
 455   SCM_VALIDATE_STRING (1, str);
 456
 457   return string_downcase_x (string_copy (str));
 458 }
 459 #undef FUNC_NAME
 460
 461
 462 /* Helper function for the string capitalization functions.
 463  * No argument checking is performed.  */
 464 static SCM
 465 string_capitalize_x (SCM str)
 466 {
 467   char *sz;
 468   int i, len, in_word=0;
 469
 470   len = SCM_STRING_LENGTH(str);
 471   sz = SCM_STRING_CHARS (str);
 472   for(i=0; i<len;  i++) {
 473     if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKE_CHAR(sz[i])))) {
 474       if(!in_word) {
 475         sz[i] = scm_upcase(sz[i]);
 476         in_word = 1;
 477       } else {
 478         sz[i] = scm_downcase(sz[i]);
 479       }
 480     }
 481     else in_word = 0;
 482   }
 483   return str;
 484 }
 485
 486
 487 SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
 488             (SCM str),
 489             "Destructively capitalize every character in @code{str}.")
 490 #define FUNC_NAME s_scm_string_capitalize_x
 491 {
 492   SCM_VALIDATE_STRING (1, str);
 493
 494   return string_capitalize_x (str);
 495 }
 496 #undef FUNC_NAME
 497
 498
 499 SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
 500             (SCM str),
 501             "Capitalize every character in @code{str}.")
 502 #define FUNC_NAME s_scm_string_capitalize
 503 {
 504   SCM_VALIDATE_STRING (1, str);
 505
 506   return string_capitalize_x (string_copy (str));
 507 }
 508 #undef FUNC_NAME
 509
 510
 511 SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
 512            (SCM str),
 513             "Return the symbol whose name is @var{str}, downcased in necessary(???).")
 514 #define FUNC_NAME s_scm_string_ci_to_symbol
 515 {
 516   return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
 517                                ? scm_string_downcase(str)
 518                                : str);
 519 }
 520 #undef FUNC_NAME
 521
 522 void
 523 scm_init_strop ()
 524 {
 525 #ifndef SCM_MAGIC_SNARFER
 526 #include "libguile/strop.x"
 527 #endif
 528 }
 529
 530 /*
 531   Local Variables:
 532   c-file-style: "gnu"
 533   End:
 534 */