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