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_STRING_UCHARS (str)[idx]);
 261 }
 262 #undef FUNC_NAME
 263
 264
 265 SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
 266             (SCM str, SCM k, SCM chr),
 267             "Stores CHR in element K of STRING and returns an unspecified value.\n"
 268             "K must be a valid index of STR.")
 269 #define FUNC_NAME s_scm_string_set_x
 270 {
 271 #if (SCM_DEBUG_DEPRECATED == 0)
 272   SCM_VALIDATE_RWSTRING (1, str);
 273 #else
 274   SCM_VALIDATE_STRING (1, str);
 275 #endif
 276   SCM_VALIDATE_INUM_RANGE (2,k,0,SCM_STRING_LENGTH(str));
 277   SCM_VALIDATE_CHAR (3,chr);
 278   SCM_STRING_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr);
 279   return SCM_UNSPECIFIED;
 280 }
 281 #undef FUNC_NAME
 282
 283
 284 SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
 285            (SCM str, SCM start, SCM end),
 286             "Returns a newly allocated string formed from the characters\n"
 287             "of STR beginning with index START (inclusive) and ending with\n"
 288             "index END (exclusive).\n"
 289             "STR must be a string, START and END must be exact integers satisfying:\n\n"
 290             "0 <= START <= END <= (string-length STR).")
 291 #define FUNC_NAME s_scm_substring
 292 {
 293   long int from;
 294   long int to;
 295
 296   SCM_VALIDATE_STRING (1, str);
 297   SCM_VALIDATE_INUM (2, start);
 298   SCM_VALIDATE_INUM_DEF (3, end, SCM_STRING_LENGTH (str));
 299
 300   from = SCM_INUM (start);
 301   SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_STRING_LENGTH (str));
 302   to = SCM_INUM (end);
 303   SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_STRING_LENGTH (str));
 304
 305   return scm_makfromstr (&SCM_STRING_CHARS (str)[from], (scm_sizet) (to - from), 0);
 306 }
 307 #undef FUNC_NAME
 308
 309
 310 SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
 311             (SCM args),
 312             "Returns a newly allocated string whose characters form the\n"
 313             "concatenation of the given strings, ARGS.")
 314 #define FUNC_NAME s_scm_string_append
 315 {
 316   SCM res;
 317   register long i = 0;
 318   register SCM l, s;
 319   register unsigned char *data;
 320
 321   SCM_VALIDATE_REST_ARGUMENT (args);
 322   for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) {
 323     s = SCM_CAR (l);
 324     SCM_VALIDATE_STRING (SCM_ARGn,s);
 325     i += SCM_STRING_LENGTH (s);
 326   }
 327   res = scm_makstr (i, 0);
 328   data = SCM_STRING_UCHARS (res);
 329   for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) {
 330     s = SCM_CAR (l);
 331     for (i = 0;i<SCM_STRING_LENGTH (s);i++) *data++ = SCM_STRING_UCHARS (s)[i];
 332   }
 333   return res;
 334 }
 335 #undef FUNC_NAME
 336
 337 #if SCM_DEBUG_DEPRECATED == 0
 338
 339 /* Explicit shared substrings will disappear from Guile.
 340  *
 341  * Instead, "normal" strings will be implemented using sharing
 342  * internally, combined with a copy-on-write strategy.
 343  */
 344
 345 SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0,
 346            (SCM str, SCM frm, SCM to),
 347             "Return a shared substring of @var{str}.  The semantics are the same as\n"
 348             "for the @code{substring} function: the shared substring returned\n"
 349             "includes all of the text from @var{str} between indexes @var{start}\n"
 350             "(inclusive) and @var{end} (exclusive).  If @var{end} is omitted, it\n"
 351             "defaults to the end of @var{str}.  The shared substring returned by\n"
 352             "@code{make-shared-substring} occupies the same storage space as\n"
 353             "@var{str}.")
 354 #define FUNC_NAME s_scm_make_shared_substring
 355 {
 356   long f;
 357   long t;
 358   SCM answer;
 359   SCM len_str;
 360
 361   SCM_VALIDATE_ROSTRING (1,str);
 362   SCM_VALIDATE_INUM_DEF_COPY (2,frm,0,f);
 363   SCM_VALIDATE_INUM_DEF_COPY (3,to,SCM_ROLENGTH(str),t);
 364
 365   SCM_ASSERT_RANGE (2,frm,(f >= 0));
 366   SCM_ASSERT_RANGE (3,to, (f <= t) && (t <= SCM_ROLENGTH (str)));
 367
 368   SCM_NEWCELL (answer);
 369   SCM_NEWCELL (len_str);
 370
 371   SCM_DEFER_INTS;
 372   if (SCM_SUBSTRP (str))
 373     {
 374       long offset;
 375       offset = SCM_INUM (SCM_SUBSTR_OFFSET (str));
 376       f += offset;
 377       t += offset;
 378       SCM_SETCAR (len_str, SCM_MAKINUM (f));
 379       SCM_SETCDR (len_str, SCM_SUBSTR_STR (str));
 380       SCM_SETCDR (answer, len_str);
 381       SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
 382     }
 383   else
 384     {
 385       SCM_SETCAR (len_str, SCM_MAKINUM (f));
 386       SCM_SETCDR (len_str, str);
 387       SCM_SETCDR (answer, len_str);
 388       SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
 389     }
 390   SCM_ALLOW_INTS;
 391   return answer;
 392 }
 393 #undef FUNC_NAME
 394
 395 #endif /* DEPRECATED */
 396
 397 void
 398 scm_init_strings ()
 399 {
 400 #ifndef SCM_MAGIC_SNARFER
 401 #include "libguile/strings.x"
 402 #endif
 403 }
 404
 405
 406 /*
 407   Local Variables:
 408   c-file-style: "gnu"
 409   End:
 410 */