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