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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  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
  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_MULTI_BYTE_STRINGP (lsym) = SCM_BOOL_F;
 301   SCM_SYMBOL_HASH (lsym) = scm_hash;
 302   SCM_SYMBOL_PROPS (lsym) = SCM_EOL;
 303   if (obarray == SCM_BOOL_F)
 304     {
 305       SCM answer;
 306       SCM_REALLOW_INTS;
 307       SCM_NEWCELL (answer);
 308       SCM_DEFER_INTS;
 309       SCM_SETCAR (answer, lsym);
 310       SCM_SETCDR (answer, SCM_UNDEFINED);
 311       SCM_REALLOW_INTS;
 312       return answer;
 313     }
 314   else
 315     {
 316       SCM a;
 317       SCM b;
 318
 319       SCM_NEWCELL (a);
 320       SCM_NEWCELL (b);
 321       SCM_SETCAR (a, lsym);
 322       SCM_SETCDR (a, SCM_UNDEFINED);
 323       SCM_SETCAR (b, a);
 324       SCM_SETCDR (b, SCM_VELTS(obarray)[scm_hash]);
 325       SCM_VELTS(obarray)[scm_hash] = b;
 326       SCM_REALLOW_INTS;
 327       return SCM_CAR (b);
 328     }
 329 }
 330
 331
 332 SCM
 333 scm_intern_obarray (name, len, obarray)
 334      char *name;
 335      scm_sizet len;
 336      SCM obarray;
 337 {
 338   return scm_intern_obarray_soft (name, len, obarray, 0);
 339 }
 340
 341
 342 SCM
 343 scm_intern (name, len)
 344      char *name;
 345      scm_sizet len;
 346 {
 347   return scm_intern_obarray (name, len, scm_symhash);
 348 }
 349
 350
 351 SCM
 352 scm_intern0 (name)
 353      char * name;
 354 {
 355   return scm_intern (name, strlen (name));
 356 }
 357
 358
 359 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated.  */
 360 SCM
 361 scm_sysintern0_no_module_lookup (name)
 362      char *name;
 363 {
 364   SCM easy_answer;
 365   SCM_DEFER_INTS;
 366   easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1);
 367   if (SCM_NIMP (easy_answer))
 368     {
 369       SCM_ALLOW_INTS;
 370       return easy_answer;
 371     }
 372   else
 373     {
 374       SCM lsym;
 375       scm_sizet len = strlen (name);
 376       register unsigned char *tmp = (unsigned char *) name;
 377       scm_sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim);
 378       SCM_NEWCELL (lsym);
 379       SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol);
 380       SCM_SETCHARS (lsym, name);
 381       lsym = scm_cons (lsym, SCM_UNDEFINED);
 382       SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]);
 383       SCM_ALLOW_INTS;
 384       return lsym;
 385     }
 386 }
 387
 388
 389 /* Is it safe to access SCM_TOP_LEVEL_LOOKUP_CLOSURE_VAR?
 390  */
 391 int scm_can_use_top_level_lookup_closure_var;
 392
 393 /* Intern the symbol named NAME in scm_symhash, and give it the value
 394    VAL.  NAME is null-terminated.  Use the current top_level lookup
 395    closure to give NAME its value.
 396  */
 397 SCM
 398 scm_sysintern (name, val)
 399      char *name;
 400      SCM val;
 401 {
 402   SCM vcell = scm_sysintern0 (name);
 403   SCM_SETCDR (vcell, val);
 404   return vcell;
 405 }
 406
 407 SCM
 408 scm_sysintern0 (name)
 409      char *name;
 410 {
 411   SCM lookup_proc;
 412   if (scm_can_use_top_level_lookup_closure_var &&
 413       SCM_NIMP (lookup_proc = SCM_CDR (scm_top_level_lookup_closure_var)))
 414     {
 415       SCM sym = SCM_CAR (scm_intern0 (name));
 416       SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T);
 417       if (vcell == SCM_BOOL_F)
 418           scm_misc_error ("sysintern", "can't define variable", sym);
 419       return vcell;
 420     }
 421   else
 422     return scm_sysintern0_no_module_lookup (name);
 423 }
 424
 425 /* Lookup the value of the symbol named by the nul-terminated string
 426    NAME in the current module.  */
 427 SCM
 428 scm_symbol_value0 (name)
 429      char *name;
 430 {
 431   /* This looks silly - we look up the symbol twice.  But it is in
 432      fact necessary given the current module system because the module
 433      lookup closures are written in scheme which needs real symbols. */
 434   SCM symbol = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 0);
 435   SCM vcell = scm_sym2vcell (SCM_CAR (symbol),
 436                              SCM_CDR (scm_top_level_lookup_closure_var),
 437                              SCM_BOOL_F);
 438   if (SCM_FALSEP (vcell))
 439     return SCM_UNDEFINED;
 440   return SCM_CDR (vcell);
 441 }
 442
 443 SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
 444
 445 SCM
 446 scm_symbol_p(x)
 447      SCM x;
 448 {
 449   if SCM_IMP(x) return SCM_BOOL_F;
 450   return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
 451 }
 452
 453 SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string);
 454
 455 SCM
 456 scm_symbol_to_string(s)
 457      SCM s;
 458 {
 459   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string);
 460   return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0);
 461 }
 462
 463
 464 SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol);
 465
 466 SCM
 467 scm_string_to_symbol(s)
 468      SCM s;
 469 {
 470   SCM vcell;
 471   SCM answer;
 472
 473   SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol);
 474   vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s));
 475   answer = SCM_CAR (vcell);
 476   if (SCM_TYP7 (answer) == scm_tc7_msymbol)
 477     {
 478       if (SCM_REGULAR_STRINGP (s))
 479         SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
 480       else
 481         SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
 482     }
 483   return answer;
 484 }
 485
 486
 487 SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol);
 488
 489 SCM
 490 scm_string_to_obarray_symbol(o, s, softp)
 491      SCM o;
 492      SCM s;
 493      SCM softp;
 494 {
 495   SCM vcell;
 496   SCM answer;
 497   int softness;
 498
 499   SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2,
 500              s_string_to_obarray_symbol);
 501   SCM_ASSERT((o == SCM_BOOL_F)
 502              || (o == SCM_BOOL_T)
 503              || (SCM_NIMP(o) && SCM_VECTORP(o)),
 504              o,
 505              SCM_ARG1,
 506              s_string_to_obarray_symbol);
 507
 508   softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F));
 509   /* iron out some screwy calling conventions */
 510   if (o == SCM_BOOL_F)
 511     o = scm_symhash;
 512   else if (o == SCM_BOOL_T)
 513     o = SCM_BOOL_F;
 514
 515   vcell = scm_intern_obarray_soft (SCM_ROCHARS(s),
 516                                    (scm_sizet)SCM_ROLENGTH(s),
 517                                    o,
 518                                    softness);
 519   if (vcell == SCM_BOOL_F)
 520     return vcell;
 521   answer = SCM_CAR (vcell);
 522   if (SCM_TYP7 (s) == scm_tc7_msymbol)
 523     {
 524       if (SCM_REGULAR_STRINGP (s))
 525         SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
 526       else
 527         SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
 528     }
 529   return answer;
 530 }
 531
 532 SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol);
 533
 534 SCM
 535 scm_intern_symbol(o, s)
 536      SCM o;
 537      SCM s;
 538 {
 539   scm_sizet hval;
 540   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol);
 541   if (o == SCM_BOOL_F)
 542     o = scm_symhash;
 543   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol);
 544   hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 545   /* If the symbol is already interned, simply return. */
 546   SCM_REDEFER_INTS;
 547   {
 548     SCM lsym;
 549     SCM sym;
 550     for (lsym = SCM_VELTS (o)[hval];
 551          SCM_NIMP (lsym);
 552          lsym = SCM_CDR (lsym))
 553       {
 554         sym = SCM_CAR (lsym);
 555         if (SCM_CAR (sym) == s)
 556           {
 557             SCM_REALLOW_INTS;
 558             return SCM_UNSPECIFIED;
 559           }
 560       }
 561     SCM_VELTS (o)[hval] =
 562       scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]);
 563   }
 564   SCM_REALLOW_INTS;
 565   return SCM_UNSPECIFIED;
 566 }
 567
 568 SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol);
 569
 570 SCM
 571 scm_unintern_symbol(o, s)
 572      SCM o;
 573      SCM s;
 574 {
 575   scm_sizet hval;
 576   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol);
 577   if (o == SCM_BOOL_F)
 578     o = scm_symhash;
 579   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol);
 580   hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 581   SCM_DEFER_INTS;
 582   {
 583     SCM lsym_follow;
 584     SCM lsym;
 585     SCM sym;
 586     for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F;
 587          SCM_NIMP (lsym);
 588          lsym_follow = lsym, lsym = SCM_CDR (lsym))
 589       {
 590         sym = SCM_CAR (lsym);
 591         if (SCM_CAR (sym) == s)
 592           {
 593             /* Found the symbol to unintern. */
 594             if (lsym_follow == SCM_BOOL_F)
 595               SCM_VELTS(o)[hval] = lsym;
 596             else
 597               SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
 598             SCM_ALLOW_INTS;
 599             return SCM_BOOL_T;
 600           }
 601       }
 602   }
 603   SCM_ALLOW_INTS;
 604   return SCM_BOOL_F;
 605 }
 606
 607 SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding);
 608
 609 SCM
 610 scm_symbol_binding (o, s)
 611      SCM o;
 612      SCM s;
 613 {
 614   SCM vcell;
 615   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding);
 616   if (o == SCM_BOOL_F)
 617     o = scm_symhash;
 618   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_binding);
 619   vcell = scm_sym2ovcell (s, o);
 620   return SCM_CDR(vcell);
 621 }
 622
 623
 624 SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p);
 625
 626 SCM
 627 scm_symbol_interned_p (o, s)
 628      SCM o;
 629      SCM s;
 630 {
 631   SCM vcell;
 632   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p);
 633   if (o == SCM_BOOL_F)
 634     o = scm_symhash;
 635   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_interned_p);
 636   vcell = scm_sym2ovcell_soft (s, o);
 637   if (SCM_IMP(vcell) && (o == scm_symhash))
 638     vcell = scm_sym2ovcell_soft (s, scm_weak_symhash);
 639   return (SCM_NIMP(vcell)
 640           ? SCM_BOOL_T
 641           : SCM_BOOL_F);
 642 }
 643
 644
 645 SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p);
 646
 647 SCM
 648 scm_symbol_bound_p (o, s)
 649      SCM o;
 650      SCM s;
 651 {
 652   SCM vcell;
 653   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_p);
 654   if (o == SCM_BOOL_F)
 655     o = scm_symhash;
 656   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_bound_p);
 657   vcell = scm_sym2ovcell_soft (s, o);
 658   return ((  SCM_NIMP(vcell)
 659            && (SCM_CDR(vcell) != SCM_UNDEFINED))
 660           ? SCM_BOOL_T
 661           : SCM_BOOL_F);
 662 }
 663
 664
 665 SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x);
 666
 667 SCM
 668 scm_symbol_set_x (o, s, v)
 669      SCM o;
 670      SCM s;
 671      SCM v;
 672 {
 673   SCM vcell;
 674   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x);
 675   if (o == SCM_BOOL_F)
 676     o = scm_symhash;
 677   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x);
 678   vcell = scm_sym2ovcell (s, o);
 679   SCM_SETCDR (vcell, v);
 680   return SCM_UNSPECIFIED;
 681 }
 682
 683 static void
 684 msymbolize (s)
 685      SCM s;
 686 {
 687   SCM string;
 688   string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
 689   SCM_SETCHARS (s, SCM_CHARS (string));
 690   SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol);
 691   SCM_SYMBOL_MULTI_BYTE_STRINGP (s) = SCM_BOOL_F;
 692   SCM_SETCDR (string, SCM_EOL);
 693   SCM_SETCAR (string, SCM_EOL);
 694 }
 695
 696
 697 SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref);
 698
 699 SCM
 700 scm_symbol_fref (s)
 701      SCM s;
 702 {
 703   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref);
 704   SCM_DEFER_INTS;
 705   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 706     msymbolize (s);
 707   SCM_ALLOW_INTS;
 708   return SCM_SYMBOL_FUNC (s);
 709 }
 710
 711
 712 SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref);
 713
 714 SCM
 715 scm_symbol_pref (s)
 716      SCM s;
 717 {
 718   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref);
 719   SCM_DEFER_INTS;
 720   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 721     msymbolize (s);
 722   SCM_ALLOW_INTS;
 723   return SCM_SYMBOL_PROPS (s);
 724 }
 725
 726
 727 SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x);
 728
 729 SCM
 730 scm_symbol_fset_x (s, val)
 731      SCM s;
 732      SCM val;
 733 {
 734   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x);
 735   SCM_DEFER_INTS;
 736   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 737     msymbolize (s);
 738   SCM_ALLOW_INTS;
 739   SCM_SYMBOL_FUNC (s) = val;
 740   return SCM_UNSPECIFIED;
 741 }
 742
 743
 744 SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x);
 745
 746 SCM
 747 scm_symbol_pset_x (s, val)
 748      SCM s;
 749      SCM val;
 750 {
 751   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x);
 752   SCM_DEFER_INTS;
 753   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 754     msymbolize (s);
 755   SCM_SYMBOL_PROPS (s) = val;
 756   SCM_ALLOW_INTS;
 757   return SCM_UNSPECIFIED;
 758 }
 759
 760
 761 SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash);
 762
 763 SCM
 764 scm_symbol_hash (s)
 765      SCM s;
 766 {
 767   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash);
 768   return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s));
 769 }
 770
 771
 772
 773 void
 774 scm_init_symbols ()
 775 {
 776 #include "symbols.x"
 777 }
 778