libguile/gh_data.c

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