libguile/symbols.c

   1 /*      Copyright (C) 1995,1996 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 (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, and give it the value VAL.
 360    NAME is null-terminated.  */
 361 SCM
 362 scm_sysintern (name, val)
 363      char *name;
 364      SCM val;
 365 {
 366   SCM easy_answer;
 367   SCM_DEFER_INTS;
 368   easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1);
 369   if (SCM_NIMP (easy_answer))
 370     {
 371       SCM_SETCDR (easy_answer, val);
 372       SCM_ALLOW_INTS;
 373       return easy_answer;
 374     }
 375   else
 376     {
 377       SCM lsym;
 378       scm_sizet len = strlen (name);
 379       register unsigned char *tmp = (unsigned char *) name;
 380       scm_sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim);
 381       SCM_NEWCELL (lsym);
 382       SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol);
 383       SCM_SETCHARS (lsym, name);
 384       lsym = scm_cons (lsym, val);
 385       SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]);
 386       SCM_ALLOW_INTS;
 387       return lsym;
 388     }
 389 }
 390
 391
 392 SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
 393
 394 SCM
 395 scm_symbol_p(x)
 396      SCM x;
 397 {
 398   if SCM_IMP(x) return SCM_BOOL_F;
 399   return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
 400 }
 401
 402 SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string);
 403
 404 SCM
 405 scm_symbol_to_string(s)
 406      SCM s;
 407 {
 408   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string);
 409   return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0);
 410 }
 411
 412
 413 SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol);
 414
 415 SCM
 416 scm_string_to_symbol(s)
 417      SCM s;
 418 {
 419   SCM vcell;
 420   SCM answer;
 421
 422   SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol);
 423   vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s));
 424   answer = SCM_CAR (vcell);
 425   if (SCM_TYP7 (answer) == scm_tc7_msymbol)
 426     {
 427       if (SCM_REGULAR_STRINGP (s))
 428         SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
 429       else
 430         SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
 431     }
 432   return answer;
 433 }
 434
 435
 436 SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol);
 437
 438 SCM
 439 scm_string_to_obarray_symbol(o, s, softp)
 440      SCM o;
 441      SCM s;
 442      SCM softp;
 443 {
 444   SCM vcell;
 445   SCM answer;
 446   int softness;
 447
 448   SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2,
 449              s_string_to_obarray_symbol);
 450   SCM_ASSERT((o == SCM_BOOL_F)
 451              || (o == SCM_BOOL_T)
 452              || (SCM_NIMP(o) && SCM_VECTORP(o)),
 453              o,
 454              SCM_ARG1,
 455              s_string_to_obarray_symbol);
 456
 457   softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F));
 458   /* iron out some screwy calling conventions */
 459   if (o == SCM_BOOL_F)
 460     o = scm_symhash;
 461   else if (o == SCM_BOOL_T)
 462     o = SCM_BOOL_F;
 463
 464   vcell = scm_intern_obarray_soft (SCM_ROCHARS(s),
 465                                    (scm_sizet)SCM_ROLENGTH(s),
 466                                    o,
 467                                    softness);
 468   if (vcell == SCM_BOOL_F)
 469     return vcell;
 470   answer = SCM_CAR (vcell);
 471   if (SCM_TYP7 (s) == scm_tc7_msymbol)
 472     {
 473       if (SCM_REGULAR_STRINGP (s))
 474         SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
 475       else
 476         SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
 477     }
 478   return answer;
 479 }
 480
 481 SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol);
 482
 483 SCM
 484 scm_intern_symbol(o, s)
 485      SCM o;
 486      SCM s;
 487 {
 488   scm_sizet hval;
 489   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol);
 490   if (o == SCM_BOOL_F)
 491     o = scm_symhash;
 492   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol);
 493   hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 494   /* If the symbol is already interned, simply return. */
 495   SCM_REDEFER_INTS;
 496   {
 497     SCM lsym;
 498     SCM sym;
 499     for (lsym = SCM_VELTS (o)[hval];
 500          SCM_NIMP (lsym);
 501          lsym = SCM_CDR (lsym))
 502       {
 503         sym = SCM_CAR (lsym);
 504         if (SCM_CAR (sym) == s)
 505           {
 506             SCM_REALLOW_INTS;
 507             return SCM_UNSPECIFIED;
 508           }
 509       }
 510     SCM_VELTS (o)[hval] =
 511       scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]);
 512   }
 513   SCM_REALLOW_INTS;
 514   return SCM_UNSPECIFIED;
 515 }
 516
 517 SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol);
 518
 519 SCM
 520 scm_unintern_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_unintern_symbol);
 526   if (o == SCM_BOOL_F)
 527     o = scm_symhash;
 528   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol);
 529   hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 530   SCM_DEFER_INTS;
 531   {
 532     SCM lsym_follow;
 533     SCM lsym;
 534     SCM sym;
 535     for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F;
 536          SCM_NIMP (lsym);
 537          lsym_follow = lsym, lsym = SCM_CDR (lsym))
 538       {
 539         sym = SCM_CAR (lsym);
 540         if (SCM_CAR (sym) == s)
 541           {
 542             /* Found the symbol to unintern. */
 543             if (lsym_follow == SCM_BOOL_F)
 544               SCM_VELTS(o)[hval] = lsym;
 545             else
 546               SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
 547             SCM_ALLOW_INTS;
 548             return SCM_BOOL_T;
 549           }
 550       }
 551   }
 552   SCM_ALLOW_INTS;
 553   return SCM_BOOL_F;
 554 }
 555
 556 SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding);
 557
 558 SCM
 559 scm_symbol_binding (o, s)
 560      SCM o;
 561      SCM s;
 562 {
 563   SCM vcell;
 564   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding);
 565   if (o == SCM_BOOL_F)
 566     o = scm_symhash;
 567   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_binding);
 568   vcell = scm_sym2ovcell (s, o);
 569   return SCM_CDR(vcell);
 570 }
 571
 572
 573 SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p);
 574
 575 SCM
 576 scm_symbol_interned_p (o, s)
 577      SCM o;
 578      SCM s;
 579 {
 580   SCM vcell;
 581   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p);
 582   if (o == SCM_BOOL_F)
 583     o = scm_symhash;
 584   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_interned_p);
 585   vcell = scm_sym2ovcell_soft (s, o);
 586   if (SCM_IMP(vcell) && (o == scm_symhash))
 587     vcell = scm_sym2ovcell_soft (s, scm_weak_symhash);
 588   return (SCM_NIMP(vcell)
 589           ? SCM_BOOL_T
 590           : SCM_BOOL_F);
 591 }
 592
 593
 594 SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p);
 595
 596 SCM
 597 scm_symbol_bound_p (o, s)
 598      SCM o;
 599      SCM s;
 600 {
 601   SCM vcell;
 602   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_p);
 603   if (o == SCM_BOOL_F)
 604     o = scm_symhash;
 605   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_bound_p);
 606   vcell = scm_sym2ovcell_soft (s, o);
 607   return ((  SCM_NIMP(vcell)
 608            && (SCM_CDR(vcell) != SCM_UNDEFINED))
 609           ? SCM_BOOL_T
 610           : SCM_BOOL_F);
 611 }
 612
 613
 614 SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x);
 615
 616 SCM
 617 scm_symbol_set_x (o, s, v)
 618      SCM o;
 619      SCM s;
 620      SCM v;
 621 {
 622   SCM vcell;
 623   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x);
 624   if (o == SCM_BOOL_F)
 625     o = scm_symhash;
 626   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x);
 627   vcell = scm_sym2ovcell (s, o);
 628   SCM_SETCDR (vcell, v);
 629   return SCM_UNSPECIFIED;
 630 }
 631
 632 static void
 633 msymbolize (s)
 634      SCM s;
 635 {
 636   SCM string;
 637   string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
 638   SCM_SETCHARS (s, SCM_CHARS (string));
 639   SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol);
 640   SCM_SYMBOL_MULTI_BYTE_STRINGP (s) = SCM_BOOL_F;
 641   SCM_SETCDR (string, SCM_EOL);
 642   SCM_SETCAR (string, SCM_EOL);
 643 }
 644
 645
 646 SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref);
 647
 648 SCM
 649 scm_symbol_fref (s)
 650      SCM s;
 651 {
 652   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref);
 653   SCM_DEFER_INTS;
 654   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 655     msymbolize (s);
 656   SCM_ALLOW_INTS;
 657   return SCM_SYMBOL_FUNC (s);
 658 }
 659
 660
 661 SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref);
 662
 663 SCM
 664 scm_symbol_pref (s)
 665      SCM s;
 666 {
 667   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref);
 668   SCM_DEFER_INTS;
 669   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 670     msymbolize (s);
 671   SCM_ALLOW_INTS;
 672   return SCM_SYMBOL_PROPS (s);
 673 }
 674
 675
 676 SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x);
 677
 678 SCM
 679 scm_symbol_fset_x (s, val)
 680      SCM s;
 681      SCM val;
 682 {
 683   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x);
 684   SCM_DEFER_INTS;
 685   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 686     msymbolize (s);
 687   SCM_ALLOW_INTS;
 688   SCM_SYMBOL_FUNC (s) = val;
 689   return SCM_UNSPECIFIED;
 690 }
 691
 692
 693 SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x);
 694
 695 SCM
 696 scm_symbol_pset_x (s, val)
 697      SCM s;
 698      SCM val;
 699 {
 700   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x);
 701   SCM_DEFER_INTS;
 702   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 703     msymbolize (s);
 704   SCM_SYMBOL_PROPS (s) = val;
 705   SCM_ALLOW_INTS;
 706   return SCM_UNSPECIFIED;
 707 }
 708
 709
 710 SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash);
 711
 712 SCM
 713 scm_symbol_hash (s)
 714      SCM s;
 715 {
 716   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash);
 717   return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s));
 718 }
 719
 720
 721
 722 void
 723 scm_init_symbols ()
 724 {
 725 #include "symbols.x"
 726 }
 727