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