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