libguile/gh_data.c

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