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