libguile/symbols.c

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