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