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