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