guile18/libguile/gh_data.c

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