libguile/gh_data.c

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