libguile/strings.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001, 2004 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18
  19 \f
  20
  21 #include <string.h>
  22 #include <stdio.h>
  23
  24 #include "libguile/_scm.h"
  25 #include "libguile/chars.h"
  26 #include "libguile/root.h"
  27 #include "libguile/strings.h"
  28 #include "libguile/deprecation.h"
  29 #include "libguile/validate.h"
  30 #include "libguile/dynwind.h"
  31
  32 \f
  33
  34 /* {Strings}
  35  */
  36
  37
  38 /* Stringbufs
  39  *
  40  * XXX - keeping an accurate refcount during GC seems to be quite
  41  * tricky, so we just keep score of whether a stringbuf might be
  42  * shared, not wether it definitely is.
  43  *
  44  * The scheme I (mvo) tried to keep an accurate reference count would
  45  * recount all strings that point to a stringbuf during the mark-phase
  46  * of the GC.  This was done since one cannot access the stringbuf of
  47  * a string when that string is freed (in order to decrease the
  48  * reference count).  The memory of the stringbuf might have been
  49  * reused already for something completely different.
  50  *
  51  * This recounted worked for a small number of threads beating on
  52  * cow-strings, but it failed randomly with more than 10 threads, say.
  53  * I couldn't figure out what went wrong, so I used the conservative
  54  * approach implemented below.
  55  *
  56  * A stringbuf needs to know its length, but only so that it can be
  57  * reported when the stringbuf is freed.
  58  *
  59  * Stringbufs (and strings) are not stored very compactly: a stringbuf
  60  * has room for about 2*sizeof(scm_t_bits)-1 bytes additional
  61  * information.  As a compensation, the code below is made more
  62  * complicated by storing small strings inline in the double cell of a
  63  * stringbuf.  So we have fixstrings and bigstrings...
  64  */
  65
  66 #define STRINGBUF_F_SHARED      0x100
  67 #define STRINGBUF_F_INLINE      0x200
  68
  69 #define STRINGBUF_TAG           scm_tc7_stringbuf
  70 #define STRINGBUF_SHARED(buf)   (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
  71 #define STRINGBUF_INLINE(buf)   (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
  72
  73 #define STRINGBUF_OUTLINE_CHARS(buf)   ((char *)SCM_CELL_WORD_1(buf))
  74 #define STRINGBUF_OUTLINE_LENGTH(buf)  (SCM_CELL_WORD_2(buf))
  75 #define STRINGBUF_INLINE_CHARS(buf)    ((char *)SCM_CELL_OBJECT_LOC(buf,1))
  76 #define STRINGBUF_INLINE_LENGTH(buf)   (((size_t)SCM_CELL_WORD_0(buf))>>16)
  77
  78 #define STRINGBUF_CHARS(buf)  (STRINGBUF_INLINE (buf) \
  79                                ? STRINGBUF_INLINE_CHARS (buf) \
  80                                : STRINGBUF_OUTLINE_CHARS (buf))
  81 #define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
  82                                ? STRINGBUF_INLINE_LENGTH (buf) \
  83                                : STRINGBUF_OUTLINE_LENGTH (buf))
  84
  85 #define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))
  86
  87 #define SET_STRINGBUF_SHARED(buf) \
  88   (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
  89
  90 #if SCM_DEBUG
  91 static size_t lenhist[1001];
  92 #endif
  93
  94 static SCM
  95 make_stringbuf (size_t len)
  96 {
  97   /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and
  98      scm_i_symbol_chars, all stringbufs are null-terminated.  Once
  99      SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code
 100      has been changed for scm_i_symbol_chars, this null-termination
 101      can be dropped.
 102   */
 103
 104 #if SCM_DEBUG
 105   if (len < 1000)
 106     lenhist[len]++;
 107   else
 108     lenhist[1000]++;
 109 #endif
 110
 111   if (len <= STRINGBUF_MAX_INLINE_LEN-1)
 112     {
 113       return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16),
 114                               0, 0, 0);
 115     }
 116   else
 117     {
 118       char *mem = scm_gc_malloc (len+1, "string");
 119       mem[len] = '\0';
 120       return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem,
 121                               (scm_t_bits) len, (scm_t_bits) 0);
 122     }
 123 }
 124
 125 SCM
 126 scm_i_stringbuf_mark (SCM buf)
 127 {
 128   return SCM_BOOL_F;
 129 }
 130
 131 void
 132 scm_i_stringbuf_free (SCM buf)
 133 {
 134   if (!STRINGBUF_INLINE (buf))
 135     scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
 136                  STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
 137 }
 138
 139 SCM_MUTEX (stringbuf_write_mutex);
 140
 141 /* Copy-on-write strings.
 142  */
 143
 144 #define STRING_TAG            scm_tc7_string
 145
 146 #define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
 147 #define STRING_START(str)     ((size_t)SCM_CELL_WORD_2(str))
 148 #define STRING_LENGTH(str)    ((size_t)SCM_CELL_WORD_3(str))
 149
 150 #define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
 151 #define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
 152
 153 #define IS_STRING(str)        (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
 154
 155 /* Mutation-sharing substrings
 156  */
 157
 158 #define SH_STRING_TAG       (scm_tc7_string + 0x100)
 159
 160 #define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
 161 /* START and LENGTH as for STRINGs. */
 162
 163 #define IS_SH_STRING(str)   (SCM_CELL_TYPE(str)==SH_STRING_TAG)
 164
 165 SCM
 166 scm_i_make_string (size_t len, char **charsp)
 167 {
 168   SCM buf = make_stringbuf (len);
 169   SCM res;
 170   if (charsp)
 171     *charsp = STRINGBUF_CHARS (buf);
 172   res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
 173                          (scm_t_bits)0, (scm_t_bits) len);
 174   return res;
 175 }
 176
 177 static void
 178 validate_substring_args (SCM str, size_t start, size_t end)
 179 {
 180   if (!IS_STRING (str))
 181     scm_wrong_type_arg_msg (NULL, 0, str, "string");
 182   if (start > STRING_LENGTH (str))
 183     scm_out_of_range (NULL, scm_from_size_t (start));
 184   if (end > STRING_LENGTH (str) || end < start)
 185     scm_out_of_range (NULL, scm_from_size_t (end));
 186 }
 187
 188 static inline void
 189 get_str_buf_start (SCM *str, SCM *buf, size_t *start)
 190 {
 191   *start = STRING_START (*str);
 192   if (IS_SH_STRING (*str))
 193     {
 194       *str = SH_STRING_STRING (*str);
 195       *start += STRING_START (*str);
 196     }
 197   *buf = STRING_STRINGBUF (*str);
 198 }
 199
 200 SCM
 201 scm_i_substring (SCM str, size_t start, size_t end)
 202 {
 203   SCM buf;
 204   size_t str_start;
 205   get_str_buf_start (&str, &buf, &str_start);
 206   scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
 207   SET_STRINGBUF_SHARED (buf);
 208   scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
 209   return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
 210                           (scm_t_bits)str_start + start,
 211                           (scm_t_bits) end - start);
 212 }
 213
 214 SCM
 215 scm_i_substring_copy (SCM str, size_t start, size_t end)
 216 {
 217   size_t len = end - start;
 218   SCM buf, my_buf;
 219   size_t str_start;
 220   get_str_buf_start (&str, &buf, &str_start);
 221   my_buf = make_stringbuf (len);
 222   memcpy (STRINGBUF_CHARS (my_buf),
 223           STRINGBUF_CHARS (buf) + str_start + start, len);
 224   scm_remember_upto_here_1 (buf);
 225   return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
 226                           (scm_t_bits)0, (scm_t_bits) len);
 227 }
 228
 229 SCM
 230 scm_i_substring_shared (SCM str, size_t start, size_t end)
 231 {
 232   if (start == 0 && end == STRING_LENGTH (str))
 233     return str;
 234   else
 235     {
 236       size_t len = end - start;
 237       if (IS_SH_STRING (str))
 238         {
 239           start += STRING_START (str);
 240           str = SH_STRING_STRING (str);
 241         }
 242       return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str),
 243                               (scm_t_bits)start, (scm_t_bits) len);
 244     }
 245 }
 246
 247 SCM
 248 scm_c_substring (SCM str, size_t start, size_t end)
 249 {
 250   validate_substring_args (str, start, end);
 251   return scm_i_substring (str, start, end);
 252 }
 253
 254 SCM
 255 scm_c_substring_copy (SCM str, size_t start, size_t end)
 256 {
 257   validate_substring_args (str, start, end);
 258   return scm_i_substring_copy (str, start, end);
 259 }
 260
 261 SCM
 262 scm_c_substring_shared (SCM str, size_t start, size_t end)
 263 {
 264   validate_substring_args (str, start, end);
 265   return scm_i_substring_shared (str, start, end);
 266 }
 267
 268 SCM
 269 scm_i_string_mark (SCM str)
 270 {
 271   if (IS_SH_STRING (str))
 272     return SH_STRING_STRING (str);
 273   else
 274     return STRING_STRINGBUF (str);
 275 }
 276
 277 void
 278 scm_i_string_free (SCM str)
 279 {
 280 }
 281
 282 /* Internal accessors
 283  */
 284
 285 size_t
 286 scm_i_string_length (SCM str)
 287 {
 288   return STRING_LENGTH (str);
 289 }
 290
 291 const char *
 292 scm_i_string_chars (SCM str)
 293 {
 294   SCM buf;
 295   size_t start;
 296   get_str_buf_start (&str, &buf, &start);
 297   return STRINGBUF_CHARS (buf) + start;
 298 }
 299
 300 char *
 301 scm_i_string_writable_chars (SCM str)
 302 {
 303   SCM buf;
 304   size_t start;
 305   get_str_buf_start (&str, &buf, &start);
 306   scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
 307   if (STRINGBUF_SHARED (buf))
 308     {
 309       /* Clone stringbuf.  For this, we put all threads to sleep.
 310        */
 311
 312       size_t len = STRING_LENGTH (str);
 313       SCM new_buf;
 314
 315       scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
 316
 317       new_buf = make_stringbuf (len);
 318       memcpy (STRINGBUF_CHARS (new_buf),
 319               STRINGBUF_CHARS (buf) + STRING_START (str), len);
 320
 321       scm_i_thread_put_to_sleep ();
 322       SET_STRING_STRINGBUF (str, new_buf);
 323       start -= STRING_START (str);
 324       SET_STRING_START (str, 0);
 325       scm_i_thread_wake_up ();
 326
 327       buf = new_buf;
 328
 329       scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
 330     }
 331
 332   return STRINGBUF_CHARS (buf) + start;
 333 }
 334
 335 void
 336 scm_i_string_stop_writing (void)
 337 {
 338   scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
 339 }
 340
 341 /* Symbols.
 342
 343    Basic symbol creation and accessing is done here, the rest is in
 344    symbols.[hc].  This has been done to keep stringbufs and the
 345    internals of strings and string-like objects confined to this file.
 346 */
 347
 348 #define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
 349
 350 SCM
 351 scm_i_make_symbol (SCM name, scm_t_bits flags,
 352                    unsigned long hash, SCM props)
 353 {
 354   SCM buf;
 355   size_t start = STRING_START (name);
 356   size_t length = STRING_LENGTH (name);
 357
 358   if (IS_SH_STRING (name))
 359     {
 360       name = SH_STRING_STRING (name);
 361       start += STRING_START (name);
 362     }
 363   buf = SYMBOL_STRINGBUF (name);
 364
 365   if (start == 0 && length == STRINGBUF_LENGTH (buf))
 366     {
 367       /* reuse buf. */
 368       scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
 369       SET_STRINGBUF_SHARED (buf);
 370       scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
 371     }
 372   else
 373     {
 374       /* make new buf. */
 375       SCM new_buf = make_stringbuf (length);
 376       memcpy (STRINGBUF_CHARS (new_buf),
 377               STRINGBUF_CHARS (buf) + start, length);
 378       buf = new_buf;
 379     }
 380   return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
 381                           (scm_t_bits) hash, SCM_UNPACK (props));
 382 }
 383
 384 size_t
 385 scm_i_symbol_length (SCM sym)
 386 {
 387   return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
 388 }
 389
 390 const char *
 391 scm_i_symbol_chars (SCM sym)
 392 {
 393   SCM buf = SYMBOL_STRINGBUF (sym);
 394   return STRINGBUF_CHARS (buf);
 395 }
 396
 397 SCM
 398 scm_i_symbol_mark (SCM sym)
 399 {
 400   scm_gc_mark (SYMBOL_STRINGBUF (sym));
 401   return SCM_CELL_OBJECT_3 (sym);
 402 }
 403
 404 void
 405 scm_i_symbol_free (SCM sym)
 406 {
 407 }
 408
 409 SCM
 410 scm_i_symbol_substring (SCM sym, size_t start, size_t end)
 411 {
 412   SCM buf = SYMBOL_STRINGBUF (sym);
 413   scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
 414   SET_STRINGBUF_SHARED (buf);
 415   scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
 416   return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
 417                           (scm_t_bits)start, (scm_t_bits) end - start);
 418 }
 419
 420 /* Debugging
 421  */
 422
 423 #if SCM_DEBUG
 424
 425 SCM scm_sys_string_dump (SCM);
 426 SCM scm_sys_symbol_dump (SCM);
 427 SCM scm_sys_stringbuf_hist (void);
 428
 429 SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
 430             (SCM str),
 431             "")
 432 #define FUNC_NAME s_scm_sys_string_dump
 433 {
 434   SCM_VALIDATE_STRING (1, str);
 435   fprintf (stderr, "%p:\n", str);
 436   fprintf (stderr, " start: %u\n", STRING_START (str));
 437   fprintf (stderr, " len:   %u\n", STRING_LENGTH (str));
 438   if (IS_SH_STRING (str))
 439     {
 440       fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
 441       fprintf (stderr, "\n");
 442       scm_sys_string_dump (SH_STRING_STRING (str));
 443     }
 444   else
 445     {
 446       SCM buf = STRING_STRINGBUF (str);
 447       fprintf (stderr, " buf:   %p\n", buf);
 448       fprintf (stderr, "  chars:  %p\n", STRINGBUF_CHARS (buf));
 449       fprintf (stderr, "  length: %u\n", STRINGBUF_LENGTH (buf));
 450       fprintf (stderr, "  flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
 451     }
 452   return SCM_UNSPECIFIED;
 453 }
 454 #undef FUNC_NAME
 455
 456 SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
 457             (SCM sym),
 458             "")
 459 #define FUNC_NAME s_scm_sys_symbol_dump
 460 {
 461   SCM_VALIDATE_SYMBOL (1, sym);
 462   fprintf (stderr, "%p:\n", sym);
 463   fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym));
 464   {
 465     SCM buf = SYMBOL_STRINGBUF (sym);
 466     fprintf (stderr, " buf: %p\n", buf);
 467     fprintf (stderr, "  chars:  %p\n", STRINGBUF_CHARS (buf));
 468     fprintf (stderr, "  length: %u\n", STRINGBUF_LENGTH (buf));
 469     fprintf (stderr, "  shared: %u\n", STRINGBUF_SHARED (buf));
 470   }
 471   return SCM_UNSPECIFIED;
 472 }
 473 #undef FUNC_NAME
 474
 475 SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
 476             (void),
 477             "")
 478 #define FUNC_NAME s_scm_sys_stringbuf_hist
 479 {
 480   int i;
 481   for (i = 0; i < 1000; i++)
 482     if (lenhist[i])
 483       fprintf (stderr, " %3d: %u\n", i, lenhist[i]);
 484   fprintf (stderr, ">999: %u\n", lenhist[1000]);
 485   return SCM_UNSPECIFIED;
 486 }
 487 #undef FUNC_NAME
 488
 489 #endif
 490
 491 \f
 492
 493 SCM_DEFINE (scm_string_p, "string?", 1, 0, 0,
 494             (SCM obj),
 495             "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
 496 #define FUNC_NAME s_scm_string_p
 497 {
 498   return scm_from_bool (IS_STRING (obj));
 499 }
 500 #undef FUNC_NAME
 501
 502
 503 SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);
 504
 505 SCM_DEFINE (scm_string, "string", 0, 0, 1,
 506             (SCM chrs),
 507             "@deffnx {Scheme Procedure} list->string chrs\n"
 508             "Return a newly allocated string composed of the arguments,\n"
 509             "@var{chrs}.")
 510 #define FUNC_NAME s_scm_string
 511 {
 512   SCM result;
 513   size_t len;
 514   char *data;
 515
 516   {
 517     long i = scm_ilength (chrs);
 518
 519     SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
 520     len = i;
 521   }
 522
 523   result = scm_i_make_string (len, &data);
 524   while (len > 0 && SCM_CONSP (chrs))
 525     {
 526       SCM elt = SCM_CAR (chrs);
 527
 528       SCM_VALIDATE_CHAR (SCM_ARGn, elt);
 529       *data++ = SCM_CHAR (elt);
 530       chrs = SCM_CDR (chrs);
 531       len--;
 532     }
 533   if (len > 0)
 534     scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
 535   if (!SCM_NULLP (chrs))
 536     scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
 537
 538   return result;
 539 }
 540 #undef FUNC_NAME
 541
 542 SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
 543             (SCM k, SCM chr),
 544             "Return a newly allocated string of\n"
 545             "length @var{k}.  If @var{chr} is given, then all elements of\n"
 546             "the string are initialized to @var{chr}, otherwise the contents\n"
 547             "of the @var{string} are unspecified.")
 548 #define FUNC_NAME s_scm_make_string
 549 {
 550   return scm_c_make_string (scm_to_size_t (k), chr);
 551 }
 552 #undef FUNC_NAME
 553
 554 SCM
 555 scm_c_make_string (size_t len, SCM chr)
 556 #define FUNC_NAME NULL
 557 {
 558   char *dst;
 559   SCM res = scm_i_make_string (len, &dst);
 560
 561   if (!SCM_UNBNDP (chr))
 562     {
 563       SCM_VALIDATE_CHAR (0, chr);
 564       memset (dst, SCM_CHAR (chr), len);
 565     }
 566
 567   return res;
 568 }
 569 #undef FUNC_NAME
 570
 571 SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
 572             (SCM string),
 573             "Return the number of characters in @var{string}.")
 574 #define FUNC_NAME s_scm_string_length
 575 {
 576   SCM_VALIDATE_STRING (1, string);
 577   return scm_from_size_t (STRING_LENGTH (string));
 578 }
 579 #undef FUNC_NAME
 580
 581 size_t
 582 scm_c_string_length (SCM string)
 583 {
 584   if (!IS_STRING (string))
 585     scm_wrong_type_arg_msg (NULL, 0, string, "string");
 586   return STRING_LENGTH (string);
 587 }
 588
 589 SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
 590             (SCM str, SCM k),
 591             "Return character @var{k} of @var{str} using zero-origin\n"
 592             "indexing. @var{k} must be a valid index of @var{str}.")
 593 #define FUNC_NAME s_scm_string_ref
 594 {
 595   unsigned long idx;
 596
 597   SCM_VALIDATE_STRING (1, str);
 598   idx = scm_to_unsigned_integer (k, 0, scm_i_string_length (str)-1);
 599   return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
 600 }
 601 #undef FUNC_NAME
 602
 603 SCM
 604 scm_c_string_ref (SCM str, size_t p)
 605 {
 606   if (p >= scm_i_string_length (str))
 607     scm_out_of_range (NULL, scm_from_size_t (p));
 608   return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
 609 }
 610
 611 SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
 612             (SCM str, SCM k, SCM chr),
 613             "Store @var{chr} in element @var{k} of @var{str} and return\n"
 614             "an unspecified value. @var{k} must be a valid index of\n"
 615             "@var{str}.")
 616 #define FUNC_NAME s_scm_string_set_x
 617 {
 618   unsigned long idx;
 619
 620   SCM_VALIDATE_STRING (1, str);
 621   idx = scm_to_unsigned_integer (k, 0, scm_i_string_length(str)-1);
 622   SCM_VALIDATE_CHAR (3, chr);
 623   {
 624     char *dst = scm_i_string_writable_chars (str);
 625     dst[idx] = SCM_CHAR (chr);
 626     scm_i_string_stop_writing ();
 627   }
 628   return SCM_UNSPECIFIED;
 629 }
 630 #undef FUNC_NAME
 631
 632 void
 633 scm_c_string_set_x (SCM str, size_t p, SCM chr)
 634 {
 635   if (p >= scm_i_string_length (str))
 636     scm_out_of_range (NULL, scm_from_size_t (p));
 637   {
 638     char *dst = scm_i_string_writable_chars (str);
 639     dst[p] = SCM_CHAR (chr);
 640     scm_i_string_stop_writing ();
 641   }
 642 }
 643
 644 SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
 645             (SCM str, SCM start, SCM end),
 646             "Return a newly allocated string formed from the characters\n"
 647             "of @var{str} beginning with index @var{start} (inclusive) and\n"
 648             "ending with index @var{end} (exclusive).\n"
 649             "@var{str} must be a string, @var{start} and @var{end} must be\n"
 650             "exact integers satisfying:\n\n"
 651             "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
 652 #define FUNC_NAME s_scm_substring
 653 {
 654   size_t len, from, to;
 655
 656   SCM_VALIDATE_STRING (1, str);
 657   len = scm_i_string_length (str);
 658   from = scm_to_unsigned_integer (start, 0, len);
 659   if (SCM_UNBNDP (end))
 660     to = len;
 661   else
 662     to = scm_to_unsigned_integer (end, from, len);
 663   return scm_i_substring (str, from, to);
 664 }
 665 #undef FUNC_NAME
 666
 667 SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0,
 668             (SCM str, SCM start, SCM end),
 669             "Return a newly allocated string formed from the characters\n"
 670             "of @var{str} beginning with index @var{start} (inclusive) and\n"
 671             "ending with index @var{end} (exclusive).\n"
 672             "@var{str} must be a string, @var{start} and @var{end} must be\n"
 673             "exact integers satisfying:\n\n"
 674             "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
 675 #define FUNC_NAME s_scm_substring_copy
 676 {
 677   /* For the Scheme version, START is mandatory, but for the C
 678      version, it is optional.  See scm_string_copy in srfi-13.c for a
 679      rationale.
 680   */
 681
 682   size_t from, to;
 683
 684   SCM_VALIDATE_STRING (1, str);
 685   scm_i_get_substring_spec (scm_i_string_length (str),
 686                             start, &from, end, &to);
 687   return scm_i_substring_copy (str, from, to);
 688 }
 689 #undef FUNC_NAME
 690
 691 SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
 692             (SCM str, SCM start, SCM end),
 693             "Return string that indirectly refers to the characters\n"
 694             "of @var{str} beginning with index @var{start} (inclusive) and\n"
 695             "ending with index @var{end} (exclusive).\n"
 696             "@var{str} must be a string, @var{start} and @var{end} must be\n"
 697             "exact integers satisfying:\n\n"
 698             "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
 699 #define FUNC_NAME s_scm_substring_shared
 700 {
 701   size_t len, from, to;
 702
 703   SCM_VALIDATE_STRING (1, str);
 704   len = scm_i_string_length (str);
 705   from = scm_to_unsigned_integer (start, 0, len);
 706   if (SCM_UNBNDP (end))
 707     to = len;
 708   else
 709     to = scm_to_unsigned_integer (end, from, len);
 710   return scm_i_substring_shared (str, from, to);
 711 }
 712 #undef FUNC_NAME
 713
 714 SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
 715             (SCM args),
 716             "Return a newly allocated string whose characters form the\n"
 717             "concatenation of the given strings, @var{args}.")
 718 #define FUNC_NAME s_scm_string_append
 719 {
 720   SCM res;
 721   size_t i = 0;
 722   SCM l, s;
 723   char *data;
 724
 725   SCM_VALIDATE_REST_ARGUMENT (args);
 726   for (l = args; !SCM_NULLP (l); l = SCM_CDR (l))
 727     {
 728       s = SCM_CAR (l);
 729       SCM_VALIDATE_STRING (SCM_ARGn, s);
 730       i += scm_i_string_length (s);
 731     }
 732   res = scm_i_make_string (i, &data);
 733   for (l = args; !SCM_NULLP (l); l = SCM_CDR (l))
 734     {
 735       size_t len;
 736       s = SCM_CAR (l);
 737       SCM_VALIDATE_STRING (SCM_ARGn, s);
 738       len = scm_i_string_length (s);
 739       memcpy (data, scm_i_string_chars (s), len);
 740       data += len;
 741       scm_remember_upto_here_1 (s);
 742     }
 743   return res;
 744 }
 745 #undef FUNC_NAME
 746
 747 int
 748 scm_is_string (SCM obj)
 749 {
 750   return IS_STRING (obj);
 751 }
 752
 753 SCM
 754 scm_from_locale_stringn (const char *str, size_t len)
 755 {
 756   SCM res;
 757   char *dst;
 758
 759   if (len == (size_t)-1)
 760     len = strlen (str);
 761   res = scm_i_make_string (len, &dst);
 762   memcpy (dst, str, len);
 763   return res;
 764 }
 765
 766 SCM
 767 scm_from_locale_string (const char *str)
 768 {
 769   return scm_from_locale_stringn (str, -1);
 770 }
 771
 772 SCM
 773 scm_take_locale_stringn (char *str, size_t len)
 774 {
 775   if (len == (size_t)-1)
 776     return scm_take_locale_string (str);
 777   else
 778     {
 779       /* STR might not be zero terminated and we are not allowed to
 780          look at str[len], so we have to make a new one...
 781       */
 782       SCM res = scm_from_locale_stringn (str, len);
 783       free (str);
 784       return res;
 785     }
 786 }
 787
 788 SCM
 789 scm_take_locale_string (char *str)
 790 {
 791   size_t len = strlen (str);
 792   SCM buf, res;
 793
 794   buf = scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
 795                          (scm_t_bits) len, (scm_t_bits) 0);
 796   res = scm_double_cell (STRING_TAG,
 797                          SCM_UNPACK (buf),
 798                          (scm_t_bits) 0, (scm_t_bits) len);
 799   scm_gc_register_collectable_memory (str, len+1, "string");
 800   return res;
 801 }
 802
 803 char *
 804 scm_to_locale_stringn (SCM str, size_t *lenp)
 805 {
 806   char *res;
 807   size_t len;
 808
 809   if (!scm_is_string (str))
 810     scm_wrong_type_arg_msg (NULL, 0, str, "string");
 811   len = scm_i_string_length (str);
 812   res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
 813   memcpy (res, scm_i_string_chars (str), len);
 814   if (lenp == NULL)
 815     {
 816       res[len] = '\0';
 817       if (strlen (res) != len)
 818         {
 819           free (res);
 820           scm_misc_error (NULL,
 821                           "string contains #\\nul character: ~S",
 822                           scm_list_1 (str));
 823         }
 824     }
 825   else
 826     *lenp = len;
 827
 828   scm_remember_upto_here_1 (str);
 829   return res;
 830 }
 831
 832 char *
 833 scm_to_locale_string (SCM str)
 834 {
 835   return scm_to_locale_stringn (str, NULL);
 836 }
 837
 838 size_t
 839 scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
 840 {
 841   size_t len;
 842
 843   if (!scm_is_string (str))
 844     scm_wrong_type_arg_msg (NULL, 0, str, "string");
 845   len = scm_i_string_length (str);
 846   memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
 847   scm_remember_upto_here_1 (str);
 848   return len;
 849 }
 850
 851 /* converts C scm_array of strings to SCM scm_list of strings. */
 852 /* If argc < 0, a null terminated scm_array is assumed. */
 853 SCM
 854 scm_makfromstrs (int argc, char **argv)
 855 {
 856   int i = argc;
 857   SCM lst = SCM_EOL;
 858   if (0 > i)
 859     for (i = 0; argv[i]; i++);
 860   while (i--)
 861     lst = scm_cons (scm_from_locale_string (argv[i]), lst);
 862   return lst;
 863 }
 864
 865 /* Return a newly allocated array of char pointers to each of the strings
 866    in args, with a terminating NULL pointer.  */
 867
 868 char **
 869 scm_i_allocate_string_pointers (SCM list)
 870 {
 871   char **result;
 872   int len = scm_ilength (list);
 873   int i;
 874
 875   if (len < 0)
 876     scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
 877
 878   scm_frame_begin (0);
 879
 880   result = (char **) scm_malloc ((len + 1) * sizeof (char *));
 881   result[len] = NULL;
 882   scm_frame_unwind_handler (free, result, 0);
 883
 884   /* The list might be have been modified in another thread, so
 885      we check LIST before each access.
 886    */
 887   for (i = 0; i < len && SCM_CONSP (list); i++)
 888     {
 889       result[i] = scm_to_locale_string (SCM_CAR (list));
 890       list = SCM_CDR (list);
 891     }
 892
 893   scm_frame_end ();
 894   return result;
 895 }
 896
 897 void
 898 scm_i_free_string_pointers (char **pointers)
 899 {
 900   int i;
 901
 902   for (i = 0; pointers[i]; i++)
 903     free (pointers[i]);
 904   free (pointers);
 905 }
 906
 907 void
 908 scm_i_get_substring_spec (size_t len,
 909                           SCM start, size_t *cstart,
 910                           SCM end, size_t *cend)
 911 {
 912   if (SCM_UNBNDP (start))
 913     *cstart = 0;
 914   else
 915     *cstart = scm_to_unsigned_integer (start, 0, len);
 916
 917   if (SCM_UNBNDP (end))
 918     *cend = len;
 919   else
 920     *cend = scm_to_unsigned_integer (end, *cstart, len);
 921 }
 922
 923 #if SCM_ENABLE_DEPRECATED
 924
 925 int
 926 SCM_STRINGP (SCM str)
 927 {
 928   scm_c_issue_deprecation_warning
 929     ("SCM_STRINGP is deprecated.  Use scm_is_string instead.");
 930
 931   return scm_is_string (str);
 932 }
 933
 934 char *
 935 SCM_STRING_CHARS (SCM str)
 936 {
 937   char *chars;
 938
 939   scm_c_issue_deprecation_warning
 940     ("SCM_STRING_CHARS is deprecated.  See the manual for alternatives.");
 941
 942   /* We don't accept shared substrings here since they are not
 943      null-terminated.
 944   */
 945   if (IS_SH_STRING (str))
 946     scm_misc_error (NULL,
 947                     "SCM_STRING_CHARS does not work with shared substrings.",
 948                     SCM_EOL);
 949
 950   /* The following is still wrong, of course...
 951    */
 952   chars = scm_i_string_writable_chars (str);
 953   scm_i_string_stop_writing ();
 954   return chars;
 955 }
 956
 957 size_t
 958 SCM_STRING_LENGTH (SCM str)
 959 {
 960   scm_c_issue_deprecation_warning
 961     ("SCM_STRING_LENGTH is deprecated.  Use scm_c_string_length instead.");
 962   return scm_c_string_length (str);
 963 }
 964
 965 #endif
 966
 967 void
 968 scm_init_strings ()
 969 {
 970   scm_nullstr = scm_i_make_string (0, NULL);
 971
 972 #include "libguile/strings.x"
 973 }
 974
 975
 976 /*
 977   Local Variables:
 978   c-file-style: "gnu"
 979   End:
 980 */