guile18/libguile/strings.c

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