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, SCM_ARG1, "gh_scm2ulong");
 233 }
 234 long
 235 gh_scm2long (SCM obj)
 236 {
 237   return scm_num2long (obj, 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, 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)
 399             ? SCM_INUM (val)
 400             : scm_num2long (val, 0, NULL);
 401         }
 402       break;
 403 #ifdef HAVE_ARRAYS
 404     case scm_tc7_ivect:
 405     case scm_tc7_uvect:
 406       n = SCM_UVECTOR_LENGTH (obj);
 407       if (m == 0)
 408         m = (long *) malloc (n * sizeof (long));
 409       if (m == NULL)
 410         return NULL;
 411       memcpy (m, SCM_VELTS (obj), n * sizeof (long));
 412       break;
 413 #endif
 414     default:
 415       scm_wrong_type_arg (0, 0, obj);
 416     }
 417   return m;
 418 }
 419
 420 /* Convert a vector, weak vector or uniform vector into an array of
 421    floats.  If result array in arg 2 is NULL, malloc a new one.  If
 422    out of memory, return NULL.  */
 423 float *
 424 gh_scm2floats (SCM obj, float *m)
 425 {
 426   int i, n;
 427   SCM val;
 428   if (SCM_IMP (obj))
 429     scm_wrong_type_arg (0, 0, obj);
 430   switch (SCM_TYP7 (obj))
 431     {
 432     case scm_tc7_vector:
 433     case scm_tc7_wvect:
 434       n = SCM_VECTOR_LENGTH (obj);
 435       for (i = 0; i < n; ++i)
 436         {
 437           val = SCM_VELTS (obj)[i];
 438           if (!SCM_INUMP (val)
 439               && !(SCM_BIGP (val) || SCM_REALP (val)))
 440             scm_wrong_type_arg (0, 0, val);
 441         }
 442       if (m == 0)
 443         m = (float *) malloc (n * sizeof (float));
 444       if (m == NULL)
 445         return NULL;
 446       for (i = 0; i < n; ++i)
 447         {
 448           val = SCM_VELTS (obj)[i];
 449           if (SCM_INUMP (val))
 450             m[i] = SCM_INUM (val);
 451           else if (SCM_BIGP (val))
 452             m[i] = scm_num2long (val, 0, NULL);
 453           else
 454             m[i] = SCM_REAL_VALUE (val);
 455         }
 456       break;
 457 #ifdef HAVE_ARRAYS
 458     case scm_tc7_fvect:
 459       n = SCM_UVECTOR_LENGTH (obj);
 460       if (m == 0)
 461         m = (float *) malloc (n * sizeof (float));
 462       if (m == NULL)
 463         return NULL;
 464       memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float));
 465       break;
 466
 467     case scm_tc7_dvect:
 468       n = SCM_UVECTOR_LENGTH (obj);
 469       if (m == 0)
 470         m = (float*) malloc (n * sizeof (float));
 471       if (m == NULL)
 472         return NULL;
 473       for (i = 0; i < n; ++i)
 474         m[i] = ((double *) SCM_VELTS (obj))[i];
 475       break;
 476 #endif
 477     default:
 478       scm_wrong_type_arg (0, 0, obj);
 479     }
 480   return m;
 481 }
 482
 483 /* Convert a vector, weak vector or uniform vector into an array of
 484    doubles.  If result array in arg 2 is NULL, malloc a new one.  If
 485    out of memory, return NULL.  */
 486 double *
 487 gh_scm2doubles (SCM obj, double *m)
 488 {
 489   int i, n;
 490   SCM val;
 491   if (SCM_IMP (obj))
 492     scm_wrong_type_arg (0, 0, obj);
 493   switch (SCM_TYP7 (obj))
 494     {
 495     case scm_tc7_vector:
 496     case scm_tc7_wvect:
 497       n = SCM_VECTOR_LENGTH (obj);
 498       for (i = 0; i < n; ++i)
 499         {
 500           val = SCM_VELTS (obj)[i];
 501           if (!SCM_INUMP (val)
 502               && !(SCM_BIGP (val) || SCM_REALP (val)))
 503             scm_wrong_type_arg (0, 0, val);
 504         }
 505       if (m == 0)
 506         m = (double *) malloc (n * sizeof (double));
 507       if (m == NULL)
 508         return NULL;
 509       for (i = 0; i < n; ++i)
 510         {
 511           val = SCM_VELTS (obj)[i];
 512           if (SCM_INUMP (val))
 513             m[i] = SCM_INUM (val);
 514           else if (SCM_BIGP (val))
 515             m[i] = scm_num2long (val, 0, NULL);
 516           else
 517             m[i] = SCM_REAL_VALUE (val);
 518         }
 519       break;
 520 #ifdef HAVE_ARRAYS
 521     case scm_tc7_fvect:
 522       n = SCM_UVECTOR_LENGTH (obj);
 523       if (m == 0)
 524         m = (double *) malloc (n * sizeof (double));
 525       if (m == NULL)
 526         return NULL;
 527       for (i = 0; i < n; ++i)
 528         m[i] = ((float *) SCM_VELTS (obj))[i];
 529       break;
 530
 531     case scm_tc7_dvect:
 532       n = SCM_UVECTOR_LENGTH (obj);
 533       if (m == 0)
 534         m = (double*) malloc (n * sizeof (double));
 535       if (m == NULL)
 536         return NULL;
 537       memcpy (m, SCM_VELTS (obj), n * sizeof (double));
 538       break;
 539 #endif
 540     default:
 541       scm_wrong_type_arg (0, 0, obj);
 542     }
 543   return m;
 544 }
 545
 546 /* string conversions between C and Scheme */
 547
 548 /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
 549    new copy of its contents, followed by a null byte.  If lenp is
 550    non-null, set *lenp to the string's length.
 551
 552    This function uses malloc to obtain storage for the copy; the
 553    caller is responsible for freeing it.  If out of memory, NULL is
 554    returned.
 555
 556    Note that Scheme strings may contain arbitrary data, including null
 557    characters.  This means that null termination is not a reliable way
 558    to determine the length of the returned value.  However, the
 559    function always copies the complete contents of STR, and sets
 560    *LEN_P to the true length of the string (when LEN_P is non-null).  */
 561 char *
 562 gh_scm2newstr (SCM str, int *lenp)
 563 {
 564   char *ret_str;
 565   int len;
 566
 567   SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr");
 568
 569   len = SCM_STRING_LENGTH (str);
 570
 571   ret_str = (char *) malloc ((len + 1) * sizeof (char));
 572   if (ret_str == NULL)
 573     return NULL;
 574   /* so we copy tmp_str to ret_str, which is what we will allocate */
 575   memcpy (ret_str, SCM_STRING_CHARS (str), len);
 576   scm_remember_upto_here_1 (str);
 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 /* Copy LEN characters at START from the Scheme string SRC to memory
 590    at DST.  START is an index into SRC; zero means the beginning of
 591    the string.  DST has already been allocated by the caller.
 592
 593    If START + LEN is off the end of SRC, silently truncate the source
 594    region to fit the string.  If truncation occurs, the corresponding
 595    area of DST is left unchanged.  */
 596 void
 597 gh_get_substr (SCM src, char *dst, int start, int len)
 598 {
 599   int src_len, effective_length;
 600   SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr");
 601
 602   src_len = SCM_STRING_LENGTH (src);
 603   effective_length = (len < src_len) ? len : src_len;
 604   memcpy (dst + start, SCM_STRING_CHARS (src), effective_length * sizeof (char));
 605   /* FIXME: must signal an error if len > src_len */
 606   scm_remember_upto_here_1 (src);
 607 }
 608
 609
 610 /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
 611    pointer to a string with the symbol characters "identifier",
 612    followed by a null byte.  If lenp is non-null, set *lenp to the
 613    string's length.
 614
 615    This function uses malloc to obtain storage for the copy; the
 616    caller is responsible for freeing it.  If out of memory, NULL is
 617    returned.*/
 618 char *
 619 gh_symbol2newstr (SCM sym, int *lenp)
 620 {
 621   char *ret_str;
 622   int len;
 623
 624   SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol");
 625
 626   len = SCM_SYMBOL_LENGTH (sym);
 627
 628   ret_str = (char *) malloc ((len + 1) * sizeof (char));
 629   if (ret_str == NULL)
 630     return NULL;
 631   /* so we copy sym to ret_str, which is what we will allocate */
 632   memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len);
 633   scm_remember_upto_here_1 (sym);
 634   /* now make sure we null-terminate it */
 635   ret_str[len] = '\0';
 636
 637   if (lenp != NULL)
 638     {
 639       *lenp = len;
 640     }
 641
 642   return ret_str;
 643 }
 644
 645
 646 /* create a new vector of the given length, all initialized to the
 647    given value */
 648 SCM
 649 gh_make_vector (SCM len, SCM fill)
 650 {
 651   return scm_make_vector (len, fill);
 652 }
 653
 654 /* set the given element of the given vector to the given value */
 655 SCM
 656 gh_vector_set_x (SCM vec, SCM pos, SCM val)
 657 {
 658   return scm_vector_set_x (vec, pos, val);
 659 }
 660
 661 /* retrieve the given element of the given vector */
 662 SCM
 663 gh_vector_ref (SCM vec, SCM pos)
 664 {
 665   return scm_vector_ref (vec, pos);
 666 }
 667
 668 /* returns the length of the given vector */
 669 unsigned long
 670 gh_vector_length (SCM v)
 671 {
 672   return gh_scm2ulong (scm_vector_length (v));
 673 }
 674
 675 #ifdef HAVE_ARRAYS
 676 /* uniform vector support */
 677
 678 /* returns the length as a C unsigned long integer */
 679 unsigned long
 680 gh_uniform_vector_length (SCM v)
 681 {
 682   return gh_scm2ulong (scm_uniform_vector_length (v));
 683 }
 684
 685 /* gets the given element from a uniform vector; ilist is a list (or
 686    possibly a single integer) of indices, and its length is the
 687    dimension of the uniform vector */
 688 SCM
 689 gh_uniform_vector_ref (SCM v, SCM ilist)
 690 {
 691   return scm_uniform_vector_ref (v, ilist);
 692 }
 693
 694 /* sets an individual element in a uniform vector */
 695 /* SCM */
 696 /* gh_list_to_uniform_array ( */
 697 #endif
 698
 699 /* Data lookups between C and Scheme
 700
 701    Look up a symbol with a given name, and return the object to which
 702    it is bound.  gh_lookup examines the Guile top level, and
 703    gh_module_lookup checks the module namespace specified by the
 704    `vec' argument.
 705
 706    The return value is the Scheme object to which SNAME is bound, or
 707    SCM_UNDEFINED if SNAME is not bound in the given context.
 708  */
 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 */