libguile/gh_data.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2004 Free Software Foundation, Inc.
   2  * This library is free software; you can redistribute it and/or
   3  * modify it under the terms of the GNU Lesser General Public
   4  * License as published by the Free Software Foundation; either
   5  * version 2.1 of the License, or (at your option) any later version.
   6  *
   7  * This library is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  10  * Lesser General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU Lesser General Public
  13  * License along with this library; if not, write to the Free Software
  14  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  15  */
  16 \f
  17
  18 /* data initialization and C<->Scheme data conversion */
  19
  20 #if HAVE_CONFIG_H
  21 #  include <config.h>
  22 #endif
  23
  24 #include "libguile/gh.h"
  25 #ifdef HAVE_STRING_H
  26 #include <string.h>
  27 #endif
  28
  29 /* data conversion C->scheme */
  30
  31 SCM
  32 gh_bool2scm (int x)
  33 {
  34   return scm_from_bool(x);
  35 }
  36 SCM
  37 gh_int2scm (int x)
  38 {
  39   return scm_from_long ((long) x);
  40 }
  41 SCM
  42 gh_ulong2scm (unsigned long x)
  43 {
  44   return scm_from_ulong (x);
  45 }
  46 SCM
  47 gh_long2scm (long x)
  48 {
  49   return scm_from_long (x);
  50 }
  51 SCM
  52 gh_double2scm (double x)
  53 {
  54   return scm_from_double (x);
  55 }
  56 SCM
  57 gh_char2scm (char c)
  58 {
  59  return SCM_MAKE_CHAR (c);
  60 }
  61 SCM
  62 gh_str2scm (const char *s, size_t len)
  63 {
  64   return scm_from_locale_stringn (s, len);
  65 }
  66 SCM
  67 gh_str02scm (const char *s)
  68 {
  69   return scm_from_locale_string (s);
  70 }
  71 /* Copy LEN characters at SRC into the *existing* Scheme string DST,
  72    starting at START.  START is an index into DST; zero means the
  73    beginning of the string.
  74
  75    If START + LEN is off the end of DST, signal an out-of-range
  76    error.  */
  77 void
  78 gh_set_substr (const char *src, SCM dst, long start, size_t len)
  79 {
  80   char *dst_ptr;
  81   size_t dst_len;
  82
  83   SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr");
  84
  85   dst_len = scm_i_string_length (dst);
  86   SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr");
  87
  88   dst_ptr = scm_i_string_writable_chars (dst);
  89   memmove (dst_ptr + start, src, len);
  90   scm_i_string_stop_writing ();
  91   scm_remember_upto_here_1 (dst);
  92 }
  93
  94 /* Return the symbol named SYMBOL_STR.  */
  95 SCM
  96 gh_symbol2scm (const char *symbol_str)
  97 {
  98   return scm_from_locale_symbol(symbol_str);
  99 }
 100
 101 SCM
 102 gh_ints2scm (const int *d, long n)
 103 {
 104   long i;
 105   SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
 106   for (i = 0; i < n; ++i)
 107     SCM_VECTOR_SET (v, i, scm_from_int (d[i]));
 108
 109   return v;
 110 }
 111
 112 SCM
 113 gh_doubles2scm (const double *d, long n)
 114 {
 115   long i;
 116   SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
 117
 118   for(i = 0; i < n; i++)
 119     SCM_VECTOR_SET (v, i, scm_from_double (d[i]));
 120   return v;
 121 }
 122
 123 #if SCM_HAVE_ARRAYS
 124 /* Do not use this function for building normal Scheme vectors, unless
 125    you arrange for the elements to be protected from GC while you
 126    initialize the vector.  */
 127 static SCM
 128 makvect (char *m, size_t len, int type)
 129 {
 130   return scm_cell (SCM_MAKE_UVECTOR_TAG (len, type), (scm_t_bits) m);
 131 }
 132
 133 SCM
 134 gh_chars2byvect (const char *d, long n)
 135 {
 136   char *m = scm_gc_malloc (n * sizeof (char), "vector");
 137   memcpy (m, d, n * sizeof (char));
 138   return makvect (m, n, scm_tc7_byvect);
 139 }
 140
 141 SCM
 142 gh_shorts2svect (const short *d, long n)
 143 {
 144   char *m = scm_gc_malloc (n * sizeof (short), "vector");
 145   memcpy (m, d, n * sizeof (short));
 146   return makvect (m, n, scm_tc7_svect);
 147 }
 148
 149 SCM
 150 gh_longs2ivect (const long *d, long n)
 151 {
 152   char *m = scm_gc_malloc (n * sizeof (long), "vector");
 153   memcpy (m, d, n * sizeof (long));
 154   return makvect (m, n, scm_tc7_ivect);
 155 }
 156
 157 SCM
 158 gh_ulongs2uvect (const unsigned long *d, long n)
 159 {
 160   char *m = scm_gc_malloc (n * sizeof (unsigned long), "vector");
 161   memcpy (m, d, n * sizeof (unsigned long));
 162   return makvect (m, n, scm_tc7_uvect);
 163 }
 164
 165 SCM
 166 gh_floats2fvect (const float *d, long n)
 167 {
 168   char *m = scm_gc_malloc (n * sizeof (float), "vector");
 169   memcpy (m, d, n * sizeof (float));
 170   return makvect (m, n, scm_tc7_fvect);
 171 }
 172
 173 SCM
 174 gh_doubles2dvect (const double *d, long n)
 175 {
 176   char *m = scm_gc_malloc (n * sizeof (double), "vector");
 177   memcpy (m, d, n * sizeof (double));
 178   return makvect (m, n, scm_tc7_dvect);
 179 }
 180 #endif
 181
 182 /* data conversion scheme->C */
 183 int
 184 gh_scm2bool (SCM obj)
 185 {
 186   return (scm_is_false (obj)) ? 0 : 1;
 187 }
 188 unsigned long
 189 gh_scm2ulong (SCM obj)
 190 {
 191   return scm_to_ulong (obj);
 192 }
 193 long
 194 gh_scm2long (SCM obj)
 195 {
 196   return scm_to_long (obj);
 197 }
 198 int
 199 gh_scm2int (SCM obj)
 200 {
 201   return scm_to_int (obj);
 202 }
 203 double
 204 gh_scm2double (SCM obj)
 205 {
 206   return scm_to_double (obj);
 207 }
 208 char
 209 gh_scm2char (SCM obj)
 210 #define FUNC_NAME "gh_scm2char"
 211 {
 212   SCM_VALIDATE_CHAR (SCM_ARG1, obj);
 213   return SCM_CHAR (obj);
 214 }
 215 #undef FUNC_NAME
 216
 217 /* Convert a vector, weak vector, string, substring or uniform vector
 218    into an array of chars.  If result array in arg 2 is NULL, malloc a
 219    new one.  If out of memory, return NULL.  */
 220 char *
 221 gh_scm2chars (SCM obj, char *m)
 222 {
 223   long i, n;
 224   long v;
 225   SCM val;
 226   if (SCM_IMP (obj))
 227     scm_wrong_type_arg (0, 0, obj);
 228   switch (SCM_TYP7 (obj))
 229     {
 230     case scm_tc7_vector:
 231     case scm_tc7_wvect:
 232       n = SCM_VECTOR_LENGTH (obj);
 233       for (i = 0; i < n; ++i)
 234         {
 235           val = SCM_VELTS (obj)[i];
 236           if (SCM_I_INUMP (val))
 237             {
 238               v = SCM_I_INUM (val);
 239               if (v < -128 || v > 255)
 240                 scm_out_of_range (0, obj);
 241             }
 242           else
 243             scm_wrong_type_arg (0, 0, obj);
 244         }
 245       if (m == 0)
 246         m = (char *) malloc (n * sizeof (char));
 247       if (m == NULL)
 248         return NULL;
 249       for (i = 0; i < n; ++i)
 250         m[i] = SCM_I_INUM (SCM_VELTS (obj)[i]);
 251       break;
 252 #if SCM_HAVE_ARRAYS
 253     case scm_tc7_byvect:
 254       n = SCM_UVECTOR_LENGTH (obj);
 255       if (m == 0)
 256         m = (char *) malloc (n * sizeof (char));
 257       if (m == NULL)
 258         return NULL;
 259       memcpy (m, SCM_VELTS (obj), n * sizeof (char));
 260       break;
 261 #endif
 262     case scm_tc7_string:
 263       n = scm_i_string_length (obj);
 264       if (m == 0)
 265         m = (char *) malloc (n * sizeof (char));
 266       if (m == NULL)
 267         return NULL;
 268       memcpy (m, scm_i_string_chars (obj), n * sizeof (char));
 269       break;
 270     default:
 271       scm_wrong_type_arg (0, 0, obj);
 272     }
 273   return m;
 274 }
 275
 276 /* Convert a vector, weak vector or uniform vector into an array of
 277    shorts.  If result array in arg 2 is NULL, malloc a new one.  If
 278    out of memory, return NULL.  */
 279 short *
 280 gh_scm2shorts (SCM obj, short *m)
 281 {
 282   long i, n;
 283   long v;
 284   SCM val;
 285   if (SCM_IMP (obj))
 286     scm_wrong_type_arg (0, 0, obj);
 287   switch (SCM_TYP7 (obj))
 288     {
 289     case scm_tc7_vector:
 290     case scm_tc7_wvect:
 291       n = SCM_VECTOR_LENGTH (obj);
 292       for (i = 0; i < n; ++i)
 293         {
 294           val = SCM_VELTS (obj)[i];
 295           if (SCM_I_INUMP (val))
 296             {
 297               v = SCM_I_INUM (val);
 298               if (v < -32768 || v > 65535)
 299                 scm_out_of_range (0, obj);
 300             }
 301           else
 302             scm_wrong_type_arg (0, 0, obj);
 303         }
 304       if (m == 0)
 305         m = (short *) malloc (n * sizeof (short));
 306       if (m == NULL)
 307         return NULL;
 308       for (i = 0; i < n; ++i)
 309         m[i] = SCM_I_INUM (SCM_VELTS (obj)[i]);
 310       break;
 311 #if SCM_HAVE_ARRAYS
 312     case scm_tc7_svect:
 313       n = SCM_UVECTOR_LENGTH (obj);
 314       if (m == 0)
 315         m = (short *) malloc (n * sizeof (short));
 316       if (m == NULL)
 317         return NULL;
 318       memcpy (m, SCM_VELTS (obj), n * sizeof (short));
 319       break;
 320 #endif
 321     default:
 322       scm_wrong_type_arg (0, 0, obj);
 323     }
 324   return m;
 325 }
 326
 327 /* Convert a vector, weak vector or uniform vector into an array of
 328    longs.  If result array in arg 2 is NULL, malloc a new one.  If out
 329    of memory, return NULL.  */
 330 long *
 331 gh_scm2longs (SCM obj, long *m)
 332 {
 333   long i, n;
 334   SCM val;
 335   if (SCM_IMP (obj))
 336     scm_wrong_type_arg (0, 0, obj);
 337   switch (SCM_TYP7 (obj))
 338     {
 339     case scm_tc7_vector:
 340     case scm_tc7_wvect:
 341       n = SCM_VECTOR_LENGTH (obj);
 342       for (i = 0; i < n; ++i)
 343         {
 344           val = SCM_VELTS (obj)[i];
 345           if (!SCM_I_INUMP (val) && !SCM_BIGP (val))
 346             scm_wrong_type_arg (0, 0, obj);
 347         }
 348       if (m == 0)
 349         m = (long *) malloc (n * sizeof (long));
 350       if (m == NULL)
 351         return NULL;
 352       for (i = 0; i < n; ++i)
 353         {
 354           val = SCM_VELTS (obj)[i];
 355           m[i] = SCM_I_INUMP (val)
 356             ? SCM_I_INUM (val)
 357             : scm_to_long (val);
 358         }
 359       break;
 360 #if SCM_HAVE_ARRAYS
 361     case scm_tc7_ivect:
 362     case scm_tc7_uvect:
 363       n = SCM_UVECTOR_LENGTH (obj);
 364       if (m == 0)
 365         m = (long *) malloc (n * sizeof (long));
 366       if (m == NULL)
 367         return NULL;
 368       memcpy (m, SCM_VELTS (obj), n * sizeof (long));
 369       break;
 370 #endif
 371     default:
 372       scm_wrong_type_arg (0, 0, obj);
 373     }
 374   return m;
 375 }
 376
 377 /* Convert a vector, weak vector or uniform vector into an array of
 378    floats.  If result array in arg 2 is NULL, malloc a new one.  If
 379    out of memory, return NULL.  */
 380 float *
 381 gh_scm2floats (SCM obj, float *m)
 382 {
 383   long i, n;
 384   SCM val;
 385   if (SCM_IMP (obj))
 386     scm_wrong_type_arg (0, 0, obj);
 387   switch (SCM_TYP7 (obj))
 388     {
 389     case scm_tc7_vector:
 390     case scm_tc7_wvect:
 391       n = SCM_VECTOR_LENGTH (obj);
 392       for (i = 0; i < n; ++i)
 393         {
 394           val = SCM_VELTS (obj)[i];
 395           if (!SCM_I_INUMP (val)
 396               && !(SCM_BIGP (val) || SCM_REALP (val)))
 397             scm_wrong_type_arg (0, 0, val);
 398         }
 399       if (m == 0)
 400         m = (float *) malloc (n * sizeof (float));
 401       if (m == NULL)
 402         return NULL;
 403       for (i = 0; i < n; ++i)
 404         {
 405           val = SCM_VELTS (obj)[i];
 406           if (SCM_I_INUMP (val))
 407             m[i] = SCM_I_INUM (val);
 408           else if (SCM_BIGP (val))
 409             m[i] = scm_to_long (val);
 410           else
 411             m[i] = SCM_REAL_VALUE (val);
 412         }
 413       break;
 414 #if SCM_HAVE_ARRAYS
 415     case scm_tc7_fvect:
 416       n = SCM_UVECTOR_LENGTH (obj);
 417       if (m == 0)
 418         m = (float *) malloc (n * sizeof (float));
 419       if (m == NULL)
 420         return NULL;
 421       memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float));
 422       break;
 423
 424     case scm_tc7_dvect:
 425       n = SCM_UVECTOR_LENGTH (obj);
 426       if (m == 0)
 427         m = (float*) malloc (n * sizeof (float));
 428       if (m == NULL)
 429         return NULL;
 430       for (i = 0; i < n; ++i)
 431         m[i] = ((double *) SCM_VELTS (obj))[i];
 432       break;
 433 #endif
 434     default:
 435       scm_wrong_type_arg (0, 0, obj);
 436     }
 437   return m;
 438 }
 439
 440 /* Convert a vector, weak vector or uniform vector into an array of
 441    doubles.  If result array in arg 2 is NULL, malloc a new one.  If
 442    out of memory, return NULL.  */
 443 double *
 444 gh_scm2doubles (SCM obj, double *m)
 445 {
 446   long i, n;
 447   SCM val;
 448   if (SCM_IMP (obj))
 449     scm_wrong_type_arg (0, 0, obj);
 450   switch (SCM_TYP7 (obj))
 451     {
 452     case scm_tc7_vector:
 453     case scm_tc7_wvect:
 454       n = SCM_VECTOR_LENGTH (obj);
 455       for (i = 0; i < n; ++i)
 456         {
 457           val = SCM_VELTS (obj)[i];
 458           if (!SCM_I_INUMP (val)
 459               && !(SCM_BIGP (val) || SCM_REALP (val)))
 460             scm_wrong_type_arg (0, 0, val);
 461         }
 462       if (m == 0)
 463         m = (double *) malloc (n * sizeof (double));
 464       if (m == NULL)
 465         return NULL;
 466       for (i = 0; i < n; ++i)
 467         {
 468           val = SCM_VELTS (obj)[i];
 469           if (SCM_I_INUMP (val))
 470             m[i] = SCM_I_INUM (val);
 471           else if (SCM_BIGP (val))
 472             m[i] = scm_to_long (val);
 473           else
 474             m[i] = SCM_REAL_VALUE (val);
 475         }
 476       break;
 477 #if SCM_HAVE_ARRAYS
 478     case scm_tc7_fvect:
 479       n = SCM_UVECTOR_LENGTH (obj);
 480       if (m == 0)
 481         m = (double *) malloc (n * sizeof (double));
 482       if (m == NULL)
 483         return NULL;
 484       for (i = 0; i < n; ++i)
 485         m[i] = ((float *) SCM_VELTS (obj))[i];
 486       break;
 487
 488     case scm_tc7_dvect:
 489       n = SCM_UVECTOR_LENGTH (obj);
 490       if (m == 0)
 491         m = (double*) malloc (n * sizeof (double));
 492       if (m == NULL)
 493         return NULL;
 494       memcpy (m, SCM_VELTS (obj), n * sizeof (double));
 495       break;
 496 #endif
 497     default:
 498       scm_wrong_type_arg (0, 0, obj);
 499     }
 500   return m;
 501 }
 502
 503 /* string conversions between C and Scheme */
 504
 505 /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
 506    new copy of its contents, followed by a null byte.  If lenp is
 507    non-null, set *lenp to the string's length.
 508
 509    This function uses malloc to obtain storage for the copy; the
 510    caller is responsible for freeing it.  If out of memory, NULL is
 511    returned.
 512
 513    Note that Scheme strings may contain arbitrary data, including null
 514    characters.  This means that null termination is not a reliable way
 515    to determine the length of the returned value.  However, the
 516    function always copies the complete contents of STR, and sets
 517    *LEN_P to the true length of the string (when LEN_P is non-null).  */
 518 char *
 519 gh_scm2newstr (SCM str, size_t *lenp)
 520 {
 521   char *ret_str;
 522
 523   /* We can't use scm_to_locale_stringn directly since it does not
 524      guarantee null-termination when lenp is non-NULL.
 525    */
 526
 527   ret_str = scm_to_locale_string (str);
 528   if (lenp)
 529     *lenp = scm_i_string_length (str);
 530   return ret_str;
 531 }
 532
 533 /* Copy LEN characters at START from the Scheme string SRC to memory
 534    at DST.  START is an index into SRC; zero means the beginning of
 535    the string.  DST has already been allocated by the caller.
 536
 537    If START + LEN is off the end of SRC, silently truncate the source
 538    region to fit the string.  If truncation occurs, the corresponding
 539    area of DST is left unchanged.  */
 540 void
 541 gh_get_substr (SCM src, char *dst, long start, size_t len)
 542 {
 543   size_t src_len, effective_length;
 544   SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr");
 545
 546   src_len = scm_i_string_length (src);
 547   effective_length = (len < src_len) ? len : src_len;
 548   memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char));
 549   /* FIXME: must signal an error if len > src_len */
 550   scm_remember_upto_here_1 (src);
 551 }
 552
 553
 554 /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
 555    pointer to a string with the symbol characters "identifier",
 556    followed by a null byte.  If lenp is non-null, set *lenp to the
 557    string's length.
 558
 559    This function uses malloc to obtain storage for the copy; the
 560    caller is responsible for freeing it.  If out of memory, NULL is
 561    returned.*/
 562 char *
 563 gh_symbol2newstr (SCM sym, size_t *lenp)
 564 {
 565   return gh_scm2newstr (scm_symbol_to_string (sym), lenp);
 566 }
 567
 568
 569 /* create a new vector of the given length, all initialized to the
 570    given value */
 571 SCM
 572 gh_make_vector (SCM len, SCM fill)
 573 {
 574   return scm_make_vector (len, fill);
 575 }
 576
 577 /* set the given element of the given vector to the given value */
 578 SCM
 579 gh_vector_set_x (SCM vec, SCM pos, SCM val)
 580 {
 581   return scm_vector_set_x (vec, pos, val);
 582 }
 583
 584 /* retrieve the given element of the given vector */
 585 SCM
 586 gh_vector_ref (SCM vec, SCM pos)
 587 {
 588   return scm_vector_ref (vec, pos);
 589 }
 590
 591 /* returns the length of the given vector */
 592 unsigned long
 593 gh_vector_length (SCM v)
 594 {
 595   return (unsigned long) SCM_VECTOR_LENGTH (v);
 596 }
 597
 598 #if SCM_HAVE_ARRAYS
 599 /* uniform vector support */
 600
 601 /* returns the length as a C unsigned long integer */
 602 unsigned long
 603 gh_uniform_vector_length (SCM v)
 604 {
 605   return (unsigned long) SCM_UVECTOR_LENGTH (v);
 606 }
 607
 608 /* gets the given element from a uniform vector; ilist is a list (or
 609    possibly a single integer) of indices, and its length is the
 610    dimension of the uniform vector */
 611 SCM
 612 gh_uniform_vector_ref (SCM v, SCM ilist)
 613 {
 614   return scm_uniform_vector_ref (v, ilist);
 615 }
 616
 617 /* sets an individual element in a uniform vector */
 618 /* SCM */
 619 /* gh_list_to_uniform_array ( */
 620 #endif
 621
 622 /* Data lookups between C and Scheme
 623
 624    Look up a symbol with a given name, and return the object to which
 625    it is bound.  gh_lookup examines the Guile top level, and
 626    gh_module_lookup checks the module namespace specified by the
 627    `vec' argument.
 628
 629    The return value is the Scheme object to which SNAME is bound, or
 630    SCM_UNDEFINED if SNAME is not bound in the given context.
 631  */
 632
 633 SCM
 634 gh_lookup (const char *sname)
 635 {
 636   return gh_module_lookup (scm_current_module (), sname);
 637 }
 638
 639
 640 SCM
 641 gh_module_lookup (SCM module, const char *sname)
 642 #define FUNC_NAME "gh_module_lookup"
 643 {
 644   SCM sym, var;
 645
 646   SCM_VALIDATE_MODULE (SCM_ARG1, module);
 647
 648   sym = scm_from_locale_symbol (sname);
 649   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
 650   if (var != SCM_BOOL_F)
 651     return SCM_VARIABLE_REF (var);
 652   else
 653     return SCM_UNDEFINED;
 654 }
 655 #undef FUNC_NAME
 656
 657 /*
 658   Local Variables:
 659   c-file-style: "gnu"
 660   End:
 661 */