libguile/strings.c

   1 /*      Copyright (C) 1995,1996,1998,2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include <string.h>
  49
  50 #include "libguile/_scm.h"
  51 #include "libguile/chars.h"
  52
  53 #include "libguile/strings.h"
  54 #include "libguile/validate.h"
  55 \f
  56
  57 /* {Strings}
  58  */
  59
  60 SCM_DEFINE (scm_string_p, "string?", 1, 0, 0,
  61            (SCM obj),
  62             "Returns #t iff OBJ is a string, else returns #f.")
  63 #define FUNC_NAME s_scm_string_p
  64 {
  65   return SCM_BOOL (SCM_STRINGP (obj));
  66 }
  67 #undef FUNC_NAME
  68
  69 #if SCM_DEBUG_DEPRECATED == 0
  70
  71 /* The concept of read-only strings will disappear in next release
  72  * of Guile.
  73  */
  74
  75 SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0,
  76            (SCM x),
  77             "Return true if OBJ can be read as a string,\n\n"
  78             "This illustrates the difference between @code{string?} and\n"
  79             "@code{read-only-string?}:\n\n"
  80             "@example\n"
  81             "(string? \"a string\") @result{} #t\n"
  82             "(string? 'a-symbol) @result{} #f\n\n"
  83             "(read-only-string? \"a string\") @result{} #t\n"
  84             "(read-only-string? 'a-symbol) @result{} #t\n"
  85             "@end example")
  86 #define FUNC_NAME s_scm_read_only_string_p
  87 {
  88   return SCM_BOOL(SCM_ROSTRINGP (x));
  89 }
  90 #undef FUNC_NAME
  91
  92 #endif /* DEPRECATED */
  93
  94 SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);
  95
  96 SCM_DEFINE (scm_string, "string", 0, 0, 1,
  97             (SCM chrs),
  98             "@deffnx primitive list->string chrs\n"
  99             "Returns a newly allocated string composed of the arguments, CHRS.")
 100 #define FUNC_NAME s_scm_string
 101 {
 102   SCM result;
 103
 104   {
 105     long i = scm_ilength (chrs);
 106
 107     SCM_ASSERT (i >= 0, chrs, SCM_ARGn, FUNC_NAME);
 108     result = scm_makstr (i, 0);
 109   }
 110
 111   {
 112     unsigned char *data = SCM_STRING_UCHARS (result);
 113
 114     while (SCM_NNULLP (chrs))
 115       {
 116         SCM elt = SCM_CAR (chrs);
 117
 118         SCM_VALIDATE_CHAR (SCM_ARGn, elt);
 119         *data++ = SCM_CHAR (elt);
 120         chrs = SCM_CDR (chrs);
 121       }
 122   }
 123   return result;
 124 }
 125 #undef FUNC_NAME
 126
 127 SCM
 128 scm_makstr (long len, int dummy)
 129 {
 130   SCM s;
 131   char *mem = (char *) scm_must_malloc (len + 1, "scm_makstr");
 132
 133   mem[len] = 0;
 134   SCM_NEWCELL (s);
 135   SCM_SETCHARS (s, mem);
 136   SCM_SETLENGTH (s, len, scm_tc7_string);
 137
 138   return s;
 139 }
 140
 141 /* converts C scm_array of strings to SCM scm_list of strings. */
 142 /* If argc < 0, a null terminated scm_array is assumed. */
 143
 144 SCM
 145 scm_makfromstrs (int argc, char **argv)
 146 {
 147   int i = argc;
 148   SCM lst = SCM_EOL;
 149   if (0 > i)
 150     for (i = 0; argv[i]; i++);
 151   while (i--)
 152     lst = scm_cons (scm_makfromstr (argv[i], (scm_sizet) strlen (argv[i]), 0), lst);
 153   return lst;
 154 }
 155
 156
 157 /* This function must only be applied to memory obtained via malloc,
 158    since the GC is going to apply `free' to it when the string is
 159    dropped.
 160
 161    Also, s[len] must be `\0', since we promise that strings are
 162    null-terminated.  Perhaps we could handle non-null-terminated
 163    strings by claiming they're shared substrings of a string we just
 164    made up.  */
 165 SCM
 166 scm_take_str (char *s, int len)
 167 {
 168   SCM answer;
 169   SCM_NEWCELL (answer);
 170   SCM_DEFER_INTS;
 171   SCM_SETLENGTH (answer, len, scm_tc7_string);
 172   scm_done_malloc (len + 1);
 173   SCM_SETCHARS (answer, s);
 174   SCM_ALLOW_INTS;
 175   return answer;
 176 }
 177
 178 /* `s' must be a malloc'd string.  See scm_take_str.  */
 179 SCM
 180 scm_take0str (char *s)
 181 {
 182   return scm_take_str (s, strlen (s));
 183 }
 184
 185 SCM
 186 scm_makfromstr (const char *src, scm_sizet len, int dummy)
 187 {
 188   SCM s = scm_makstr (len, 0);
 189   char *dst = SCM_STRING_CHARS (s);
 190
 191   while (len--)
 192     *dst++ = *src++;
 193   return s;
 194 }
 195
 196 SCM
 197 scm_makfrom0str (const char *src)
 198 {
 199   if (!src) return SCM_BOOL_F;
 200   return scm_makfromstr (src, (scm_sizet) strlen (src), 0);
 201 }
 202
 203
 204 SCM
 205 scm_makfrom0str_opt (const char *src)
 206 {
 207   return scm_makfrom0str (src);
 208 }
 209
 210
 211
 212
 213 SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
 214             (SCM k, SCM chr),
 215             "Returns a newly allocated string of\n"
 216             "length K.  If CHR is given, then all elements of the string\n"
 217             "are initialized to CHR, otherwise the contents of the\n"
 218             "STRING are unspecified.\n")
 219 #define FUNC_NAME s_scm_make_string
 220 {
 221   SCM res;
 222   register long i;
 223   SCM_VALIDATE_INUM_MIN_COPY (1,k,0,i);
 224   res = scm_makstr (i, 0);
 225   if (!SCM_UNBNDP (chr))
 226     {
 227       SCM_VALIDATE_CHAR (2,chr);
 228       {
 229         unsigned char *dst = SCM_STRING_UCHARS (res);
 230         char c = SCM_CHAR (chr);
 231
 232         memset (dst, c, i);
 233       }
 234     }
 235   return res;
 236 }
 237 #undef FUNC_NAME
 238
 239 SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
 240            (SCM string),
 241             "Returns the number of characters in STRING")
 242 #define FUNC_NAME s_scm_string_length
 243 {
 244   SCM_VALIDATE_STRING (1, string);
 245   return SCM_MAKINUM (SCM_STRING_LENGTH (string));
 246 }
 247 #undef FUNC_NAME
 248
 249 SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
 250             (SCM str, SCM k),
 251             "Returns character K of STR using zero-origin indexing.\n"
 252             "K must be a valid index of STR.")
 253 #define FUNC_NAME s_scm_string_ref
 254 {
 255   int idx;
 256
 257   SCM_VALIDATE_STRING (1, str);
 258   SCM_VALIDATE_INUM_COPY (2, k, idx);
 259   SCM_ASSERT_RANGE (2, k, idx >= 0 && idx < SCM_STRING_LENGTH (str));
 260   return SCM_MAKE_CHAR (SCM_ROUCHARS (str)[idx]);
 261 }
 262 #undef FUNC_NAME
 263
 264 SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
 265             (SCM str, SCM k, SCM chr),
 266             "Stores CHR in element K of STRING and returns an unspecified value.\n"
 267             "K must be a valid index of STR.")
 268 #define FUNC_NAME s_scm_string_set_x
 269 {
 270   SCM_VALIDATE_RWSTRING (1,str);
 271   SCM_VALIDATE_INUM_RANGE (2,k,0,SCM_STRING_LENGTH(str));
 272   SCM_VALIDATE_CHAR (3,chr);
 273   SCM_STRING_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr);
 274   return SCM_UNSPECIFIED;
 275 }
 276 #undef FUNC_NAME
 277
 278
 279 SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
 280            (SCM str, SCM start, SCM end),
 281             "Returns a newly allocated string formed from the characters\n"
 282             "of STR beginning with index START (inclusive) and ending with\n"
 283             "index END (exclusive).\n"
 284             "STR must be a string, START and END must be exact integers satisfying:\n\n"
 285             "0 <= START <= END <= (string-length STR).")
 286 #define FUNC_NAME s_scm_substring
 287 {
 288   long int from;
 289   long int to;
 290
 291   SCM_VALIDATE_STRING (1, str);
 292   SCM_VALIDATE_INUM (2, start);
 293   SCM_VALIDATE_INUM_DEF (3, end, SCM_STRING_LENGTH (str));
 294
 295   from = SCM_INUM (start);
 296   SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_STRING_LENGTH (str));
 297   to = SCM_INUM (end);
 298   SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_STRING_LENGTH (str));
 299
 300   return scm_makfromstr (&SCM_ROCHARS (str)[from], (scm_sizet) (to - from), 0);
 301 }
 302 #undef FUNC_NAME
 303
 304
 305 SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
 306             (SCM args),
 307             "Returns a newly allocated string whose characters form the\n"
 308             "concatenation of the given strings, ARGS.")
 309 #define FUNC_NAME s_scm_string_append
 310 {
 311   SCM res;
 312   register long i = 0;
 313   register SCM l, s;
 314   register unsigned char *data;
 315
 316   SCM_VALIDATE_REST_ARGUMENT (args);
 317   for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) {
 318     s = SCM_CAR (l);
 319     SCM_VALIDATE_STRING (SCM_ARGn,s);
 320     i += SCM_STRING_LENGTH (s);
 321   }
 322   res = scm_makstr (i, 0);
 323   data = SCM_STRING_UCHARS (res);
 324   for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) {
 325     s = SCM_CAR (l);
 326     for (i = 0;i<SCM_STRING_LENGTH (s);i++) *data++ = SCM_ROUCHARS (s)[i];
 327   }
 328   return res;
 329 }
 330 #undef FUNC_NAME
 331
 332 #if SCM_DEBUG_DEPRECATED == 0
 333
 334 /* Explicit shared substrings will disappear from Guile.
 335  *
 336  * Instead, "normal" strings will be implemented using sharing
 337  * internally, combined with a copy-on-write strategy.
 338  */
 339
 340 SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0,
 341            (SCM str, SCM frm, SCM to),
 342             "Return a shared substring of @var{str}.  The semantics are the same as\n"
 343             "for the @code{substring} function: the shared substring returned\n"
 344             "includes all of the text from @var{str} between indexes @var{start}\n"
 345             "(inclusive) and @var{end} (exclusive).  If @var{end} is omitted, it\n"
 346             "defaults to the end of @var{str}.  The shared substring returned by\n"
 347             "@code{make-shared-substring} occupies the same storage space as\n"
 348             "@var{str}.")
 349 #define FUNC_NAME s_scm_make_shared_substring
 350 {
 351   long f;
 352   long t;
 353   SCM answer;
 354   SCM len_str;
 355
 356   SCM_VALIDATE_ROSTRING (1,str);
 357   SCM_VALIDATE_INUM_DEF_COPY (2,frm,0,f);
 358   SCM_VALIDATE_INUM_DEF_COPY (3,to,SCM_ROLENGTH(str),t);
 359
 360   SCM_ASSERT_RANGE (2,frm,(f >= 0));
 361   SCM_ASSERT_RANGE (3,to, (f <= t) && (t <= SCM_ROLENGTH (str)));
 362
 363   SCM_NEWCELL (answer);
 364   SCM_NEWCELL (len_str);
 365
 366   SCM_DEFER_INTS;
 367   if (SCM_SUBSTRP (str))
 368     {
 369       long offset;
 370       offset = SCM_INUM (SCM_SUBSTR_OFFSET (str));
 371       f += offset;
 372       t += offset;
 373       SCM_SETCAR (len_str, SCM_MAKINUM (f));
 374       SCM_SETCDR (len_str, SCM_SUBSTR_STR (str));
 375       SCM_SETCDR (answer, len_str);
 376       SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
 377     }
 378   else
 379     {
 380       SCM_SETCAR (len_str, SCM_MAKINUM (f));
 381       SCM_SETCDR (len_str, str);
 382       SCM_SETCDR (answer, len_str);
 383       SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
 384     }
 385   SCM_ALLOW_INTS;
 386   return answer;
 387 }
 388 #undef FUNC_NAME
 389
 390 #endif /* DEPRECATED */
 391
 392 void
 393 scm_init_strings ()
 394 {
 395 #include "libguile/strings.x"
 396 }
 397
 398
 399 /*
 400   Local Variables:
 401   c-file-style: "gnu"
 402   End:
 403 */