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, size_t 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, long start, size_t len)
  99 {
 100   char *dst_ptr;
 101   size_t dst_len;
 102   size_t 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 && len <= dst_len,
 109               dst, SCM_ARG4, "gh_set_substr");
 110
 111   effective_length = (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, long n)
 125 {
 126   long 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_i_long2big (d[i]));
 132
 133   return v;
 134 }
 135
 136 SCM
 137 gh_doubles2scm (const double *d, long n)
 138 {
 139   long 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, size_t 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, long 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, long 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, long 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, long 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, long 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, long 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   return (int) scm_num2int (obj, SCM_ARG1, "gh_scm2int");
 233 }
 234 double
 235 gh_scm2double (SCM obj)
 236 {
 237   return scm_num2dbl (obj, "gh_scm2double");
 238 }
 239 char
 240 gh_scm2char (SCM obj)
 241 #define FUNC_NAME "gh_scm2char"
 242 {
 243   SCM_VALIDATE_CHAR (SCM_ARG1, obj);
 244   return SCM_CHAR (obj);
 245 }
 246 #undef FUNC_NAME
 247
 248 /* Convert a vector, weak vector, string, substring or uniform vector
 249    into an array of chars.  If result array in arg 2 is NULL, malloc a
 250    new one.  If out of memory, return NULL.  */
 251 char *
 252 gh_scm2chars (SCM obj, char *m)
 253 {
 254   long i, n;
 255   long v;
 256   SCM val;
 257   if (SCM_IMP (obj))
 258     scm_wrong_type_arg (0, 0, obj);
 259   switch (SCM_TYP7 (obj))
 260     {
 261     case scm_tc7_vector:
 262     case scm_tc7_wvect:
 263       n = SCM_VECTOR_LENGTH (obj);
 264       for (i = 0; i < n; ++i)
 265         {
 266           val = SCM_VELTS (obj)[i];
 267           if (SCM_INUMP (val))
 268             {
 269               v = SCM_INUM (val);
 270               if (v < -128 || v > 255)
 271                 scm_out_of_range (0, obj);
 272             }
 273           else
 274             scm_wrong_type_arg (0, 0, obj);
 275         }
 276       if (m == 0)
 277         m = (char *) malloc (n * sizeof (char));
 278       if (m == NULL)
 279         return NULL;
 280       for (i = 0; i < n; ++i)
 281         m[i] = SCM_INUM (SCM_VELTS (obj)[i]);
 282       break;
 283 #ifdef HAVE_ARRAYS
 284     case scm_tc7_byvect:
 285       n = SCM_UVECTOR_LENGTH (obj);
 286       if (m == 0)
 287         m = (char *) malloc (n * sizeof (char));
 288       if (m == NULL)
 289         return NULL;
 290       memcpy (m, SCM_VELTS (obj), n * sizeof (char));
 291       break;
 292 #endif
 293     case scm_tc7_string:
 294     case scm_tc7_substring:
 295       n = SCM_STRING_LENGTH (obj);
 296       if (m == 0)
 297         m = (char *) malloc (n * sizeof (char));
 298       if (m == NULL)
 299         return NULL;
 300       memcpy (m, SCM_VELTS (obj), n * sizeof (char));
 301       break;
 302     default:
 303       scm_wrong_type_arg (0, 0, obj);
 304     }
 305   return m;
 306 }
 307
 308 /* Convert a vector, weak vector or uniform vector into an array of
 309    shorts.  If result array in arg 2 is NULL, malloc a new one.  If
 310    out of memory, return NULL.  */
 311 short *
 312 gh_scm2shorts (SCM obj, short *m)
 313 {
 314   long i, n;
 315   long v;
 316   SCM val;
 317   if (SCM_IMP (obj))
 318     scm_wrong_type_arg (0, 0, obj);
 319   switch (SCM_TYP7 (obj))
 320     {
 321     case scm_tc7_vector:
 322     case scm_tc7_wvect:
 323       n = SCM_VECTOR_LENGTH (obj);
 324       for (i = 0; i < n; ++i)
 325         {
 326           val = SCM_VELTS (obj)[i];
 327           if (SCM_INUMP (val))
 328             {
 329               v = SCM_INUM (val);
 330               if (v < -32768 || v > 65535)
 331                 scm_out_of_range (0, obj);
 332             }
 333           else
 334             scm_wrong_type_arg (0, 0, obj);
 335         }
 336       if (m == 0)
 337         m = (short *) malloc (n * sizeof (short));
 338       if (m == NULL)
 339         return NULL;
 340       for (i = 0; i < n; ++i)
 341         m[i] = SCM_INUM (SCM_VELTS (obj)[i]);
 342       break;
 343 #ifdef HAVE_ARRAYS
 344     case scm_tc7_svect:
 345       n = SCM_UVECTOR_LENGTH (obj);
 346       if (m == 0)
 347         m = (short *) malloc (n * sizeof (short));
 348       if (m == NULL)
 349         return NULL;
 350       memcpy (m, SCM_VELTS (obj), n * sizeof (short));
 351       break;
 352 #endif
 353     default:
 354       scm_wrong_type_arg (0, 0, obj);
 355     }
 356   return m;
 357 }
 358
 359 /* Convert a vector, weak vector or uniform vector into an array of
 360    longs.  If result array in arg 2 is NULL, malloc a new one.  If out
 361    of memory, return NULL.  */
 362 long *
 363 gh_scm2longs (SCM obj, long *m)
 364 {
 365   long i, n;
 366   SCM val;
 367   if (SCM_IMP (obj))
 368     scm_wrong_type_arg (0, 0, obj);
 369   switch (SCM_TYP7 (obj))
 370     {
 371     case scm_tc7_vector:
 372     case scm_tc7_wvect:
 373       n = SCM_VECTOR_LENGTH (obj);
 374       for (i = 0; i < n; ++i)
 375         {
 376           val = SCM_VELTS (obj)[i];
 377           if (!SCM_INUMP (val) && !SCM_BIGP (val))
 378             scm_wrong_type_arg (0, 0, obj);
 379         }
 380       if (m == 0)
 381         m = (long *) malloc (n * sizeof (long));
 382       if (m == NULL)
 383         return NULL;
 384       for (i = 0; i < n; ++i)
 385         {
 386           val = SCM_VELTS (obj)[i];
 387           m[i] = SCM_INUMP (val)
 388             ? SCM_INUM (val)
 389             : scm_num2long (val, 0, NULL);
 390         }
 391       break;
 392 #ifdef HAVE_ARRAYS
 393     case scm_tc7_ivect:
 394     case scm_tc7_uvect:
 395       n = SCM_UVECTOR_LENGTH (obj);
 396       if (m == 0)
 397         m = (long *) malloc (n * sizeof (long));
 398       if (m == NULL)
 399         return NULL;
 400       memcpy (m, SCM_VELTS (obj), n * sizeof (long));
 401       break;
 402 #endif
 403     default:
 404       scm_wrong_type_arg (0, 0, obj);
 405     }
 406   return m;
 407 }
 408
 409 /* Convert a vector, weak vector or uniform vector into an array of
 410    floats.  If result array in arg 2 is NULL, malloc a new one.  If
 411    out of memory, return NULL.  */
 412 float *
 413 gh_scm2floats (SCM obj, float *m)
 414 {
 415   long i, n;
 416   SCM val;
 417   if (SCM_IMP (obj))
 418     scm_wrong_type_arg (0, 0, obj);
 419   switch (SCM_TYP7 (obj))
 420     {
 421     case scm_tc7_vector:
 422     case scm_tc7_wvect:
 423       n = SCM_VECTOR_LENGTH (obj);
 424       for (i = 0; i < n; ++i)
 425         {
 426           val = SCM_VELTS (obj)[i];
 427           if (!SCM_INUMP (val)
 428               && !(SCM_BIGP (val) || SCM_REALP (val)))
 429             scm_wrong_type_arg (0, 0, val);
 430         }
 431       if (m == 0)
 432         m = (float *) malloc (n * sizeof (float));
 433       if (m == NULL)
 434         return NULL;
 435       for (i = 0; i < n; ++i)
 436         {
 437           val = SCM_VELTS (obj)[i];
 438           if (SCM_INUMP (val))
 439             m[i] = SCM_INUM (val);
 440           else if (SCM_BIGP (val))
 441             m[i] = scm_num2long (val, 0, NULL);
 442           else
 443             m[i] = SCM_REAL_VALUE (val);
 444         }
 445       break;
 446 #ifdef HAVE_ARRAYS
 447     case scm_tc7_fvect:
 448       n = SCM_UVECTOR_LENGTH (obj);
 449       if (m == 0)
 450         m = (float *) malloc (n * sizeof (float));
 451       if (m == NULL)
 452         return NULL;
 453       memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float));
 454       break;
 455
 456     case scm_tc7_dvect:
 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       for (i = 0; i < n; ++i)
 463         m[i] = ((double *) SCM_VELTS (obj))[i];
 464       break;
 465 #endif
 466     default:
 467       scm_wrong_type_arg (0, 0, obj);
 468     }
 469   return m;
 470 }
 471
 472 /* Convert a vector, weak vector or uniform vector into an array of
 473    doubles.  If result array in arg 2 is NULL, malloc a new one.  If
 474    out of memory, return NULL.  */
 475 double *
 476 gh_scm2doubles (SCM obj, double *m)
 477 {
 478   long i, n;
 479   SCM val;
 480   if (SCM_IMP (obj))
 481     scm_wrong_type_arg (0, 0, obj);
 482   switch (SCM_TYP7 (obj))
 483     {
 484     case scm_tc7_vector:
 485     case scm_tc7_wvect:
 486       n = SCM_VECTOR_LENGTH (obj);
 487       for (i = 0; i < n; ++i)
 488         {
 489           val = SCM_VELTS (obj)[i];
 490           if (!SCM_INUMP (val)
 491               && !(SCM_BIGP (val) || SCM_REALP (val)))
 492             scm_wrong_type_arg (0, 0, val);
 493         }
 494       if (m == 0)
 495         m = (double *) malloc (n * sizeof (double));
 496       if (m == NULL)
 497         return NULL;
 498       for (i = 0; i < n; ++i)
 499         {
 500           val = SCM_VELTS (obj)[i];
 501           if (SCM_INUMP (val))
 502             m[i] = SCM_INUM (val);
 503           else if (SCM_BIGP (val))
 504             m[i] = scm_num2long (val, 0, NULL);
 505           else
 506             m[i] = SCM_REAL_VALUE (val);
 507         }
 508       break;
 509 #ifdef HAVE_ARRAYS
 510     case scm_tc7_fvect:
 511       n = SCM_UVECTOR_LENGTH (obj);
 512       if (m == 0)
 513         m = (double *) malloc (n * sizeof (double));
 514       if (m == NULL)
 515         return NULL;
 516       for (i = 0; i < n; ++i)
 517         m[i] = ((float *) SCM_VELTS (obj))[i];
 518       break;
 519
 520     case scm_tc7_dvect:
 521       n = SCM_UVECTOR_LENGTH (obj);
 522       if (m == 0)
 523         m = (double*) malloc (n * sizeof (double));
 524       if (m == NULL)
 525         return NULL;
 526       memcpy (m, SCM_VELTS (obj), n * sizeof (double));
 527       break;
 528 #endif
 529     default:
 530       scm_wrong_type_arg (0, 0, obj);
 531     }
 532   return m;
 533 }
 534
 535 /* string conversions between C and Scheme */
 536
 537 /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
 538    new copy of its contents, followed by a null byte.  If lenp is
 539    non-null, set *lenp to the string's length.
 540
 541    This function uses malloc to obtain storage for the copy; the
 542    caller is responsible for freeing it.  If out of memory, NULL is
 543    returned.
 544
 545    Note that Scheme strings may contain arbitrary data, including null
 546    characters.  This means that null termination is not a reliable way
 547    to determine the length of the returned value.  However, the
 548    function always copies the complete contents of STR, and sets
 549    *LEN_P to the true length of the string (when LEN_P is non-null).  */
 550 char *
 551 gh_scm2newstr (SCM str, size_t *lenp)
 552 {
 553   char *ret_str;
 554   size_t len;
 555
 556   SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr");
 557
 558   len = SCM_STRING_LENGTH (str);
 559
 560   ret_str = (char *) malloc ((len + 1) * sizeof (char));
 561   if (ret_str == NULL)
 562     return NULL;
 563   /* so we copy tmp_str to ret_str, which is what we will allocate */
 564   memcpy (ret_str, SCM_STRING_CHARS (str), len);
 565   scm_remember_upto_here_1 (str);
 566   /* now make sure we null-terminate it */
 567   ret_str[len] = '\0';
 568
 569   if (lenp != NULL)
 570     {
 571       *lenp = len;
 572     }
 573
 574   return ret_str;
 575 }
 576
 577
 578 /* Copy LEN characters at START from the Scheme string SRC to memory
 579    at DST.  START is an index into SRC; zero means the beginning of
 580    the string.  DST has already been allocated by the caller.
 581
 582    If START + LEN is off the end of SRC, silently truncate the source
 583    region to fit the string.  If truncation occurs, the corresponding
 584    area of DST is left unchanged.  */
 585 void
 586 gh_get_substr (SCM src, char *dst, long start, size_t len)
 587 {
 588   size_t src_len, effective_length;
 589   SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr");
 590
 591   src_len = SCM_STRING_LENGTH (src);
 592   effective_length = (len < src_len) ? len : src_len;
 593   memcpy (dst + start, SCM_STRING_CHARS (src), effective_length * sizeof (char));
 594   /* FIXME: must signal an error if len > src_len */
 595   scm_remember_upto_here_1 (src);
 596 }
 597
 598
 599 /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
 600    pointer to a string with the symbol characters "identifier",
 601    followed by a null byte.  If lenp is non-null, set *lenp to the
 602    string's length.
 603
 604    This function uses malloc to obtain storage for the copy; the
 605    caller is responsible for freeing it.  If out of memory, NULL is
 606    returned.*/
 607 char *
 608 gh_symbol2newstr (SCM sym, size_t *lenp)
 609 {
 610   char *ret_str;
 611   size_t len;
 612
 613   SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol");
 614
 615   len = SCM_SYMBOL_LENGTH (sym);
 616
 617   ret_str = (char *) malloc ((len + 1) * sizeof (char));
 618   if (ret_str == NULL)
 619     return NULL;
 620   /* so we copy sym to ret_str, which is what we will allocate */
 621   memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len);
 622   scm_remember_upto_here_1 (sym);
 623   /* now make sure we null-terminate it */
 624   ret_str[len] = '\0';
 625
 626   if (lenp != NULL)
 627     {
 628       *lenp = len;
 629     }
 630
 631   return ret_str;
 632 }
 633
 634
 635 /* create a new vector of the given length, all initialized to the
 636    given value */
 637 SCM
 638 gh_make_vector (SCM len, SCM fill)
 639 {
 640   return scm_make_vector (len, fill);
 641 }
 642
 643 /* set the given element of the given vector to the given value */
 644 SCM
 645 gh_vector_set_x (SCM vec, SCM pos, SCM val)
 646 {
 647   return scm_vector_set_x (vec, pos, val);
 648 }
 649
 650 /* retrieve the given element of the given vector */
 651 SCM
 652 gh_vector_ref (SCM vec, SCM pos)
 653 {
 654   return scm_vector_ref (vec, pos);
 655 }
 656
 657 /* returns the length of the given vector */
 658 unsigned long
 659 gh_vector_length (SCM v)
 660 {
 661   return (unsigned long) SCM_VECTOR_LENGTH (v);
 662 }
 663
 664 #ifdef HAVE_ARRAYS
 665 /* uniform vector support */
 666
 667 /* returns the length as a C unsigned long integer */
 668 unsigned long
 669 gh_uniform_vector_length (SCM v)
 670 {
 671   return (unsigned long) SCM_UVECTOR_LENGTH (v);
 672 }
 673
 674 /* gets the given element from a uniform vector; ilist is a list (or
 675    possibly a single integer) of indices, and its length is the
 676    dimension of the uniform vector */
 677 SCM
 678 gh_uniform_vector_ref (SCM v, SCM ilist)
 679 {
 680   return scm_uniform_vector_ref (v, ilist);
 681 }
 682
 683 /* sets an individual element in a uniform vector */
 684 /* SCM */
 685 /* gh_list_to_uniform_array ( */
 686 #endif
 687
 688 /* Data lookups between C and Scheme
 689
 690    Look up a symbol with a given name, and return the object to which
 691    it is bound.  gh_lookup examines the Guile top level, and
 692    gh_module_lookup checks the module namespace specified by the
 693    `vec' argument.
 694
 695    The return value is the Scheme object to which SNAME is bound, or
 696    SCM_UNDEFINED if SNAME is not bound in the given context.
 697  */
 698
 699 SCM
 700 gh_lookup (const char *sname)
 701 {
 702   return gh_module_lookup (scm_current_module (), sname);
 703 }
 704
 705
 706 SCM
 707 gh_module_lookup (SCM module, const char *sname)
 708 #define FUNC_NAME "gh_module_lookup"
 709 {
 710   SCM sym, var;
 711
 712   SCM_VALIDATE_MODULE (SCM_ARG1, module);
 713
 714   sym = gh_symbol2scm (sname);
 715   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
 716   if (var != SCM_BOOL_F)
 717     return SCM_VARIABLE_REF (var);
 718   else
 719     return SCM_UNDEFINED;
 720 }
 721 #undef FUNC_NAME
 722
 723 /*
 724   Local Variables:
 725   c-file-style: "gnu"
 726   End:
 727 */