libguile/strings.c

   1 /*      Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "chars.h"
  46
  47 #include "strings.h"
  48 \f
  49
  50 /* {Strings}
  51  */
  52
  53 SCM_PROC(s_string_p, "string?", 1, 0, 0, scm_string_p);
  54 #ifdef __STDC__
  55 SCM
  56 scm_string_p (SCM x)
  57 #else
  58 SCM
  59 scm_string_p (x)
  60      SCM x;
  61 #endif
  62 {
  63   if (SCM_IMP (x))
  64     return SCM_BOOL_F;
  65   return SCM_STRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F;
  66 }
  67
  68 SCM_PROC(s_read_only_string_p, "read-only-string?", 1, 0, 0, scm_read_only_string_p);
  69 #ifdef __STDC__
  70 SCM
  71 scm_read_only_string_p (SCM x)
  72 #else
  73 SCM
  74 scm_read_only_string_p (x)
  75      SCM x;
  76 #endif
  77 {
  78   if (SCM_IMP (x))
  79     return SCM_BOOL_F;
  80   return SCM_ROSTRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F;
  81 }
  82
  83 SCM_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string);
  84 SCM_PROC(s_string, "string", 0, 0, 1, scm_string);
  85 #ifdef __STDC__
  86 SCM
  87 scm_string (SCM chrs)
  88 #else
  89 SCM
  90 scm_string (chrs)
  91      SCM chrs;
  92 #endif
  93 {
  94   SCM res;
  95   register char *data;
  96   long i;
  97   long len;
  98   SCM_DEFER_INTS;
  99   i = scm_ilength (chrs);
 100   if (i < 0)
 101     {
 102       SCM_ALLOW_INTS;
 103       SCM_ASSERT (0, chrs, SCM_ARG1, s_string);
 104     }
 105   len = 0;
 106   {
 107     SCM s;
 108
 109     for (len = 0, s = chrs; s != SCM_EOL; s = SCM_CDR (s))
 110       if (SCM_ICHRP (SCM_CAR (s)))
 111         len += 1;
 112       else if (SCM_NIMP (SCM_CAR (s)) && SCM_ROSTRINGP (SCM_CAR (s)))
 113         len += SCM_ROLENGTH (SCM_CAR (s));
 114       else
 115         {
 116           SCM_ALLOW_INTS;
 117           SCM_ASSERT (0, s, SCM_ARG1, s_string);
 118         }
 119   }
 120   res = scm_makstr (len, 0);
 121   data = SCM_CHARS (res);
 122   for (;SCM_NNULLP (chrs);chrs = SCM_CDR (chrs))
 123     {
 124       if (SCM_ICHRP (SCM_CAR (chrs)))
 125         *data++ = SCM_ICHR (SCM_CAR (chrs));
 126       else
 127         {
 128           int l;
 129           char * c;
 130           l = SCM_ROLENGTH (SCM_CAR (chrs));
 131           c = SCM_ROCHARS (SCM_CAR (chrs));
 132           while (l)
 133             {
 134               --l;
 135               *data++ = *c++;
 136             }
 137         }
 138     }
 139   SCM_ALLOW_INTS;
 140   return res;
 141 }
 142
 143 #ifdef __STDC__
 144 SCM
 145 scm_makstr (long len, int slots)
 146 #else
 147 SCM
 148 scm_makstr (len, slots)
 149      long len;
 150      int slots;
 151 #endif
 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                                 s_string);
 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 #ifdef __STDC__
 177 SCM
 178 scm_makfromstrs (int argc, char **argv)
 179 #else
 180 SCM
 181 scm_makfromstrs (argc, argv)
 182      int argc;
 183      char **argv;
 184 #endif
 185 {
 186   int i = argc;
 187   SCM lst = SCM_EOL;
 188   if (0 > i)
 189     for (i = 0; argv[i]; i++);
 190   while (i--)
 191     lst = scm_cons (scm_makfromstr (argv[i], (scm_sizet) strlen (argv[i]), 0), lst);
 192   return lst;
 193 }
 194
 195
 196 #ifdef __STDC__
 197 SCM
 198 scm_take0str (char * it)
 199 #else
 200 SCM
 201 scm_take0str (it)
 202      char * it;
 203 #endif
 204 {
 205   SCM answer;
 206   SCM_NEWCELL (answer);
 207   SCM_DEFER_INTS;
 208   SCM_SETLENGTH (answer, strlen (it), scm_tc7_string);
 209   SCM_SETCHARS (answer, it);
 210   SCM_ALLOW_INTS;
 211   return answer;
 212 }
 213
 214 #ifdef __STDC__
 215 SCM
 216 scm_makfromstr (const char *src, scm_sizet len, int slots)
 217 #else
 218 SCM
 219 scm_makfromstr (src, len, slots)
 220      const char *src;
 221      scm_sizet len;
 222      int slots;
 223 #endif
 224 {
 225   SCM s;
 226   register char *dst;
 227   s = scm_makstr ((long) len, slots);
 228   dst = SCM_CHARS (s);
 229   while (len--)
 230     *dst++ = *src++;
 231   return s;
 232 }
 233
 234
 235 #ifdef __STDC__
 236 SCM
 237 scm_makfrom0str (char *src)
 238 #else
 239 SCM
 240 scm_makfrom0str (src)
 241      char *src;
 242 #endif
 243 {
 244   if (!src) return SCM_BOOL_F;
 245   return scm_makfromstr (src, (scm_sizet) strlen (src), 0);
 246 }
 247
 248 #ifdef __STDC__
 249 SCM
 250 scm_makfrom0str_opt (char *src)
 251 #else
 252 SCM
 253 scm_makfrom0str_opt (src)
 254      char *src;
 255 #endif
 256 {
 257   return scm_makfrom0str (src);
 258 }
 259
 260
 261
 262
 263 SCM_PROC(s_make_string, "make-string", 1, 1, 0, scm_make_string);
 264 #ifdef __STDC__
 265 SCM
 266 scm_make_string (SCM k, SCM chr)
 267 #else
 268 SCM
 269 scm_make_string (k, chr)
 270      SCM k;
 271      SCM chr;
 272 #endif
 273 {
 274   SCM res;
 275   register char *dst;
 276   register long i;
 277   SCM_ASSERT (SCM_INUMP (k) && (k >= 0), k, SCM_ARG1, s_make_string);
 278   i = SCM_INUM (k);
 279   res = scm_makstr (i, 0);
 280   dst = SCM_CHARS (res);
 281   if SCM_ICHRP (chr)
 282     {
 283       char c = SCM_ICHR (chr);
 284       for (i--;i >= 0;i--)
 285         {
 286           dst[i] = c;
 287         }
 288     }
 289   return res;
 290 }
 291
 292 SCM_PROC(s_string_length, "string-length", 1, 0, 0, scm_string_length);
 293 #ifdef __STDC__
 294 SCM
 295 scm_string_length (SCM str)
 296 #else
 297 SCM
 298 scm_string_length (str)
 299      SCM str;
 300 #endif
 301 {
 302   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_length);
 303   return SCM_MAKINUM (SCM_ROLENGTH (str));
 304 }
 305
 306 SCM_PROC(s_string_ref, "string-ref", 1, 1, 0, scm_string_ref);
 307 #ifdef __STDC__
 308 SCM
 309 scm_string_ref (SCM str, SCM k)
 310 #else
 311 SCM
 312 scm_string_ref (str, k)
 313      SCM str;
 314      SCM k;
 315 #endif
 316 {
 317   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_ref);
 318   if (k == SCM_UNDEFINED)
 319     k = SCM_MAKINUM (0);
 320   SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_ref);
 321   SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_ref);
 322   return SCM_MAKICHR (SCM_ROCHARS (str)[SCM_INUM (k)]);
 323 }
 324
 325 SCM_PROC(s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x);
 326 #ifdef __STDC__
 327 SCM
 328 scm_string_set_x (SCM str, SCM k, SCM chr)
 329 #else
 330 SCM
 331 scm_string_set_x (str, k, chr)
 332      SCM str;
 333      SCM k;
 334      SCM chr;
 335 #endif
 336 {
 337   SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_set_x);
 338   SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_set_x);
 339   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG3, s_string_set_x);
 340   SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_set_x);
 341   SCM_CHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr);
 342   return SCM_UNSPECIFIED;
 343 }
 344
 345
 346
 347 SCM_PROC(s_substring, "substring", 2, 1, 0, scm_substring);
 348 #ifdef __STDC__
 349 SCM
 350 scm_substring (SCM str, SCM start, SCM end)
 351 #else
 352 SCM
 353 scm_substring (str, start, end)
 354      SCM str;
 355      SCM start;
 356      SCM end;
 357 #endif
 358 {
 359   long l;
 360   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str),
 361          str, SCM_ARG1, s_substring);
 362   SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring);
 363   if (end == SCM_UNDEFINED)
 364     end = SCM_MAKINUM (SCM_ROLENGTH (str));
 365   SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring);
 366   SCM_ASSERT (SCM_INUM (start) <= SCM_ROLENGTH (str), start, SCM_OUTOFRANGE, s_substring);
 367   SCM_ASSERT (SCM_INUM (end) <= SCM_ROLENGTH (str), end, SCM_OUTOFRANGE, s_substring);
 368   l = SCM_INUM (end)-SCM_INUM (start);
 369   SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, s_substring);
 370   return scm_makfromstr (&SCM_ROCHARS (str)[SCM_INUM (start)], (scm_sizet)l, 0);
 371 }
 372
 373 SCM_PROC(s_string_append, "string-append", 0, 0, 1, scm_string_append);
 374 #ifdef __STDC__
 375 SCM
 376 scm_string_append (SCM args)
 377 #else
 378 SCM
 379 scm_string_append (args)
 380      SCM args;
 381 #endif
 382 {
 383   SCM res;
 384   register long i = 0;
 385   register SCM l, s;
 386   register char *data;
 387   for (l = args;SCM_NIMP (l);) {
 388     SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, s_string_append);
 389     s = SCM_CAR (l);
 390     SCM_ASSERT (SCM_NIMP (s) && SCM_ROSTRINGP (s),
 391            s, SCM_ARGn, s_string_append);
 392     i += SCM_ROLENGTH (s);
 393     l = SCM_CDR (l);
 394   }
 395   SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, s_string_append);
 396   res = scm_makstr (i, 0);
 397   data = SCM_CHARS (res);
 398   for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) {
 399     s = SCM_CAR (l);
 400     for (i = 0;i<SCM_ROLENGTH (s);i++) *data++ = SCM_ROCHARS (s)[i];
 401   }
 402   return res;
 403 }
 404
 405 SCM_PROC(s_make_shared_substring, "make-shared-substring", 1, 2, 0, scm_make_shared_substring);
 406 #ifdef __STDC__
 407 SCM
 408 scm_make_shared_substring (SCM str, SCM frm, SCM to)
 409 #else
 410 SCM
 411 scm_make_shared_substring (str, frm, to)
 412      SCM str;
 413      SCM frm;
 414      SCM to;
 415 #endif
 416 {
 417   long f;
 418   long t;
 419   SCM answer;
 420   SCM len_str;
 421
 422   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_make_shared_substring);
 423
 424   if (frm == SCM_UNDEFINED)
 425     frm = SCM_MAKINUM (0);
 426   else
 427     SCM_ASSERT (SCM_INUMP (frm), frm, SCM_ARG2, s_make_shared_substring);
 428
 429   if (to == SCM_UNDEFINED)
 430     to = SCM_MAKINUM (SCM_ROLENGTH (str));
 431   else
 432     SCM_ASSERT (SCM_INUMP (to), to, SCM_ARG3, s_make_shared_substring);
 433
 434   f = SCM_INUM (frm);
 435   t = SCM_INUM (to);
 436   SCM_ASSERT ((f >= 0), frm, SCM_OUTOFRANGE, s_make_shared_substring);
 437   SCM_ASSERT ((f <= t) && (t <= SCM_ROLENGTH (str)), to, SCM_OUTOFRANGE, s_make_shared_substring);
 438
 439   SCM_NEWCELL (answer);
 440   SCM_NEWCELL (len_str);
 441
 442   SCM_DEFER_INTS;
 443   if (SCM_SUBSTRP (str))
 444     {
 445       long offset;
 446       offset = SCM_INUM (SCM_SUBSTR_OFFSET (str));
 447       f += offset;
 448       t += offset;
 449       SCM_SETCAR (len_str, SCM_MAKINUM (f));
 450       SCM_SETCDR (len_str, SCM_SUBSTR_STR (str));
 451       SCM_SETCDR (answer, len_str);
 452       SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
 453     }
 454   else
 455     {
 456       SCM_SETCAR (len_str, SCM_MAKINUM (f));
 457       SCM_SETCDR (len_str, str);
 458       SCM_SETCDR (answer, len_str);
 459       SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
 460     }
 461   SCM_ALLOW_INTS;
 462   return answer;
 463 }
 464
 465 #ifdef __STDC__
 466 void
 467 scm_init_strings (void)
 468 #else
 469 void
 470 scm_init_strings ()
 471 #endif
 472 {
 473 #include "strings.x"
 474 }
 475