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 SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0,
  70            (SCM x),
  71             "Return true if OBJ can be read as a string,\n\n"
  72             "This illustrates the difference between @code{string?} and\n"
  73             "@code{read-only-string?}:\n\n"
  74             "@example\n"
  75             "(string? \"a string\") @result{} #t\n"
  76             "(string? 'a-symbol) @result{} #f\n\n"
  77             "(read-only-string? \"a string\") @result{} #t\n"
  78             "(read-only-string? 'a-symbol) @result{} #t\n"
  79             "@end example")
  80 #define FUNC_NAME s_scm_read_only_string_p
  81 {
  82   return SCM_BOOL(SCM_ROSTRINGP (x));
  83 }
  84 #undef FUNC_NAME
  85
  86 SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);
  87
  88 SCM_DEFINE (scm_string, "string", 0, 0, 1,
  89             (SCM chrs),
  90             "Returns a newly allocated string composed of the arguments, CHRS.")
  91 #define FUNC_NAME s_scm_string
  92 {
  93   SCM result;
  94
  95   {
  96     long i = scm_ilength (chrs);
  97
  98     SCM_ASSERT (i >= 0, chrs, SCM_ARGn, FUNC_NAME);
  99     result = scm_makstr (i, 0);
 100   }
 101
 102   {
 103     unsigned char *data = SCM_UCHARS (result);
 104
 105     while (SCM_NNULLP (chrs))
 106       {
 107         SCM elt = SCM_CAR (chrs);
 108
 109         SCM_VALIDATE_CHAR (SCM_ARGn, elt);
 110         *data++ = SCM_CHAR (elt);
 111         chrs = SCM_CDR (chrs);
 112       }
 113   }
 114   return result;
 115 }
 116 #undef FUNC_NAME
 117
 118 SCM
 119 scm_makstr (long len, int slots)
 120 {
 121   SCM s;
 122   scm_bits_t * mem;
 123
 124   SCM_NEWCELL (s);
 125   --slots;
 126   SCM_REDEFER_INTS;
 127   mem = (scm_bits_t *) scm_must_malloc (sizeof (scm_bits_t) * (slots + 1)
 128                                         + len + 1, "scm_makstr");
 129   if (slots >= 0)
 130     {
 131       int x;
 132       mem[slots] = (scm_bits_t) mem;
 133       for (x = 0; x < slots; ++x)
 134         mem[x] = SCM_UNPACK (SCM_BOOL_F);
 135     }
 136   SCM_SETCHARS (s, (char *) (mem + slots + 1));
 137   SCM_SETLENGTH (s, len, scm_tc7_string);
 138   SCM_REALLOW_INTS;
 139   SCM_CHARS (s)[len] = 0;
 140   return s;
 141 }
 142
 143 /* converts C scm_array of strings to SCM scm_list of strings. */
 144 /* If argc < 0, a null terminated scm_array is assumed. */
 145
 146 SCM
 147 scm_makfromstrs (int argc, char **argv)
 148 {
 149   int i = argc;
 150   SCM lst = SCM_EOL;
 151   if (0 > i)
 152     for (i = 0; argv[i]; i++);
 153   while (i--)
 154     lst = scm_cons (scm_makfromstr (argv[i], (scm_sizet) strlen (argv[i]), 0), lst);
 155   return lst;
 156 }
 157
 158
 159 /* This function must only be applied to memory obtained via malloc,
 160    since the GC is going to apply `free' to it when the string is
 161    dropped.
 162
 163    Also, s[len] must be `\0', since we promise that strings are
 164    null-terminated.  Perhaps we could handle non-null-terminated
 165    strings by claiming they're shared substrings of a string we just
 166    made up.  */
 167 SCM
 168 scm_take_str (char *s, int len)
 169 {
 170   SCM answer;
 171   SCM_NEWCELL (answer);
 172   SCM_DEFER_INTS;
 173   SCM_SETLENGTH (answer, len, scm_tc7_string);
 174   scm_done_malloc (len + 1);
 175   SCM_SETCHARS (answer, s);
 176   SCM_ALLOW_INTS;
 177   return answer;
 178 }
 179
 180 /* `s' must be a malloc'd string.  See scm_take_str.  */
 181 SCM
 182 scm_take0str (char *s)
 183 {
 184   return scm_take_str (s, strlen (s));
 185 }
 186
 187 SCM
 188 scm_makfromstr (const char *src, scm_sizet len, int slots)
 189 {
 190   SCM s = scm_makstr (len, slots);
 191   char *dst = SCM_CHARS (s);
 192
 193   while (len--)
 194     *dst++ = *src++;
 195   return s;
 196 }
 197
 198 SCM
 199 scm_makfrom0str (const char *src)
 200 {
 201   if (!src) return SCM_BOOL_F;
 202   return scm_makfromstr (src, (scm_sizet) strlen (src), 0);
 203 }
 204
 205
 206 SCM
 207 scm_makfrom0str_opt (const char *src)
 208 {
 209   return scm_makfrom0str (src);
 210 }
 211
 212
 213
 214
 215 SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
 216             (SCM k, SCM chr),
 217             "Returns a newly allocated string of\n"
 218             "length K.  If CHR is given, then all elements of the string\n"
 219             "are initialized to CHR, otherwise the contents of the\n"
 220             "STRING are unspecified.\n")
 221 #define FUNC_NAME s_scm_make_string
 222 {
 223   SCM res;
 224   register long i;
 225   SCM_VALIDATE_INUM_MIN_COPY (1,k,0,i);
 226   res = scm_makstr (i, 0);
 227   if (!SCM_UNBNDP (chr))
 228     {
 229       SCM_VALIDATE_CHAR (2,chr);
 230       {
 231         unsigned char *dst = SCM_UCHARS (res);
 232         char c = SCM_CHAR (chr);
 233
 234         memset (dst, c, i);
 235       }
 236     }
 237   return res;
 238 }
 239 #undef FUNC_NAME
 240
 241 SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
 242            (SCM string),
 243             "Returns the number of characters in STRING")
 244 #define FUNC_NAME s_scm_string_length
 245 {
 246   SCM_VALIDATE_ROSTRING (1,string);
 247   return SCM_MAKINUM (SCM_ROLENGTH (string));
 248 }
 249 #undef FUNC_NAME
 250
 251 SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
 252             (SCM str, SCM k),
 253             "Returns character K of STR using zero-origin indexing.\n"
 254             "K must be a valid index of STR.")
 255 #define FUNC_NAME s_scm_string_ref
 256 {
 257   int idx;
 258
 259   SCM_VALIDATE_ROSTRING (1, str);
 260   SCM_VALIDATE_INUM_COPY (2, k, idx);
 261   SCM_ASSERT_RANGE (2, k, idx >= 0 && idx < SCM_ROLENGTH (str));
 262   return SCM_MAKE_CHAR (SCM_ROUCHARS (str)[idx]);
 263 }
 264 #undef FUNC_NAME
 265
 266 SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
 267             (SCM str, SCM k, SCM chr),
 268             "Stores CHR in element K of STRING and returns an unspecified value.\n"
 269             "K must be a valid index of STR.")
 270 #define FUNC_NAME s_scm_string_set_x
 271 {
 272   SCM_VALIDATE_RWSTRING (1,str);
 273   SCM_VALIDATE_INUM_RANGE (2,k,0,SCM_LENGTH(str));
 274   SCM_VALIDATE_CHAR (3,chr);
 275   SCM_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr);
 276   return SCM_UNSPECIFIED;
 277 }
 278 #undef FUNC_NAME
 279
 280
 281 SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
 282            (SCM str, SCM start, SCM end),
 283             "Returns a newly allocated string formed from the characters\n"
 284             "of STR beginning with index START (inclusive) and ending with\n"
 285             "index END (exclusive).\n"
 286             "STR must be a string, START and END must be exact integers satisfying:\n\n"
 287             "0 <= START <= END <= (string-length STR).")
 288 #define FUNC_NAME s_scm_substring
 289 {
 290   long int from;
 291   long int to;
 292
 293   SCM_VALIDATE_ROSTRING (1,str);
 294   SCM_VALIDATE_INUM (2, start);
 295   SCM_VALIDATE_INUM_DEF (3,end,SCM_ROLENGTH(str));
 296
 297   from = SCM_INUM (start);
 298   SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_ROLENGTH (str));
 299   to = SCM_INUM (end);
 300   SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_ROLENGTH (str));
 301
 302   return scm_makfromstr (&SCM_ROCHARS (str)[from], (scm_sizet) (to - from), 0);
 303 }
 304 #undef FUNC_NAME
 305
 306
 307 SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
 308             (SCM args),
 309             "Returns a newly allocated string whose characters form the\n"
 310             "concatenation of the given strings, ARGS.")
 311 #define FUNC_NAME s_scm_string_append
 312 {
 313   SCM res;
 314   register long i = 0;
 315   register SCM l, s;
 316   register unsigned char *data;
 317
 318   SCM_VALIDATE_REST_ARGUMENT (args);
 319   for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) {
 320     s = SCM_CAR (l);
 321     SCM_VALIDATE_ROSTRING (SCM_ARGn,s);
 322     i += SCM_ROLENGTH (s);
 323   }
 324   res = scm_makstr (i, 0);
 325   data = SCM_UCHARS (res);
 326   for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) {
 327     s = SCM_CAR (l);
 328     for (i = 0;i<SCM_ROLENGTH (s);i++) *data++ = SCM_ROUCHARS (s)[i];
 329   }
 330   return res;
 331 }
 332 #undef FUNC_NAME
 333
 334 SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0,
 335            (SCM str, SCM frm, SCM to),
 336             "Return a shared substring of @var{str}.  The semantics are the same as\n"
 337             "for the @code{substring} function: the shared substring returned\n"
 338             "includes all of the text from @var{str} between indexes @var{start}\n"
 339             "(inclusive) and @var{end} (exclusive).  If @var{end} is omitted, it\n"
 340             "defaults to the end of @var{str}.  The shared substring returned by\n"
 341             "@code{make-shared-substring} occupies the same storage space as\n"
 342             "@var{str}.")
 343 #define FUNC_NAME s_scm_make_shared_substring
 344 {
 345   long f;
 346   long t;
 347   SCM answer;
 348   SCM len_str;
 349
 350   SCM_VALIDATE_ROSTRING (1,str);
 351   SCM_VALIDATE_INUM_DEF_COPY (2,frm,0,f);
 352   SCM_VALIDATE_INUM_DEF_COPY (3,to,SCM_ROLENGTH(str),t);
 353
 354   SCM_ASSERT_RANGE (2,frm,(f >= 0));
 355   SCM_ASSERT_RANGE (3,to, (f <= t) && (t <= SCM_ROLENGTH (str)));
 356
 357   SCM_NEWCELL (answer);
 358   SCM_NEWCELL (len_str);
 359
 360   SCM_DEFER_INTS;
 361   if (SCM_SUBSTRP (str))
 362     {
 363       long offset;
 364       offset = SCM_INUM (SCM_SUBSTR_OFFSET (str));
 365       f += offset;
 366       t += offset;
 367       SCM_SETCAR (len_str, SCM_MAKINUM (f));
 368       SCM_SETCDR (len_str, SCM_SUBSTR_STR (str));
 369       SCM_SETCDR (answer, len_str);
 370       SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
 371     }
 372   else
 373     {
 374       SCM_SETCAR (len_str, SCM_MAKINUM (f));
 375       SCM_SETCDR (len_str, str);
 376       SCM_SETCDR (answer, len_str);
 377       SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
 378     }
 379   SCM_ALLOW_INTS;
 380   return answer;
 381 }
 382 #undef FUNC_NAME
 383
 384 void
 385 scm_init_strings ()
 386 {
 387 #include "libguile/strings.x"
 388 }
 389
 390
 391 /*
 392   Local Variables:
 393   c-file-style: "gnu"
 394   End:
 395 */