libguile/strings.c

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