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 SCM_DEFINE(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 SCM_DEFINE(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 SCM_DEFINE(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 SCM_DEFINE(scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
 460            (SCM o, SCM s, SCM softp),
 461 "Intern a new symbol in @var{obarray}, a symbol table, with name
 462 @var{string}.
 463
 464 If @var{obarray} is @code{#f}, use the default system symbol table.  If
 465 @var{obarray} is @code{#t}, the symbol should not be interned in any
 466 symbol table; merely return the pair (@var{symbol}
 467 . @var{#<undefined>}).
 468
 469 The @var{soft?} argument determines whether new symbol table entries
 470 should be created when the specified symbol is not already present in
 471 @var{obarray}.  If @var{soft?} is specified and is a true value, then
 472 new entries should not be added for symbols not already present in the
 473 table; instead, simply return @code{#f}.")
 474 #define FUNC_NAME s_scm_string_to_obarray_symbol
 475 {
 476   SCM vcell;
 477   SCM answer;
 478   int softness;
 479
 480   SCM_VALIDATE_ROSTRING(2,s);
 481   SCM_ASSERT((o == SCM_BOOL_F)
 482              || (o == SCM_BOOL_T)
 483              || (SCM_VECTORP(o)),
 484              o, SCM_ARG1, FUNC_NAME);
 485
 486   softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F));
 487   /* iron out some screwy calling conventions */
 488   if (o == SCM_BOOL_F)
 489     o = scm_symhash;
 490   else if (o == SCM_BOOL_T)
 491     o = SCM_BOOL_F;
 492
 493   vcell = scm_intern_obarray_soft (SCM_ROCHARS(s),
 494                                    (scm_sizet)SCM_ROLENGTH(s),
 495                                    o,
 496                                    softness);
 497   if (vcell == SCM_BOOL_F)
 498     return vcell;
 499   answer = SCM_CAR (vcell);
 500   return answer;
 501 }
 502 #undef FUNC_NAME
 503
 504 SCM_DEFINE(scm_intern_symbol, "intern-symbol", 2, 0, 0,
 505            (SCM o, SCM s),
 506 "Add a new symbol to @var{obarray} with name @var{string}, bound to an
 507 unspecified initial value.  The symbol table is not modified if a symbol
 508 with this name is already present.")
 509 #define FUNC_NAME s_scm_intern_symbol
 510 {
 511   scm_sizet hval;
 512   SCM_VALIDATE_SYMBOL(2,s);
 513   if (o == SCM_BOOL_F)
 514     o = scm_symhash;
 515   SCM_VALIDATE_VECTOR(1,o);
 516   hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 517   /* If the symbol is already interned, simply return. */
 518   SCM_REDEFER_INTS;
 519   {
 520     SCM lsym;
 521     SCM sym;
 522     for (lsym = SCM_VELTS (o)[hval];
 523          SCM_NIMP (lsym);
 524          lsym = SCM_CDR (lsym))
 525       {
 526         sym = SCM_CAR (lsym);
 527         if (SCM_CAR (sym) == s)
 528           {
 529             SCM_REALLOW_INTS;
 530             return SCM_UNSPECIFIED;
 531           }
 532       }
 533     SCM_VELTS (o)[hval] =
 534       scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]);
 535   }
 536   SCM_REALLOW_INTS;
 537   return SCM_UNSPECIFIED;
 538 }
 539 #undef FUNC_NAME
 540
 541 SCM_DEFINE(scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
 542            (SCM o, SCM s),
 543 "Remove the symbol with name @var{string} from @var{obarray}.  This
 544 function returns @code{#t} if the symbol was present and @code{#f}
 545 otherwise.")
 546 #define FUNC_NAME s_scm_unintern_symbol
 547 {
 548   scm_sizet hval;
 549   SCM_VALIDATE_SYMBOL(2,s);
 550   if (o == SCM_BOOL_F)
 551     o = scm_symhash;
 552   SCM_VALIDATE_VECTOR(1,o);
 553   hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 554   SCM_DEFER_INTS;
 555   {
 556     SCM lsym_follow;
 557     SCM lsym;
 558     SCM sym;
 559     for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F;
 560          SCM_NIMP (lsym);
 561          lsym_follow = lsym, lsym = SCM_CDR (lsym))
 562       {
 563         sym = SCM_CAR (lsym);
 564         if (SCM_CAR (sym) == s)
 565           {
 566             /* Found the symbol to unintern. */
 567             if (lsym_follow == SCM_BOOL_F)
 568               SCM_VELTS(o)[hval] = lsym;
 569             else
 570               SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
 571             SCM_ALLOW_INTS;
 572             return SCM_BOOL_T;
 573           }
 574       }
 575   }
 576   SCM_ALLOW_INTS;
 577   return SCM_BOOL_F;
 578 }
 579 #undef FUNC_NAME
 580
 581 SCM_DEFINE(scm_symbol_binding, "symbol-binding", 2, 0, 0,
 582            (SCM o, SCM s),
 583 "Look up in @var{obarray} the symbol whose name is @var{string}, and
 584 return the value to which it is bound.  If @var{obarray} is @code{#f},
 585 use the global symbol table.  If @var{string} is not interned in
 586 @var{obarray}, an error is signalled.")
 587 #define FUNC_NAME s_scm_symbol_binding
 588 {
 589   SCM vcell;
 590   SCM_VALIDATE_SYMBOL(2,s);
 591   if (o == SCM_BOOL_F)
 592     o = scm_symhash;
 593   SCM_VALIDATE_VECTOR(1,o);
 594   vcell = scm_sym2ovcell (s, o);
 595   return SCM_CDR(vcell);
 596 }
 597 #undef FUNC_NAME
 598
 599
 600 SCM_DEFINE(scm_symbol_interned_p, "symbol-interned?", 2, 0, 0,
 601            (SCM o, SCM s),
 602 "Return @var{#t} if @var{obarray} contains a symbol with name
 603 @var{string}, and @var{#f} otherwise.")
 604 #define FUNC_NAME s_scm_symbol_interned_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   if (SCM_IMP(vcell) && (o == scm_symhash))
 613     vcell = scm_sym2ovcell_soft (s, scm_weak_symhash);
 614   return (SCM_NIMP(vcell)
 615           ? SCM_BOOL_T
 616           : SCM_BOOL_F);
 617 }
 618 #undef FUNC_NAME
 619
 620
 621 SCM_DEFINE(scm_symbol_bound_p, "symbol-bound?", 2, 0, 0,
 622            (SCM o, SCM s),
 623 "Return @var{#t} if @var{obarray} contains a symbol with name
 624 @var{string} bound to a defined value.  This differs from
 625 @var{symbol-bound?} in that the mere mention of a symbol usually causes
 626 it to be interned; @code{symbol-bound?} determines whether a symbol has
 627 been given any meaningful value.")
 628 #define FUNC_NAME s_scm_symbol_bound_p
 629 {
 630   SCM vcell;
 631   SCM_VALIDATE_SYMBOL(2,s);
 632   if (o == SCM_BOOL_F)
 633     o = scm_symhash;
 634   SCM_VALIDATE_VECTOR(1,o);
 635   vcell = scm_sym2ovcell_soft (s, o);
 636   return ((  SCM_NIMP(vcell)
 637            && (SCM_CDR(vcell) != SCM_UNDEFINED))
 638           ? SCM_BOOL_T
 639           : SCM_BOOL_F);
 640 }
 641 #undef FUNC_NAME
 642
 643
 644 SCM_DEFINE(scm_symbol_set_x, "symbol-set!", 3, 0, 0,
 645            (SCM o, SCM s, SCM v),
 646 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind
 647 it to @var{value}.  An error is signalled if @var{string} is not present
 648 in @var{obarray}.")
 649 #define FUNC_NAME s_scm_symbol_set_x
 650 {
 651   SCM vcell;
 652   SCM_VALIDATE_SYMBOL(2,s);
 653   if (o == SCM_BOOL_F)
 654     o = scm_symhash;
 655   SCM_VALIDATE_VECTOR(1,o);
 656   vcell = scm_sym2ovcell (s, o);
 657   SCM_SETCDR (vcell, v);
 658   return SCM_UNSPECIFIED;
 659 }
 660 #undef FUNC_NAME
 661
 662 static void
 663 msymbolize (SCM s)
 664 {
 665   SCM string;
 666   string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
 667   SCM_SETCHARS (s, SCM_CHARS (string));
 668   SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol);
 669   SCM_SETCDR (string, SCM_EOL);
 670   SCM_SETCAR (string, SCM_EOL);
 671   SCM_SYMBOL_PROPS (s) = SCM_EOL;
 672   /* If it's a tc7_ssymbol, it comes from scm_symhash */
 673   SCM_SYMBOL_HASH (s) = scm_strhash (SCM_UCHARS (s),
 674                                      (scm_sizet) SCM_LENGTH (s),
 675                                      SCM_LENGTH (scm_symhash));
 676 }
 677
 678
 679 SCM_DEFINE(scm_symbol_fref, "symbol-fref", 1, 0, 0,
 680            (SCM s),
 681 "Return the contents of @var{symbol}'s @dfn{function slot}.")
 682 #define FUNC_NAME s_scm_symbol_fref
 683 {
 684   SCM_VALIDATE_SYMBOL(1,s);
 685   SCM_DEFER_INTS;
 686   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 687     msymbolize (s);
 688   SCM_ALLOW_INTS;
 689   return SCM_SYMBOL_FUNC (s);
 690 }
 691 #undef FUNC_NAME
 692
 693
 694 SCM_DEFINE(scm_symbol_pref, "symbol-pref", 1, 0, 0,
 695            (SCM s),
 696 "Return the @dfn{property list} currently associated with @var{symbol}.")
 697 #define FUNC_NAME s_scm_symbol_pref
 698 {
 699   SCM_VALIDATE_SYMBOL(1,s);
 700   SCM_DEFER_INTS;
 701   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 702     msymbolize (s);
 703   SCM_ALLOW_INTS;
 704   return SCM_SYMBOL_PROPS (s);
 705 }
 706 #undef FUNC_NAME
 707
 708
 709 SCM_DEFINE(scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
 710            (SCM s, SCM val),
 711 "Change the binding of @var{symbol}'s function slot.")
 712 #define FUNC_NAME s_scm_symbol_fset_x
 713 {
 714   SCM_VALIDATE_SYMBOL(1,s);
 715   SCM_DEFER_INTS;
 716   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 717     msymbolize (s);
 718   SCM_ALLOW_INTS;
 719   SCM_SYMBOL_FUNC (s) = val;
 720   return SCM_UNSPECIFIED;
 721 }
 722 #undef FUNC_NAME
 723
 724
 725 SCM_DEFINE(scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
 726            (SCM s, SCM val),
 727 "Change the binding of @var{symbol}'s property slot.")
 728 #define FUNC_NAME s_scm_symbol_pset_x
 729 {
 730   SCM_VALIDATE_SYMBOL(1,s);
 731   SCM_DEFER_INTS;
 732   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 733     msymbolize (s);
 734   SCM_SYMBOL_PROPS (s) = val;
 735   SCM_ALLOW_INTS;
 736   return SCM_UNSPECIFIED;
 737 }
 738 #undef FUNC_NAME
 739
 740
 741 SCM_DEFINE(scm_symbol_hash, "symbol-hash", 1, 0, 0,
 742            (SCM s),
 743 "Return the hash value derived from @var{symbol}'s name, i.e. the integer
 744 index into @var{symbol}'s obarray at which it is stored.")
 745 #define FUNC_NAME s_scm_symbol_hash
 746 {
 747   SCM_VALIDATE_SYMBOL(1,s);
 748   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 749     msymbolize (s);
 750   return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s));
 751 }
 752 #undef FUNC_NAME
 753
 754
 755 static void
 756 copy_and_prune_obarray (SCM from, SCM to)
 757 {
 758   int i;
 759   int length = SCM_LENGTH (from);
 760   for (i = 0; i < length; ++i)
 761     {
 762       SCM head = SCM_VELTS (from)[i]; /* GC protection */
 763       SCM ls = head;
 764       SCM res = SCM_EOL;
 765       SCM *lloc = &res;
 766       while (SCM_NIMP (ls))
 767         {
 768           if (!SCM_UNBNDP (SCM_CDAR (ls)))
 769             {
 770               *lloc = scm_cons (SCM_CAR (ls), SCM_EOL);
 771               lloc = SCM_CDRLOC (*lloc);
 772             }
 773           ls = SCM_CDR (ls);
 774         }
 775       SCM_VELTS (to)[i] = res;
 776     }
 777 }
 778
 779
 780 SCM_DEFINE(scm_builtin_bindings, "builtin-bindings", 0, 0, 0,
 781            (),
 782 "Create and return a copy of the global symbol table, removing all
 783 unbound symbols.")
 784 #define FUNC_NAME s_scm_builtin_bindings
 785 {
 786   int length = SCM_LENGTH (scm_symhash);
 787   SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL);
 788   copy_and_prune_obarray (scm_symhash, obarray);
 789   return obarray;
 790 }
 791 #undef FUNC_NAME
 792
 793
 794 SCM_DEFINE(scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0,
 795            (),
 796 "")
 797 #define FUNC_NAME s_scm_builtin_weak_bindings
 798 {
 799   int length = SCM_LENGTH (scm_weak_symhash);
 800   SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length));
 801   copy_and_prune_obarray (scm_weak_symhash, obarray);
 802   return obarray;
 803 }
 804 #undef FUNC_NAME
 805
 806 static int gensym_counter;
 807 static SCM gensym_prefix;
 808
 809 /* :FIXME:OPTIMIZE */
 810 SCM_DEFINE (scm_gensym, "gensym", 0, 2, 0,
 811             (SCM name, SCM obarray),
 812 "Create a new, unique symbol in @var{obarray}, using the global symbol
 813 table by default.  If @var{name} is specified, it should be used as a
 814 prefix for the new symbol's name.  The default prefix is @code{%%gensym}.")
 815 #define FUNC_NAME s_scm_gensym
 816 {
 817   SCM new;
 818   if (SCM_UNBNDP (name))
 819     name = gensym_prefix;
 820   else
 821     SCM_VALIDATE_ROSTRING(1,name);
 822
 823   new = name;
 824   if (SCM_UNBNDP (obarray))
 825     {
 826       obarray = SCM_BOOL_F;
 827       goto skip_test;
 828     }
 829   else
 830     SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)),
 831                 obarray,
 832                 SCM_ARG2,
 833                 FUNC_NAME);
 834   while (scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_T)
 835          != SCM_BOOL_F)
 836     skip_test:
 837     new = scm_string_append
 838       (scm_cons2 (name,
 839                   scm_number_to_string (SCM_MAKINUM (gensym_counter++),
 840                                         SCM_UNDEFINED),
 841                   SCM_EOL));
 842   return scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_F);
 843 }
 844 #undef FUNC_NAME
 845
 846 void
 847 scm_init_symbols ()
 848 {
 849   gensym_counter = 0;
 850   gensym_prefix = scm_permanent_object (scm_makfrom0str ("%%gensym"));
 851 #include "symbols.x"
 852 }