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