libguile/gh_data.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
   2  * This program is free software; you can redistribute it and/or modify
   3  * it under the terms of the GNU General Public License as published by
   4  * the Free Software Foundation; either version 2, or (at your option)
   5  * any later version.
   6  *
   7  * This program 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
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this software; see the file COPYING.  If not, write to
  14  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  15  * Boston, MA 02111-1307 USA
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.  */
  40 \f
  41
  42 /* data initialization and C<->Scheme data conversion */
  43
  44 #include "libguile/gh.h"
  45 #ifdef HAVE_STRING_H
  46 #include <string.h>
  47 #endif
  48
  49 /* data conversion C->scheme */
  50
  51 #if (SCM_DEBUG_DEPRECATED == 0)
  52
  53 SCM
  54 gh_int2scmb (int x)             /* this is being phased out */
  55 {
  56   return SCM_BOOL(x);
  57 }
  58
  59 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
  60
  61 SCM
  62 gh_bool2scm (int x)
  63 {
  64   return SCM_BOOL(x);
  65 }
  66 SCM
  67 gh_int2scm (int x)
  68 {
  69   return scm_long2num ((long) x);
  70 }
  71 SCM
  72 gh_ulong2scm (unsigned long x)
  73 {
  74   return scm_ulong2num (x);
  75 }
  76 SCM
  77 gh_long2scm (long x)
  78 {
  79   return scm_long2num (x);
  80 }
  81 SCM
  82 gh_double2scm (double x)
  83 {
  84   return scm_make_real (x);
  85 }
  86 SCM
  87 gh_char2scm (char c)
  88 {
  89  return SCM_MAKE_CHAR (c);
  90 }
  91 SCM
  92 gh_str2scm (const char *s, int len)
  93 {
  94   return scm_makfromstr (s, len, 0);
  95 }
  96 SCM
  97 gh_str02scm (const char *s)
  98 {
  99   return scm_makfrom0str (s);
 100 }
 101 /* Copy LEN characters at SRC into the *existing* Scheme string DST,
 102    starting at START.  START is an index into DST; zero means the
 103    beginning of the string.
 104
 105    If START + LEN is off the end of DST, signal an out-of-range
 106    error.  */
 107 void
 108 gh_set_substr (char *src, SCM dst, int start, int len)
 109 {
 110   char *dst_ptr;
 111   unsigned long dst_len;
 112   unsigned long effective_length;
 113
 114   SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr");
 115
 116   dst_ptr = SCM_STRING_CHARS (dst);
 117   dst_len = SCM_STRING_LENGTH (dst);
 118   SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len,
 119               dst, SCM_ARG4, "gh_set_substr");
 120
 121   effective_length = ((unsigned) len < dst_len) ? len : dst_len;
 122   memmove (dst_ptr + start, src, effective_length);
 123   scm_remember_upto_here_1 (dst);
 124 }
 125
 126 /* Return the symbol named SYMBOL_STR.  */
 127 SCM
 128 gh_symbol2scm (const char *symbol_str)
 129 {
 130   return scm_str2symbol(symbol_str);
 131 }
 132
 133 SCM
 134 gh_ints2scm (const int *d, int n)
 135 {
 136   int i;
 137   SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
 138   SCM *velts = SCM_VELTS(v);
 139
 140   for (i = 0; i < n; ++i)
 141     velts[i] = (SCM_FIXABLE (d[i]) ? SCM_MAKINUM (d[i]) : scm_long2big (d[i]));
 142
 143   return v;
 144 }
 145
 146 SCM
 147 gh_doubles2scm (const double *d, int n)
 148 {
 149   int i;
 150   SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
 151   SCM *velts = SCM_VELTS(v);
 152
 153   for(i = 0; i < n; i++)
 154     velts[i] = scm_make_real (d[i]);
 155   return v;
 156 }
 157
 158 #ifdef HAVE_ARRAYS
 159 /* Do not use this function for building normal Scheme vectors, unless
 160    you arrange for the elements to be protected from GC while you
 161    initialize the vector.  */
 162 static SCM
 163 makvect (char* m, int len, int type)
 164 {
 165   SCM ans;
 166   SCM_NEWCELL (ans);
 167   SCM_DEFER_INTS;
 168   SCM_SET_UVECTOR_BASE (ans, m);
 169   SCM_SET_UVECTOR_LENGTH (ans, len, type);
 170   SCM_ALLOW_INTS;
 171   return ans;
 172 }
 173
 174 SCM
 175 gh_chars2byvect (const char *d, int n)
 176 {
 177   char *m = scm_must_malloc (n * sizeof (char), "vector");
 178   memcpy (m, d, n * sizeof (char));
 179   return makvect (m, n, scm_tc7_byvect);
 180 }
 181
 182 SCM
 183 gh_shorts2svect (const short *d, int n)
 184 {
 185   char *m = scm_must_malloc (n * sizeof (short), "vector");
 186   memcpy (m, d, n * sizeof (short));
 187   return makvect (m, n, scm_tc7_svect);
 188 }
 189
 190 SCM
 191 gh_longs2ivect (const long *d, int n)
 192 {
 193   char *m = scm_must_malloc (n * sizeof (long), "vector");
 194   memcpy (m, d, n * sizeof (long));
 195   return makvect (m, n, scm_tc7_ivect);
 196 }
 197
 198 SCM
 199 gh_ulongs2uvect (const unsigned long *d, int n)
 200 {
 201   char *m = scm_must_malloc (n * sizeof (unsigned long), "vector");
 202   memcpy (m, d, n * sizeof (unsigned long));
 203   return makvect (m, n, scm_tc7_uvect);
 204 }
 205
 206 SCM
 207 gh_floats2fvect (const float *d, int n)
 208 {
 209   char *m = scm_must_malloc (n * sizeof (float), "vector");
 210   memcpy (m, d, n * sizeof (float));
 211   return makvect (m, n, scm_tc7_fvect);
 212 }
 213
 214 SCM
 215 gh_doubles2dvect (const double *d, int n)
 216 {
 217   char *m = scm_must_malloc (n * sizeof (double), "vector");
 218   memcpy (m, d, n * sizeof (double));
 219   return makvect (m, n, scm_tc7_dvect);
 220 }
 221 #endif
 222
 223 /* data conversion scheme->C */
 224 int
 225 gh_scm2bool (SCM obj)
 226 {
 227   return (SCM_FALSEP (obj)) ? 0 : 1;
 228 }
 229 unsigned long
 230 gh_scm2ulong (SCM obj)
 231 {
 232   return scm_num2ulong (obj, (char *) SCM_ARG1, "gh_scm2ulong");
 233 }
 234 long
 235 gh_scm2long (SCM obj)
 236 {
 237   return scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2long");
 238 }
 239 int
 240 gh_scm2int (SCM obj)
 241 {
 242   /* NOTE: possible loss of precision here */
 243   return (int) scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2int");
 244 }
 245 double
 246 gh_scm2double (SCM obj)
 247 {
 248   return scm_num2dbl (obj, "gh_scm2double");
 249 }
 250 char
 251 gh_scm2char (SCM obj)
 252 #define FUNC_NAME "gh_scm2char"
 253 {
 254   SCM_VALIDATE_CHAR (SCM_ARG1, obj);
 255   return SCM_CHAR (obj);
 256 }
 257 #undef FUNC_NAME
 258
 259 /* Convert a vector, weak vector, string, substring or uniform vector
 260    into an array of chars.  If result array in arg 2 is NULL, malloc a
 261    new one.  If out of memory, return NULL.  */
 262 char *
 263 gh_scm2chars (SCM obj, char *m)
 264 {
 265   int i, n;
 266   long v;
 267   SCM val;
 268   if (SCM_IMP (obj))
 269     scm_wrong_type_arg (0, 0, obj);
 270   switch (SCM_TYP7 (obj))
 271     {
 272     case scm_tc7_vector:
 273     case scm_tc7_wvect:
 274       n = SCM_VECTOR_LENGTH (obj);
 275       for (i = 0; i < n; ++i)
 276         {
 277           val = SCM_VELTS (obj)[i];
 278           if (SCM_INUMP (val))
 279             {
 280               v = SCM_INUM (val);
 281               if (v < -128 || v > 255)
 282                 scm_out_of_range (0, obj);
 283             }
 284           else
 285             scm_wrong_type_arg (0, 0, obj);
 286         }
 287       if (m == 0)
 288         m = (char *) malloc (n * sizeof (char));
 289       if (m == NULL)
 290         return NULL;
 291       for (i = 0; i < n; ++i)
 292         m[i] = SCM_INUM (SCM_VELTS (obj)[i]);
 293       break;
 294 #ifdef HAVE_ARRAYS
 295     case scm_tc7_byvect:
 296       n = SCM_UVECTOR_LENGTH (obj);
 297       if (m == 0)
 298         m = (char *) malloc (n * sizeof (char));
 299       if (m == NULL)
 300         return NULL;
 301       memcpy (m, SCM_VELTS (obj), n * sizeof (char));
 302       break;
 303 #endif
 304     case scm_tc7_string:
 305     case scm_tc7_substring:
 306       n = SCM_STRING_LENGTH (obj);
 307       if (m == 0)
 308         m = (char *) malloc (n * sizeof (char));
 309       if (m == NULL)
 310         return NULL;
 311       memcpy (m, SCM_VELTS (obj), n * sizeof (char));
 312       break;
 313     default:
 314       scm_wrong_type_arg (0, 0, obj);
 315     }
 316   return m;
 317 }
 318
 319 /* Convert a vector, weak vector or uniform vector into an array of
 320    shorts.  If result array in arg 2 is NULL, malloc a new one.  If
 321    out of memory, return NULL.  */
 322 short *
 323 gh_scm2shorts (SCM obj, short *m)
 324 {
 325   int i, n;
 326   long v;
 327   SCM val;
 328   if (SCM_IMP (obj))
 329     scm_wrong_type_arg (0, 0, obj);
 330   switch (SCM_TYP7 (obj))
 331     {
 332     case scm_tc7_vector:
 333     case scm_tc7_wvect:
 334       n = SCM_VECTOR_LENGTH (obj);
 335       for (i = 0; i < n; ++i)
 336         {
 337           val = SCM_VELTS (obj)[i];
 338           if (SCM_INUMP (val))
 339             {
 340               v = SCM_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_INUM (SCM_VELTS (obj)[i]);
 353       break;
 354 #ifdef HAVE_ARRAYS
 355     case scm_tc7_svect:
 356       n = SCM_UVECTOR_LENGTH (obj);
 357       if (m == 0)
 358         m = (short *) malloc (n * sizeof (short));
 359       if (m == NULL)
 360         return NULL;
 361       memcpy (m, SCM_VELTS (obj), n * sizeof (short));
 362       break;
 363 #endif
 364     default:
 365       scm_wrong_type_arg (0, 0, obj);
 366     }
 367   return m;
 368 }
 369
 370 /* Convert a vector, weak vector or uniform vector into an array of
 371    longs.  If result array in arg 2 is NULL, malloc a new one.  If out
 372    of memory, return NULL.  */
 373 long *
 374 gh_scm2longs (SCM obj, long *m)
 375 {
 376   int i, n;
 377   SCM val;
 378   if (SCM_IMP (obj))
 379     scm_wrong_type_arg (0, 0, obj);
 380   switch (SCM_TYP7 (obj))
 381     {
 382     case scm_tc7_vector:
 383     case scm_tc7_wvect:
 384       n = SCM_VECTOR_LENGTH (obj);
 385       for (i = 0; i < n; ++i)
 386         {
 387           val = SCM_VELTS (obj)[i];
 388           if (!SCM_INUMP (val) && !SCM_BIGP (val))
 389             scm_wrong_type_arg (0, 0, obj);
 390         }
 391       if (m == 0)
 392         m = (long *) malloc (n * sizeof (long));
 393       if (m == NULL)
 394         return NULL;
 395       for (i = 0; i < n; ++i)
 396         {
 397           val = SCM_VELTS (obj)[i];
 398           m[i] = SCM_INUMP (val) ? SCM_INUM (val) : scm_num2long (val, 0, 0);
 399         }
 400       break;
 401 #ifdef HAVE_ARRAYS
 402     case scm_tc7_ivect:
 403     case scm_tc7_uvect:
 404       n = SCM_UVECTOR_LENGTH (obj);
 405       if (m == 0)
 406         m = (long *) malloc (n * sizeof (long));
 407       if (m == NULL)
 408         return NULL;
 409       memcpy (m, SCM_VELTS (obj), n * sizeof (long));
 410       break;
 411 #endif
 412     default:
 413       scm_wrong_type_arg (0, 0, obj);
 414     }
 415   return m;
 416 }
 417
 418 /* Convert a vector, weak vector or uniform vector into an array of
 419    floats.  If result array in arg 2 is NULL, malloc a new one.  If
 420    out of memory, return NULL.  */
 421 float *
 422 gh_scm2floats (SCM obj, float *m)
 423 {
 424   int i, n;
 425   SCM val;
 426   if (SCM_IMP (obj))
 427     scm_wrong_type_arg (0, 0, obj);
 428   switch (SCM_TYP7 (obj))
 429     {
 430     case scm_tc7_vector:
 431     case scm_tc7_wvect:
 432       n = SCM_VECTOR_LENGTH (obj);
 433       for (i = 0; i < n; ++i)
 434         {
 435           val = SCM_VELTS (obj)[i];
 436           if (!SCM_INUMP (val)
 437               && !(SCM_BIGP (val) || SCM_REALP (val)))
 438             scm_wrong_type_arg (0, 0, val);
 439         }
 440       if (m == 0)
 441         m = (float *) malloc (n * sizeof (float));
 442       if (m == NULL)
 443         return NULL;
 444       for (i = 0; i < n; ++i)
 445         {
 446           val = SCM_VELTS (obj)[i];
 447           if (SCM_INUMP (val))
 448             m[i] = SCM_INUM (val);
 449           else if (SCM_BIGP (val))
 450             m[i] = scm_num2long (val, 0, 0);
 451           else
 452             m[i] = SCM_REAL_VALUE (val);
 453         }
 454       break;
 455 #ifdef HAVE_ARRAYS
 456     case scm_tc7_fvect:
 457       n = SCM_UVECTOR_LENGTH (obj);
 458       if (m == 0)
 459         m = (float *) malloc (n * sizeof (float));
 460       if (m == NULL)
 461         return NULL;
 462       memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float));
 463       break;
 464
 465     case scm_tc7_dvect:
 466       n = SCM_UVECTOR_LENGTH (obj);
 467       if (m == 0)
 468         m = (float*) malloc (n * sizeof (float));
 469       if (m == NULL)
 470         return NULL;
 471       for (i = 0; i < n; ++i)
 472         m[i] = ((double *) SCM_VELTS (obj))[i];
 473       break;
 474 #endif
 475     default:
 476       scm_wrong_type_arg (0, 0, obj);
 477     }
 478   return m;
 479 }
 480
 481 /* Convert a vector, weak vector or uniform vector into an array of
 482    doubles.  If result array in arg 2 is NULL, malloc a new one.  If
 483    out of memory, return NULL.  */
 484 double *
 485 gh_scm2doubles (SCM obj, double *m)
 486 {
 487   int i, n;
 488   SCM val;
 489   if (SCM_IMP (obj))
 490     scm_wrong_type_arg (0, 0, obj);
 491   switch (SCM_TYP7 (obj))
 492     {
 493     case scm_tc7_vector:
 494     case scm_tc7_wvect:
 495       n = SCM_VECTOR_LENGTH (obj);
 496       for (i = 0; i < n; ++i)
 497         {
 498           val = SCM_VELTS (obj)[i];
 499           if (!SCM_INUMP (val)
 500               && !(SCM_BIGP (val) || SCM_REALP (val)))
 501             scm_wrong_type_arg (0, 0, val);
 502         }
 503       if (m == 0)
 504         m = (double *) malloc (n * sizeof (double));
 505       if (m == NULL)
 506         return NULL;
 507       for (i = 0; i < n; ++i)
 508         {
 509           val = SCM_VELTS (obj)[i];
 510           if (SCM_INUMP (val))
 511             m[i] = SCM_INUM (val);
 512           else if (SCM_BIGP (val))
 513             m[i] = scm_num2long (val, 0, 0);
 514           else
 515             m[i] = SCM_REAL_VALUE (val);
 516         }
 517       break;
 518 #ifdef HAVE_ARRAYS
 519     case scm_tc7_fvect:
 520       n = SCM_UVECTOR_LENGTH (obj);
 521       if (m == 0)
 522         m = (double *) malloc (n * sizeof (double));
 523       if (m == NULL)
 524         return NULL;
 525       for (i = 0; i < n; ++i)
 526         m[i] = ((float *) SCM_VELTS (obj))[i];
 527       break;
 528
 529     case scm_tc7_dvect:
 530       n = SCM_UVECTOR_LENGTH (obj);
 531       if (m == 0)
 532         m = (double*) malloc (n * sizeof (double));
 533       if (m == NULL)
 534         return NULL;
 535       memcpy (m, SCM_VELTS (obj), n * sizeof (double));
 536       break;
 537 #endif
 538     default:
 539       scm_wrong_type_arg (0, 0, obj);
 540     }
 541   return m;
 542 }
 543
 544 /* string conversions between C and Scheme */
 545
 546 /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
 547    new copy of its contents, followed by a null byte.  If lenp is
 548    non-null, set *lenp to the string's length.
 549
 550    This function uses malloc to obtain storage for the copy; the
 551    caller is responsible for freeing it.  If out of memory, NULL is
 552    returned.
 553
 554    Note that Scheme strings may contain arbitrary data, including null
 555    characters.  This means that null termination is not a reliable way
 556    to determine the length of the returned value.  However, the
 557    function always copies the complete contents of STR, and sets
 558    *LEN_P to the true length of the string (when LEN_P is non-null).  */
 559 char *
 560 gh_scm2newstr (SCM str, int *lenp)
 561 {
 562   char *ret_str;
 563   int len;
 564
 565   SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr");
 566
 567   len = SCM_STRING_LENGTH (str);
 568
 569   ret_str = (char *) malloc ((len + 1) * sizeof (char));
 570   if (ret_str == NULL)
 571     return NULL;
 572   /* so we copy tmp_str to ret_str, which is what we will allocate */
 573   memcpy (ret_str, SCM_STRING_CHARS (str), len);
 574   scm_remember_upto_here_1 (str);
 575   /* now make sure we null-terminate it */
 576   ret_str[len] = '\0';
 577
 578   if (lenp != NULL)
 579     {
 580       *lenp = len;
 581     }
 582
 583   return ret_str;
 584 }
 585
 586
 587 /* Copy LEN characters at START from the Scheme string SRC to memory
 588    at DST.  START is an index into SRC; zero means the beginning of
 589    the string.  DST has already been allocated by the caller.
 590
 591    If START + LEN is off the end of SRC, silently truncate the source
 592    region to fit the string.  If truncation occurs, the corresponding
 593    area of DST is left unchanged.  */
 594 void
 595 gh_get_substr (SCM src, char *dst, int start, int len)
 596 {
 597   int src_len, effective_length;
 598   SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr");
 599
 600   src_len = SCM_STRING_LENGTH (src);
 601   effective_length = (len < src_len) ? len : src_len;
 602   memcpy (dst + start, SCM_STRING_CHARS (src), effective_length * sizeof (char));
 603   /* FIXME: must signal an error if len > src_len */
 604   scm_remember_upto_here_1 (src);
 605 }
 606
 607
 608 /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
 609    pointer to a string with the symbol characters "identifier",
 610    followed by a null byte.  If lenp is non-null, set *lenp to the
 611    string's length.
 612
 613    This function uses malloc to obtain storage for the copy; the
 614    caller is responsible for freeing it.  If out of memory, NULL is
 615    returned.*/
 616 char *
 617 gh_symbol2newstr (SCM sym, int *lenp)
 618 {
 619   char *ret_str;
 620   int len;
 621
 622   SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol");
 623
 624   len = SCM_SYMBOL_LENGTH (sym);
 625
 626   ret_str = (char *) malloc ((len + 1) * sizeof (char));
 627   if (ret_str == NULL)
 628     return NULL;
 629   /* so we copy sym to ret_str, which is what we will allocate */
 630   memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len);
 631   scm_remember_upto_here_1 (sym);
 632   /* now make sure we null-terminate it */
 633   ret_str[len] = '\0';
 634
 635   if (lenp != NULL)
 636     {
 637       *lenp = len;
 638     }
 639
 640   return ret_str;
 641 }
 642
 643
 644 /* create a new vector of the given length, all initialized to the
 645    given value */
 646 SCM
 647 gh_make_vector (SCM len, SCM fill)
 648 {
 649   return scm_make_vector (len, fill);
 650 }
 651
 652 /* set the given element of the given vector to the given value */
 653 SCM
 654 gh_vector_set_x (SCM vec, SCM pos, SCM val)
 655 {
 656   return scm_vector_set_x (vec, pos, val);
 657 }
 658
 659 /* retrieve the given element of the given vector */
 660 SCM
 661 gh_vector_ref (SCM vec, SCM pos)
 662 {
 663   return scm_vector_ref (vec, pos);
 664 }
 665
 666 /* returns the length of the given vector */
 667 unsigned long
 668 gh_vector_length (SCM v)
 669 {
 670   return gh_scm2ulong (scm_vector_length (v));
 671 }
 672
 673 #ifdef HAVE_ARRAYS
 674 /* uniform vector support */
 675
 676 /* returns the length as a C unsigned long integer */
 677 unsigned long
 678 gh_uniform_vector_length (SCM v)
 679 {
 680   return gh_scm2ulong (scm_uniform_vector_length (v));
 681 }
 682
 683 /* gets the given element from a uniform vector; ilist is a list (or
 684    possibly a single integer) of indices, and its length is the
 685    dimension of the uniform vector */
 686 SCM
 687 gh_uniform_vector_ref (SCM v, SCM ilist)
 688 {
 689   return scm_uniform_vector_ref (v, ilist);
 690 }
 691
 692 /* sets an individual element in a uniform vector */
 693 /* SCM */
 694 /* gh_list_to_uniform_array ( */
 695 #endif
 696
 697 /* Data lookups between C and Scheme
 698
 699    Look up a symbol with a given name, and return the object to which
 700    it is bound.  gh_lookup examines the Guile top level, and
 701    gh_module_lookup checks the module namespace specified by the
 702    `vec' argument.
 703
 704    The return value is the Scheme object to which SNAME is bound, or
 705    SCM_UNDEFINED if SNAME is not bound in the given context. [FIXME:
 706    should this be SCM_UNSPECIFIED?  Can a symbol ever legitimately be
 707    bound to SCM_UNDEFINED or SCM_UNSPECIFIED?  What is the difference?
 708    -twp] */
 709
 710 SCM
 711 gh_lookup (const char *sname)
 712 {
 713   return gh_module_lookup (SCM_BOOL_F, sname);
 714 }
 715
 716 SCM
 717 gh_module_lookup (SCM vec, const char *sname)
 718 {
 719   SCM sym = gh_symbol2scm (sname);
 720   if (SCM_EQ_P (scm_symbol_bound_p (vec, sym), SCM_BOOL_T))
 721     return scm_symbol_binding (vec, sym);
 722   else
 723     return SCM_UNDEFINED;
 724 }
 725
 726 /*
 727   Local Variables:
 728   c-file-style: "gnu"
 729   End:
 730 */