libguile/symbols.c

   1 /*      Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include "_scm.h"
  49 #include "chars.h"
  50 #include "eval.h"
  51 #include "variable.h"
  52 #include "alist.h"
  53 #include "weaks.h"
  54
  55 #include "scm_validate.h"
  56 #include "symbols.h"
  57
  58 #ifdef HAVE_STRING_H
  59 #include <string.h>
  60 #endif
  61
  62 \f
  63
  64
  65 /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets.
  66  */
  67 #define NUM_HASH_BUCKETS 137
  68
  69 \f
  70
  71
  72 /* {Symbols}
  73  */
  74
  75
  76 unsigned long
  77 scm_strhash (unsigned char *str,scm_sizet len,unsigned long n)
  78 {
  79   if (len > 5)
  80     {
  81       scm_sizet i = 5;
  82       unsigned long h = 264 % n;
  83       while (i--)
  84         h = ((h << 8) + ((unsigned) (scm_downcase (str[h % len])))) % n;
  85       return h;
  86     }
  87   else
  88     {
  89       scm_sizet i = len;
  90       unsigned long h = 0;
  91       while (i)
  92         h = ((h << 8) + ((unsigned) (scm_downcase (str[--i])))) % n;
  93       return h;
  94     }
  95 }
  96
  97 int scm_symhash_dim = NUM_HASH_BUCKETS;
  98
  99
 100 /* scm_sym2vcell
 101  * looks up the symbol in the symhash table.
 102  */
 103
 104 SCM
 105 scm_sym2vcell (SCM sym,SCM thunk,SCM definep)
 106 {
 107   if (SCM_NIMP(thunk))
 108     {
 109       SCM var = scm_apply (thunk, sym, scm_cons(definep, scm_listofnull));
 110
 111       if (var == SCM_BOOL_F)
 112         return SCM_BOOL_F;
 113       else
 114         {
 115           if (SCM_IMP(var) || !SCM_VARIABLEP (var))
 116             scm_wta (sym, "strangely interned symbol? ", "");
 117           return SCM_VARVCELL (var);
 118         }
 119     }
 120   else
 121     {
 122       SCM lsym;
 123       SCM * lsymp;
 124       SCM z;
 125       scm_sizet scm_hash = scm_strhash (SCM_UCHARS (sym), (scm_sizet) SCM_LENGTH (sym),
 126                                     (unsigned long) scm_symhash_dim);
 127
 128       SCM_DEFER_INTS;
 129       for (lsym = SCM_VELTS (scm_symhash)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
 130         {
 131           z = SCM_CAR (lsym);
 132           if (SCM_CAR (z) == sym)
 133             {
 134               SCM_ALLOW_INTS;
 135               return z;
 136             }
 137         }
 138
 139       for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[scm_hash]);
 140            SCM_NIMP (lsym);
 141            lsym = *(lsymp = SCM_CDRLOC (lsym)))
 142         {
 143           z = SCM_CAR (lsym);
 144           if (SCM_CAR (z) == sym)
 145             {
 146               if (SCM_NFALSEP (definep))
 147                 {
 148                   /* Move handle from scm_weak_symhash to scm_symhash. */
 149                   *lsymp = SCM_CDR (lsym);
 150                   SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[scm_hash]);
 151                   SCM_VELTS(scm_symhash)[scm_hash] = lsym;
 152                 }
 153               SCM_ALLOW_INTS;
 154               return z;
 155             }
 156         }
 157       SCM_ALLOW_INTS;
 158       return scm_wta (sym, "uninterned symbol? ", "");
 159     }
 160 }
 161
 162 /* scm_sym2ovcell
 163  * looks up the symbol in an arbitrary obarray.
 164  */
 165
 166 SCM
 167 scm_sym2ovcell_soft (SCM sym, SCM obarray)
 168 {
 169   SCM lsym, z;
 170   scm_sizet scm_hash;
 171
 172   scm_hash = scm_strhash (SCM_UCHARS (sym),
 173                           (scm_sizet) SCM_LENGTH (sym),
 174                           SCM_LENGTH (obarray));
 175   SCM_REDEFER_INTS;
 176   for (lsym = SCM_VELTS (obarray)[scm_hash];
 177        SCM_NIMP (lsym);
 178        lsym = SCM_CDR (lsym))
 179     {
 180       z = SCM_CAR (lsym);
 181       if (SCM_CAR (z) == sym)
 182         {
 183           SCM_REALLOW_INTS;
 184           return z;
 185         }
 186     }
 187   SCM_REALLOW_INTS;
 188   return SCM_BOOL_F;
 189 }
 190
 191
 192 SCM
 193 scm_sym2ovcell (SCM sym, SCM obarray)
 194 {
 195   SCM answer;
 196   answer = scm_sym2ovcell_soft (sym, obarray);
 197   if (answer != SCM_BOOL_F)
 198     return answer;
 199   scm_wta (sym, "uninterned symbol? ", "");
 200   return SCM_UNSPECIFIED;               /* not reached */
 201 }
 202
 203 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
 204
 205    OBARRAY should be a vector of lists, indexed by the name's hash
 206    value, modulo OBARRAY's length.  Each list has the form
 207    ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
 208    value associated with that symbol (in the current module?  in the
 209    system module?)
 210
 211    To "intern" a symbol means: if OBARRAY already contains a symbol by
 212    that name, return its (SYMBOL . VALUE) pair; otherwise, create a
 213    new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
 214    appropriate list of the OBARRAY, and return the pair.
 215
 216    If softness is non-zero, don't create a symbol if it isn't already
 217    in OBARRAY; instead, just return #f.
 218
 219    If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
 220    return (SYMBOL . SCM_UNDEFINED).
 221
 222    If OBARRAY is scm_symhash, and that doesn't contain the symbol,
 223    check scm_weak_symhash instead.  */
 224
 225
 226 SCM
 227 scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,int softness)
 228 {
 229   SCM lsym;
 230   SCM z;
 231   register scm_sizet i;
 232   register unsigned char *tmp;
 233   scm_sizet scm_hash;
 234
 235   SCM_REDEFER_INTS;
 236
 237   i = len;
 238   tmp = (unsigned char *) name;
 239
 240   if (obarray == SCM_BOOL_F)
 241     {
 242       scm_hash = scm_strhash (tmp, i, 1019);
 243       goto uninterned_symbol;
 244     }
 245
 246   scm_hash = scm_strhash (tmp, i, SCM_LENGTH(obarray));
 247
 248   /* softness == -1 used to mean that it was known that the symbol
 249      wasn't already in the obarray.  I don't think there are any
 250      callers that use that case any more, but just in case...
 251      -- JimB, Oct 1996  */
 252   if (softness == -1)
 253     abort ();
 254
 255  retry_new_obarray:
 256   for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
 257     {
 258       z = SCM_CAR (lsym);
 259       z = SCM_CAR (z);
 260       tmp = SCM_UCHARS (z);
 261       if (SCM_LENGTH (z) != len)
 262         goto trynext;
 263       for (i = len; i--;)
 264         if (((unsigned char *) name)[i] != tmp[i])
 265           goto trynext;
 266       {
 267         SCM a;
 268         a = SCM_CAR (lsym);
 269         SCM_REALLOW_INTS;
 270         return a;
 271       }
 272     trynext:;
 273     }
 274
 275   if (obarray == scm_symhash)
 276     {
 277       obarray = scm_weak_symhash;
 278       goto retry_new_obarray;
 279     }
 280
 281  uninterned_symbol:
 282   if (softness)
 283     {
 284       SCM_REALLOW_INTS;
 285       return SCM_BOOL_F;
 286     }
 287
 288   lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS);
 289
 290   SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol);
 291   SCM_SYMBOL_HASH (lsym) = scm_hash;
 292   SCM_SYMBOL_PROPS (lsym) = SCM_EOL;
 293   if (obarray == SCM_BOOL_F)
 294     {
 295       SCM answer;
 296       SCM_REALLOW_INTS;
 297       SCM_NEWCELL (answer);
 298       SCM_DEFER_INTS;
 299       SCM_SETCAR (answer, lsym);
 300       SCM_SETCDR (answer, SCM_UNDEFINED);
 301       SCM_REALLOW_INTS;
 302       return answer;
 303     }
 304   else
 305     {
 306       SCM a;
 307       SCM b;
 308
 309       SCM_NEWCELL (a);
 310       SCM_NEWCELL (b);
 311       SCM_SETCAR (a, lsym);
 312       SCM_SETCDR (a, SCM_UNDEFINED);
 313       SCM_SETCAR (b, a);
 314       SCM_SETCDR (b, SCM_VELTS(obarray)[scm_hash]);
 315       SCM_VELTS(obarray)[scm_hash] = b;
 316       SCM_REALLOW_INTS;
 317       return SCM_CAR (b);
 318     }
 319 }
 320
 321
 322 SCM
 323 scm_intern_obarray (const char *name,scm_sizet len,SCM obarray)
 324 {
 325   return scm_intern_obarray_soft (name, len, obarray, 0);
 326 }
 327
 328
 329 SCM
 330 scm_intern (const char *name,scm_sizet len)
 331 {
 332   return scm_intern_obarray (name, len, scm_symhash);
 333 }
 334
 335
 336 SCM
 337 scm_intern0 (const char * name)
 338 {
 339   return scm_intern (name, strlen (name));
 340 }
 341
 342
 343 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated.  */
 344 SCM
 345 scm_sysintern0_no_module_lookup (const char *name)
 346 {
 347   SCM easy_answer;
 348   SCM_DEFER_INTS;
 349   easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1);
 350   if (SCM_NIMP (easy_answer))
 351     {
 352       SCM_ALLOW_INTS;
 353       return easy_answer;
 354     }
 355   else
 356     {
 357       SCM lsym;
 358       scm_sizet len = strlen (name);
 359       register unsigned char *tmp = (unsigned char *) name;
 360       scm_sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim);
 361       SCM_NEWCELL (lsym);
 362       SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol);
 363       SCM_SETCHARS (lsym, name);
 364       lsym = scm_cons (lsym, SCM_UNDEFINED);
 365       SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]);
 366       SCM_ALLOW_INTS;
 367       return lsym;
 368     }
 369 }
 370
 371
 372 /* Is it safe to access SCM_TOP_LEVEL_LOOKUP_CLOSURE_VAR?
 373  */
 374 int scm_can_use_top_level_lookup_closure_var;
 375
 376 /* Intern the symbol named NAME in scm_symhash, and give it the value
 377    VAL.  NAME is null-terminated.  Use the current top_level lookup
 378    closure to give NAME its value.
 379  */
 380 SCM
 381 scm_sysintern (const char *name, SCM val)
 382 {
 383   SCM vcell = scm_sysintern0 (name);
 384   SCM_SETCDR (vcell, val);
 385   return vcell;
 386 }
 387
 388 SCM
 389 scm_sysintern0 (const char *name)
 390 {
 391   SCM lookup_proc;
 392   if (scm_can_use_top_level_lookup_closure_var &&
 393       SCM_NIMP (lookup_proc = SCM_CDR (scm_top_level_lookup_closure_var)))
 394     {
 395       SCM sym = SCM_CAR (scm_intern0 (name));
 396       SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T);
 397       if (vcell == SCM_BOOL_F)
 398           scm_misc_error ("sysintern", "can't define variable", sym);
 399       return vcell;
 400     }
 401   else
 402     return scm_sysintern0_no_module_lookup (name);
 403 }
 404
 405 /* Lookup the value of the symbol named by the nul-terminated string
 406    NAME in the current module.  */
 407 SCM
 408 scm_symbol_value0 (const char *name)
 409 {
 410   /* This looks silly - we look up the symbol twice.  But it is in
 411      fact necessary given the current module system because the module
 412      lookup closures are written in scheme which needs real symbols. */
 413   SCM symbol = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 0);
 414   SCM vcell = scm_sym2vcell (SCM_CAR (symbol),
 415                              SCM_CDR (scm_top_level_lookup_closure_var),
 416                              SCM_BOOL_F);
 417   if (SCM_FALSEP (vcell))
 418     return SCM_UNDEFINED;
 419   return SCM_CDR (vcell);
 420 }
 421
 422 GUILE_PROC(scm_symbol_p, "symbol?", 1, 0, 0,
 423            (SCM x),
 424 "")
 425 #define FUNC_NAME s_scm_symbol_p
 426 {
 427   if SCM_IMP(x) return SCM_BOOL_F;
 428   return SCM_BOOL(SCM_SYMBOLP(x));
 429 }
 430 #undef FUNC_NAME
 431
 432 GUILE_PROC(scm_symbol_to_string, "symbol->string", 1, 0, 0,
 433            (SCM s),
 434 "")
 435 #define FUNC_NAME s_scm_symbol_to_string
 436 {
 437   SCM_VALIDATE_SYMBOL(1,s);
 438   return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0);
 439 }
 440 #undef FUNC_NAME
 441
 442
 443 GUILE_PROC(scm_string_to_symbol, "string->symbol", 1, 0, 0,
 444            (SCM s),
 445 "")
 446 #define FUNC_NAME s_scm_string_to_symbol
 447 {
 448   SCM vcell;
 449   SCM answer;
 450
 451   SCM_VALIDATE_ROSTRING(1,s);
 452   vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s));
 453   answer = SCM_CAR (vcell);
 454   return answer;
 455 }
 456 #undef FUNC_NAME
 457
 458
 459 GUILE_PROC(scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
 460            (SCM o, SCM s, SCM softp),
 461 "")
 462 #define FUNC_NAME s_scm_string_to_obarray_symbol
 463 {
 464   SCM vcell;
 465   SCM answer;
 466   int softness;
 467
 468   SCM_VALIDATE_ROSTRING(2,s);
 469   SCM_ASSERT((o == SCM_BOOL_F)
 470              || (o == SCM_BOOL_T)
 471              || (SCM_NIMP(o) && SCM_VECTORP(o)),
 472              o, SCM_ARG1, FUNC_NAME);
 473
 474   softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F));
 475   /* iron out some screwy calling conventions */
 476   if (o == SCM_BOOL_F)
 477     o = scm_symhash;
 478   else if (o == SCM_BOOL_T)
 479     o = SCM_BOOL_F;
 480
 481   vcell = scm_intern_obarray_soft (SCM_ROCHARS(s),
 482                                    (scm_sizet)SCM_ROLENGTH(s),
 483                                    o,
 484                                    softness);
 485   if (vcell == SCM_BOOL_F)
 486     return vcell;
 487   answer = SCM_CAR (vcell);
 488   return answer;
 489 }
 490 #undef FUNC_NAME
 491
 492 GUILE_PROC(scm_intern_symbol, "intern-symbol", 2, 0, 0,
 493            (SCM o, SCM s),
 494 "")
 495 #define FUNC_NAME s_scm_intern_symbol
 496 {
 497   scm_sizet hval;
 498   SCM_VALIDATE_SYMBOL(2,s);
 499   if (o == SCM_BOOL_F)
 500     o = scm_symhash;
 501   SCM_VALIDATE_VECTOR(1,o);
 502   hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 503   /* If the symbol is already interned, simply return. */
 504   SCM_REDEFER_INTS;
 505   {
 506     SCM lsym;
 507     SCM sym;
 508     for (lsym = SCM_VELTS (o)[hval];
 509          SCM_NIMP (lsym);
 510          lsym = SCM_CDR (lsym))
 511       {
 512         sym = SCM_CAR (lsym);
 513         if (SCM_CAR (sym) == s)
 514           {
 515             SCM_REALLOW_INTS;
 516             return SCM_UNSPECIFIED;
 517           }
 518       }
 519     SCM_VELTS (o)[hval] =
 520       scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]);
 521   }
 522   SCM_REALLOW_INTS;
 523   return SCM_UNSPECIFIED;
 524 }
 525 #undef FUNC_NAME
 526
 527 GUILE_PROC(scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
 528            (SCM o, SCM s),
 529 "")
 530 #define FUNC_NAME s_scm_unintern_symbol
 531 {
 532   scm_sizet hval;
 533   SCM_VALIDATE_SYMBOL(2,s);
 534   if (o == SCM_BOOL_F)
 535     o = scm_symhash;
 536   SCM_VALIDATE_VECTOR(1,o);
 537   hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 538   SCM_DEFER_INTS;
 539   {
 540     SCM lsym_follow;
 541     SCM lsym;
 542     SCM sym;
 543     for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F;
 544          SCM_NIMP (lsym);
 545          lsym_follow = lsym, lsym = SCM_CDR (lsym))
 546       {
 547         sym = SCM_CAR (lsym);
 548         if (SCM_CAR (sym) == s)
 549           {
 550             /* Found the symbol to unintern. */
 551             if (lsym_follow == SCM_BOOL_F)
 552               SCM_VELTS(o)[hval] = lsym;
 553             else
 554               SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
 555             SCM_ALLOW_INTS;
 556             return SCM_BOOL_T;
 557           }
 558       }
 559   }
 560   SCM_ALLOW_INTS;
 561   return SCM_BOOL_F;
 562 }
 563 #undef FUNC_NAME
 564
 565 GUILE_PROC(scm_symbol_binding, "symbol-binding", 2, 0, 0,
 566            (SCM o, SCM s),
 567 "")
 568 #define FUNC_NAME s_scm_symbol_binding
 569 {
 570   SCM vcell;
 571   SCM_VALIDATE_SYMBOL(2,s);
 572   if (o == SCM_BOOL_F)
 573     o = scm_symhash;
 574   SCM_VALIDATE_VECTOR(1,o);
 575   vcell = scm_sym2ovcell (s, o);
 576   return SCM_CDR(vcell);
 577 }
 578 #undef FUNC_NAME
 579
 580
 581 GUILE_PROC(scm_symbol_interned_p, "symbol-interned?", 2, 0, 0,
 582            (SCM o, SCM s),
 583 "")
 584 #define FUNC_NAME s_scm_symbol_interned_p
 585 {
 586   SCM vcell;
 587   SCM_VALIDATE_SYMBOL(2,s);
 588   if (o == SCM_BOOL_F)
 589     o = scm_symhash;
 590   SCM_VALIDATE_VECTOR(1,o);
 591   vcell = scm_sym2ovcell_soft (s, o);
 592   if (SCM_IMP(vcell) && (o == scm_symhash))
 593     vcell = scm_sym2ovcell_soft (s, scm_weak_symhash);
 594   return (SCM_NIMP(vcell)
 595           ? SCM_BOOL_T
 596           : SCM_BOOL_F);
 597 }
 598 #undef FUNC_NAME
 599
 600
 601 GUILE_PROC(scm_symbol_bound_p, "symbol-bound?", 2, 0, 0,
 602            (SCM o, SCM s),
 603 "")
 604 #define FUNC_NAME s_scm_symbol_bound_p
 605 {
 606   SCM vcell;
 607   SCM_VALIDATE_SYMBOL(2,s);
 608   if (o == SCM_BOOL_F)
 609     o = scm_symhash;
 610   SCM_VALIDATE_VECTOR(1,o);
 611   vcell = scm_sym2ovcell_soft (s, o);
 612   return ((  SCM_NIMP(vcell)
 613            && (SCM_CDR(vcell) != SCM_UNDEFINED))
 614           ? SCM_BOOL_T
 615           : SCM_BOOL_F);
 616 }
 617 #undef FUNC_NAME
 618
 619
 620 GUILE_PROC(scm_symbol_set_x, "symbol-set!", 3, 0, 0,
 621            (SCM o, SCM s, SCM v),
 622 "")
 623 #define FUNC_NAME s_scm_symbol_set_x
 624 {
 625   SCM vcell;
 626   SCM_VALIDATE_SYMBOL(2,s);
 627   if (o == SCM_BOOL_F)
 628     o = scm_symhash;
 629   SCM_VALIDATE_VECTOR(1,o);
 630   vcell = scm_sym2ovcell (s, o);
 631   SCM_SETCDR (vcell, v);
 632   return SCM_UNSPECIFIED;
 633 }
 634 #undef FUNC_NAME
 635
 636 static void
 637 msymbolize (SCM s)
 638 {
 639   SCM string;
 640   string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
 641   SCM_SETCHARS (s, SCM_CHARS (string));
 642   SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol);
 643   SCM_SETCDR (string, SCM_EOL);
 644   SCM_SETCAR (string, SCM_EOL);
 645   SCM_SYMBOL_PROPS (s) = SCM_EOL;
 646   /* If it's a tc7_ssymbol, it comes from scm_symhash */
 647   SCM_SYMBOL_HASH (s) = scm_strhash (SCM_UCHARS (s),
 648                                      (scm_sizet) SCM_LENGTH (s),
 649                                      SCM_LENGTH (scm_symhash));
 650 }
 651
 652
 653 GUILE_PROC(scm_symbol_fref, "symbol-fref", 1, 0, 0,
 654            (SCM s),
 655 "")
 656 #define FUNC_NAME s_scm_symbol_fref
 657 {
 658   SCM_VALIDATE_SYMBOL(1,s);
 659   SCM_DEFER_INTS;
 660   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 661     msymbolize (s);
 662   SCM_ALLOW_INTS;
 663   return SCM_SYMBOL_FUNC (s);
 664 }
 665 #undef FUNC_NAME
 666
 667
 668 GUILE_PROC(scm_symbol_pref, "symbol-pref", 1, 0, 0,
 669            (SCM s),
 670 "")
 671 #define FUNC_NAME s_scm_symbol_pref
 672 {
 673   SCM_VALIDATE_SYMBOL(1,s);
 674   SCM_DEFER_INTS;
 675   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 676     msymbolize (s);
 677   SCM_ALLOW_INTS;
 678   return SCM_SYMBOL_PROPS (s);
 679 }
 680 #undef FUNC_NAME
 681
 682
 683 GUILE_PROC(scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
 684            (SCM s, SCM val),
 685            "")
 686 #define FUNC_NAME s_scm_symbol_fset_x
 687 {
 688   SCM_VALIDATE_SYMBOL(1,s);
 689   SCM_DEFER_INTS;
 690   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 691     msymbolize (s);
 692   SCM_ALLOW_INTS;
 693   SCM_SYMBOL_FUNC (s) = val;
 694   return SCM_UNSPECIFIED;
 695 }
 696 #undef FUNC_NAME
 697
 698
 699 GUILE_PROC(scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
 700            (SCM s, SCM val),
 701 "")
 702 #define FUNC_NAME s_scm_symbol_pset_x
 703 {
 704   SCM_VALIDATE_SYMBOL(1,s);
 705   SCM_DEFER_INTS;
 706   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 707     msymbolize (s);
 708   SCM_SYMBOL_PROPS (s) = val;
 709   SCM_ALLOW_INTS;
 710   return SCM_UNSPECIFIED;
 711 }
 712 #undef FUNC_NAME
 713
 714
 715 GUILE_PROC(scm_symbol_hash, "symbol-hash", 1, 0, 0,
 716            (SCM s),
 717 "")
 718 #define FUNC_NAME s_scm_symbol_hash
 719 {
 720   SCM_VALIDATE_SYMBOL(1,s);
 721   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 722     msymbolize (s);
 723   return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s));
 724 }
 725 #undef FUNC_NAME
 726
 727
 728 static void
 729 copy_and_prune_obarray (SCM from, SCM to)
 730 {
 731   int i;
 732   int length = SCM_LENGTH (from);
 733   for (i = 0; i < length; ++i)
 734     {
 735       SCM head = SCM_VELTS (from)[i]; /* GC protection */
 736       SCM ls = head;
 737       SCM res = SCM_EOL;
 738       SCM *lloc = &res;
 739       while (SCM_NIMP (ls))
 740         {
 741           if (!SCM_UNBNDP (SCM_CDAR (ls)))
 742             {
 743               *lloc = scm_cons (SCM_CAR (ls), SCM_EOL);
 744               lloc = SCM_CDRLOC (*lloc);
 745             }
 746           ls = SCM_CDR (ls);
 747         }
 748       SCM_VELTS (to)[i] = res;
 749     }
 750 }
 751
 752
 753 GUILE_PROC(scm_builtin_bindings, "builtin-bindings", 0, 0, 0,
 754            (),
 755 "")
 756 #define FUNC_NAME s_scm_builtin_bindings
 757 {
 758   int length = SCM_LENGTH (scm_symhash);
 759   SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL);
 760   copy_and_prune_obarray (scm_symhash, obarray);
 761   return obarray;
 762 }
 763 #undef FUNC_NAME
 764
 765
 766 GUILE_PROC(scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0,
 767            (),
 768 "")
 769 #define FUNC_NAME s_scm_builtin_weak_bindings
 770 {
 771   int length = SCM_LENGTH (scm_weak_symhash);
 772   SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length));
 773   copy_and_prune_obarray (scm_weak_symhash, obarray);
 774   return obarray;
 775 }
 776 #undef FUNC_NAME
 777
 778 static int gensym_counter;
 779 static SCM gensym_prefix;
 780
 781 /* :FIXME:OPTIMIZE */
 782 GUILE_PROC (scm_gensym, "gensym", 0, 2, 0,
 783             (SCM name, SCM obarray),
 784 "")
 785 #define FUNC_NAME s_scm_gensym
 786 {
 787   SCM new;
 788   if (SCM_UNBNDP (name))
 789     name = gensym_prefix;
 790   else
 791     SCM_VALIDATE_ROSTRING(1,name);
 792
 793   new = name;
 794   if (SCM_UNBNDP (obarray))
 795     {
 796       obarray = SCM_BOOL_F;
 797       goto skip_test;
 798     }
 799   else
 800     SCM_ASSERT (SCM_NIMP (obarray)
 801                 && (SCM_VECTORP (obarray) || SCM_WVECTP (obarray)),
 802                 obarray,
 803                 SCM_ARG2,
 804                 FUNC_NAME);
 805   while (scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_T)
 806          != SCM_BOOL_F)
 807     skip_test:
 808     new = scm_string_append
 809       (scm_cons2 (name,
 810                   scm_number_to_string (SCM_MAKINUM (gensym_counter++),
 811                                         SCM_UNDEFINED),
 812                   SCM_EOL));
 813   return scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_F);
 814 }
 815 #undef FUNC_NAME
 816
 817 void
 818 scm_init_symbols ()
 819 {
 820   gensym_counter = 0;
 821   gensym_prefix = scm_permanent_object (scm_makfrom0str ("%%gensym"));
 822 #include "symbols.x"
 823 }