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_BOOL(x);
  35 }
  36 SCM
  37 gh_int2scm (int x)
  38 {
  39   return scm_long2num ((long) x);
  40 }
  41 SCM
  42 gh_ulong2scm (unsigned long x)
  43 {
  44   return scm_ulong2num (x);
  45 }
  46 SCM
  47 gh_long2scm (long x)
  48 {
  49   return scm_long2num (x);
  50 }
  51 SCM
  52 gh_double2scm (double x)
  53 {
  54   return scm_make_real (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_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr");
  84
  85   dst_ptr = SCM_STRING_CHARS (dst);
  86   dst_len = SCM_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_FIXABLE (d[i]) ? SCM_MAKINUM (d[i]) : scm_i_long2big (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_make_real (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_FALSEP (obj)) ? 0 : 1;
 186 }
 187 unsigned long
 188 gh_scm2ulong (SCM obj)
 189 {
 190   return scm_num2ulong (obj, SCM_ARG1, "gh_scm2ulong");
 191 }
 192 long
 193 gh_scm2long (SCM obj)
 194 {
 195   return scm_num2long (obj, SCM_ARG1, "gh_scm2long");
 196 }
 197 int
 198 gh_scm2int (SCM obj)
 199 {
 200   return (int) scm_num2int (obj, SCM_ARG1, "gh_scm2int");
 201 }
 202 double
 203 gh_scm2double (SCM obj)
 204 {
 205   return scm_num2dbl (obj, "gh_scm2double");
 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_INUMP (val))
 236             {
 237               v = SCM_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_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_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_VELTS (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_INUMP (val))
 295             {
 296               v = SCM_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_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_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_INUMP (val)
 355             ? SCM_INUM (val)
 356             : scm_num2long (val, 0, NULL);
 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_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_INUMP (val))
 406             m[i] = SCM_INUM (val);
 407           else if (SCM_BIGP (val))
 408             m[i] = scm_num2long (val, 0, NULL);
 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_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_INUMP (val))
 469             m[i] = SCM_INUM (val);
 470           else if (SCM_BIGP (val))
 471             m[i] = scm_num2long (val, 0, NULL);
 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   size_t len;
 522
 523   SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr");
 524
 525   len = SCM_STRING_LENGTH (str);
 526
 527   ret_str = (char *) malloc ((len + 1) * sizeof (char));
 528   if (ret_str == NULL)
 529     return NULL;
 530   /* so we copy tmp_str to ret_str, which is what we will allocate */
 531   memcpy (ret_str, SCM_STRING_CHARS (str), len);
 532   scm_remember_upto_here_1 (str);
 533   /* now make sure we null-terminate it */
 534   ret_str[len] = '\0';
 535
 536   if (lenp != NULL)
 537     {
 538       *lenp = len;
 539     }
 540
 541   return ret_str;
 542 }
 543
 544
 545 /* Copy LEN characters at START from the Scheme string SRC to memory
 546    at DST.  START is an index into SRC; zero means the beginning of
 547    the string.  DST has already been allocated by the caller.
 548
 549    If START + LEN is off the end of SRC, silently truncate the source
 550    region to fit the string.  If truncation occurs, the corresponding
 551    area of DST is left unchanged.  */
 552 void
 553 gh_get_substr (SCM src, char *dst, long start, size_t len)
 554 {
 555   size_t src_len, effective_length;
 556   SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr");
 557
 558   src_len = SCM_STRING_LENGTH (src);
 559   effective_length = (len < src_len) ? len : src_len;
 560   memcpy (dst + start, SCM_STRING_CHARS (src), effective_length * sizeof (char));
 561   /* FIXME: must signal an error if len > src_len */
 562   scm_remember_upto_here_1 (src);
 563 }
 564
 565
 566 /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
 567    pointer to a string with the symbol characters "identifier",
 568    followed by a null byte.  If lenp is non-null, set *lenp to the
 569    string's length.
 570
 571    This function uses malloc to obtain storage for the copy; the
 572    caller is responsible for freeing it.  If out of memory, NULL is
 573    returned.*/
 574 char *
 575 gh_symbol2newstr (SCM sym, size_t *lenp)
 576 {
 577   char *ret_str;
 578   size_t len;
 579
 580   SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol");
 581
 582   len = SCM_SYMBOL_LENGTH (sym);
 583
 584   ret_str = (char *) malloc ((len + 1) * sizeof (char));
 585   if (ret_str == NULL)
 586     return NULL;
 587   /* so we copy sym to ret_str, which is what we will allocate */
 588   memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len);
 589   scm_remember_upto_here_1 (sym);
 590   /* now make sure we null-terminate it */
 591   ret_str[len] = '\0';
 592
 593   if (lenp != NULL)
 594     {
 595       *lenp = len;
 596     }
 597
 598   return ret_str;
 599 }
 600
 601
 602 /* create a new vector of the given length, all initialized to the
 603    given value */
 604 SCM
 605 gh_make_vector (SCM len, SCM fill)
 606 {
 607   return scm_make_vector (len, fill);
 608 }
 609
 610 /* set the given element of the given vector to the given value */
 611 SCM
 612 gh_vector_set_x (SCM vec, SCM pos, SCM val)
 613 {
 614   return scm_vector_set_x (vec, pos, val);
 615 }
 616
 617 /* retrieve the given element of the given vector */
 618 SCM
 619 gh_vector_ref (SCM vec, SCM pos)
 620 {
 621   return scm_vector_ref (vec, pos);
 622 }
 623
 624 /* returns the length of the given vector */
 625 unsigned long
 626 gh_vector_length (SCM v)
 627 {
 628   return (unsigned long) SCM_VECTOR_LENGTH (v);
 629 }
 630
 631 #if SCM_HAVE_ARRAYS
 632 /* uniform vector support */
 633
 634 /* returns the length as a C unsigned long integer */
 635 unsigned long
 636 gh_uniform_vector_length (SCM v)
 637 {
 638   return (unsigned long) SCM_UVECTOR_LENGTH (v);
 639 }
 640
 641 /* gets the given element from a uniform vector; ilist is a list (or
 642    possibly a single integer) of indices, and its length is the
 643    dimension of the uniform vector */
 644 SCM
 645 gh_uniform_vector_ref (SCM v, SCM ilist)
 646 {
 647   return scm_uniform_vector_ref (v, ilist);
 648 }
 649
 650 /* sets an individual element in a uniform vector */
 651 /* SCM */
 652 /* gh_list_to_uniform_array ( */
 653 #endif
 654
 655 /* Data lookups between C and Scheme
 656
 657    Look up a symbol with a given name, and return the object to which
 658    it is bound.  gh_lookup examines the Guile top level, and
 659    gh_module_lookup checks the module namespace specified by the
 660    `vec' argument.
 661
 662    The return value is the Scheme object to which SNAME is bound, or
 663    SCM_UNDEFINED if SNAME is not bound in the given context.
 664  */
 665
 666 SCM
 667 gh_lookup (const char *sname)
 668 {
 669   return gh_module_lookup (scm_current_module (), sname);
 670 }
 671
 672
 673 SCM
 674 gh_module_lookup (SCM module, const char *sname)
 675 #define FUNC_NAME "gh_module_lookup"
 676 {
 677   SCM sym, var;
 678
 679   SCM_VALIDATE_MODULE (SCM_ARG1, module);
 680
 681   sym = scm_str2symbol (sname);
 682   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
 683   if (var != SCM_BOOL_F)
 684     return SCM_VARIABLE_REF (var);
 685   else
 686     return SCM_UNDEFINED;
 687 }
 688 #undef FUNC_NAME
 689
 690 /*
 691   Local Variables:
 692   c-file-style: "gnu"
 693   End:
 694 */