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
  46 #ifdef HAVE_STRING_H
  47 #include <string.h>
  48 #endif
  49
  50 \f
  51
  52
  53 /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets.
  54  */
  55 #define NUM_HASH_BUCKETS 137
  56
  57 \f
  58
  59
  60 /* {Symbols}
  61  */
  62
  63 #ifdef __STDC__
  64 unsigned long
  65 scm_strhash (unsigned char *str, scm_sizet len, unsigned long n)
  66 #else
  67 unsigned long
  68 scm_strhash (str, len, n)
  69      unsigned char *str;
  70      scm_sizet len;
  71      unsigned long n;
  72 #endif
  73 {
  74   if (len > 5)
  75     {
  76       scm_sizet i = 5;
  77       unsigned long h = 264 % n;
  78       while (i--)
  79         h = ((h << 8) + ((unsigned) (scm_downcase[str[h % len]]))) % n;
  80       return h;
  81     }
  82   else
  83     {
  84       scm_sizet i = len;
  85       unsigned long h = 0;
  86       while (i)
  87         h = ((h << 8) + ((unsigned) (scm_downcase[str[--i]]))) % n;
  88       return h;
  89     }
  90 }
  91
  92 int scm_symhash_dim = NUM_HASH_BUCKETS;
  93
  94
  95 /* scm_sym2vcell
  96  * looks up the symbol in the symhash table.
  97  */
  98 #ifdef __STDC__
  99 SCM
 100 scm_sym2vcell (SCM sym, SCM thunk, SCM definep)
 101 #else
 102 SCM
 103 scm_sym2vcell (sym, thunk, definep)
 104      SCM sym;
 105      SCM thunk;
 106      SCM definep;
 107 #endif
 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_CDR (lsym)))
 144         {
 145           z = SCM_CAR (lsym);
 146           if (SCM_CAR (z) == sym)
 147             {
 148               if (definep)
 149                 {
 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 (defaulting to scm_symhash).
 165  */
 166 #ifdef __STDC__
 167 SCM
 168 scm_sym2ovcell_soft (SCM sym, SCM obarray)
 169 #else
 170 SCM
 171 scm_sym2ovcell_soft (sym, obarray)
 172      SCM sym;
 173      SCM obarray;
 174 #endif
 175 {
 176   SCM lsym, z;
 177   scm_sizet scm_hash;
 178
 179   scm_hash = scm_strhash (SCM_UCHARS (sym),
 180                           (scm_sizet) SCM_LENGTH (sym),
 181                           SCM_LENGTH (obarray));
 182   SCM_REDEFER_INTS;
 183   for (lsym = SCM_VELTS (obarray)[scm_hash];
 184        SCM_NIMP (lsym);
 185        lsym = SCM_CDR (lsym))
 186     {
 187       z = SCM_CAR (lsym);
 188       if (SCM_CAR (z) == sym)
 189         {
 190           SCM_REALLOW_INTS;
 191           return z;
 192         }
 193     }
 194   SCM_REALLOW_INTS;
 195   return SCM_BOOL_F;
 196 }
 197
 198 #ifdef __STDC__
 199 SCM
 200 scm_sym2ovcell (SCM sym, SCM obarray)
 201 #else
 202 SCM
 203 scm_sym2ovcell (sym, obarray)
 204      SCM sym;
 205      SCM obarray;
 206 #endif
 207 {
 208   SCM answer;
 209   answer = scm_sym2ovcell_soft (sym, obarray);
 210   if (answer != SCM_BOOL_F)
 211     return answer;
 212   scm_wta (sym, "uninterned symbol? ", "");
 213   return SCM_UNSPECIFIED;               /* not reached */
 214 }
 215
 216 #ifdef __STDC__
 217 SCM
 218 scm_intern_obarray_soft (char *name, scm_sizet len, SCM obarray, int softness)
 219 #else
 220 SCM
 221 scm_intern_obarray_soft (name, len, obarray, softness)
 222      char *name;
 223      scm_sizet len;
 224      SCM obarray;
 225      int softness;
 226 #endif
 227 {
 228   SCM lsym;
 229   SCM z;
 230   register scm_sizet i;
 231   register unsigned char *tmp;
 232   scm_sizet scm_hash;
 233
 234   SCM_REDEFER_INTS;
 235
 236   i = len;
 237   tmp = (unsigned char *) name;
 238
 239   if (obarray == SCM_BOOL_F)
 240     {
 241       scm_hash = scm_strhash (tmp, i, 1019);
 242       goto uninterned_symbol;
 243     }
 244
 245   scm_hash = scm_strhash (tmp, i, SCM_LENGTH(obarray));
 246
 247   if (softness == -1)
 248     goto mustintern_symbol;
 249
 250  retry_new_obarray:
 251   for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
 252     {
 253       z = SCM_CAR (lsym);
 254       z = SCM_CAR (z);
 255       tmp = SCM_UCHARS (z);
 256       if (SCM_LENGTH (z) != len)
 257         goto trynext;
 258       for (i = len; i--;)
 259         if (((unsigned char *) name)[i] != tmp[i])
 260           goto trynext;
 261       {
 262         SCM a;
 263         a = SCM_CAR (lsym);
 264         SCM_REALLOW_INTS;
 265         return a;
 266       }
 267     trynext:;
 268     }
 269
 270   if (obarray == scm_symhash)
 271     {
 272       obarray = scm_weak_symhash;
 273       goto retry_new_obarray;
 274     }
 275
 276  uninterned_symbol:
 277   if (softness)
 278     {
 279       SCM_REALLOW_INTS;
 280       return SCM_BOOL_F;
 281     }
 282
 283  mustintern_symbol:
 284   lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS);
 285
 286   SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol);
 287   SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (lsym) = SCM_BOOL_F;
 288   SCM_SYMBOL_HASH (lsym) = scm_hash;
 289   if (obarray == SCM_BOOL_F)
 290     {
 291       SCM answer;
 292       SCM_REALLOW_INTS;
 293       SCM_NEWCELL (answer);
 294       SCM_DEFER_INTS;
 295       SCM_CAR (answer) = lsym;
 296       SCM_CDR (answer) = SCM_UNDEFINED;
 297       SCM_REALLOW_INTS;
 298       return answer;
 299     }
 300   else
 301     {
 302       SCM a;
 303       SCM b;
 304
 305       SCM_NEWCELL (a);
 306       SCM_NEWCELL (b);
 307       SCM_SETCAR (a, lsym);
 308       SCM_SETCDR (a, SCM_UNDEFINED);
 309       SCM_SETCAR (b, a);
 310       SCM_SETCDR (b, SCM_VELTS(obarray)[scm_hash]);
 311       SCM_VELTS(obarray)[scm_hash] = b;
 312       SCM_REALLOW_INTS;
 313       return SCM_CAR (b);
 314     }
 315 }
 316
 317 #ifdef __STDC__
 318 SCM
 319 scm_intern_obarray (char *name, scm_sizet len, SCM obarray)
 320 #else
 321 SCM
 322 scm_intern_obarray (name, len, obarray)
 323      char *name;
 324      scm_sizet len;
 325      SCM obarray;
 326 #endif
 327 {
 328   return scm_intern_obarray_soft (name, len, obarray, 0);
 329 }
 330
 331
 332 #ifdef __STDC__
 333 SCM
 334 scm_intern (char *name, scm_sizet len)
 335 #else
 336 SCM
 337 scm_intern (name, len)
 338      char *name;
 339      scm_sizet len;
 340 #endif
 341 {
 342   return scm_intern_obarray (name, len, scm_symhash);
 343 }
 344
 345 #ifdef __STDC__
 346 SCM
 347 scm_intern0 (char * name)
 348 #else
 349 SCM
 350 scm_intern0 (name)
 351      char * name;
 352 #endif
 353 {
 354   return scm_intern (name, strlen (name));
 355 }
 356
 357
 358 #ifdef __STDC__
 359 SCM
 360 scm_sysintern (char *name, SCM val)
 361 #else
 362 SCM
 363 scm_sysintern (name, val)
 364      char *name;
 365      SCM val;
 366 #endif
 367 {
 368   SCM easy_answer;
 369   SCM_DEFER_INTS;
 370   easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1);
 371   if (SCM_NIMP (easy_answer))
 372     {
 373       SCM_CDR (easy_answer) = val;
 374       SCM_ALLOW_INTS;
 375       return easy_answer;
 376     }
 377   else
 378     {
 379       SCM lsym;
 380       scm_sizet len = strlen (name);
 381       register unsigned char *tmp = (unsigned char *) name;
 382       scm_sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim);
 383       SCM_NEWCELL (lsym);
 384       SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol);
 385       SCM_SETCHARS (lsym, name);
 386       lsym = scm_cons (lsym, val);
 387       SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]);
 388       SCM_ALLOW_INTS;
 389       return lsym;
 390     }
 391 }
 392
 393
 394 SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
 395 #ifdef __STDC__
 396 SCM
 397 scm_symbol_p(SCM x)
 398 #else
 399 SCM
 400 scm_symbol_p(x)
 401      SCM x;
 402 #endif
 403 {
 404         if SCM_IMP(x) return SCM_BOOL_F;
 405         return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
 406 }
 407
 408 SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string);
 409 #ifdef __STDC__
 410 SCM
 411 scm_symbol_to_string(SCM s)
 412 #else
 413 SCM
 414 scm_symbol_to_string(s)
 415      SCM s;
 416 #endif
 417 {
 418         SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string);
 419         return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0);
 420 }
 421
 422
 423 SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol);
 424 #ifdef __STDC__
 425 SCM
 426 scm_string_to_symbol(SCM s)
 427 #else
 428 SCM
 429 scm_string_to_symbol(s)
 430      SCM s;
 431 #endif
 432 {
 433   SCM vcell;
 434   SCM answer;
 435
 436   SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol);
 437   vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s));
 438   answer = SCM_CAR (vcell);
 439   if (SCM_TYP7 (answer) == scm_tc7_msymbol)
 440     {
 441       if (SCM_REGULAR_STRINGP (s))
 442         SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_F;
 443       else
 444         SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_T;
 445     }
 446   return answer;
 447 }
 448
 449
 450 SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol);
 451 #ifdef __STDC__
 452 SCM
 453 scm_string_to_obarray_symbol(SCM o, SCM s, SCM softp)
 454 #else
 455 SCM
 456 scm_string_to_obarray_symbol(o, s, softp)
 457      SCM o;
 458      SCM s;
 459      SCM softp;
 460 #endif
 461 {
 462   SCM vcell;
 463   SCM answer;
 464   int softness;
 465
 466   SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2, s_string_to_obarray_symbol);
 467   SCM_ASSERT((o == SCM_BOOL_F) || (o == SCM_BOOL_T) || (SCM_NIMP(o) && SCM_VECTORP(o)),
 468          o, SCM_ARG1, s_string_to_obarray_symbol);
 469
 470   softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F));
 471   /* iron out some screwy calling conventions */
 472   if (o == SCM_BOOL_F)
 473     o = scm_symhash;
 474   else if (o == SCM_BOOL_T)
 475     o = SCM_BOOL_F;
 476
 477   vcell = scm_intern_obarray_soft (SCM_ROCHARS(s), (scm_sizet)SCM_ROLENGTH(s), o, softness);
 478   if (vcell == SCM_BOOL_F)
 479     return vcell;
 480   answer = SCM_CAR (vcell);
 481   if (SCM_TYP7 (s) == scm_tc7_msymbol)
 482     {
 483       if (SCM_REGULAR_STRINGP (s))
 484         SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_F;
 485       else
 486         SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_T;
 487     }
 488   return answer;
 489 }
 490
 491 SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol);
 492 #ifdef __STDC__
 493 SCM
 494 scm_intern_symbol(SCM o, SCM s)
 495 #else
 496 SCM
 497 scm_intern_symbol(o, s)
 498      SCM o;
 499      SCM s;
 500 #endif
 501 {
 502         scm_sizet hval;
 503         SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol);
 504         if (o == SCM_BOOL_F)
 505           o = scm_symhash;
 506         SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol);
 507         hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 508         /* If the symbol is already interned, simply return. */
 509         SCM_REDEFER_INTS;
 510         {
 511           SCM lsym;
 512           SCM sym;
 513           for (lsym = SCM_VELTS (o)[hval];
 514                SCM_NIMP (lsym);
 515                lsym = SCM_CDR (lsym))
 516             {
 517               sym = SCM_CAR (lsym);
 518               if (SCM_CAR (sym) == s)
 519                 {
 520                   SCM_REALLOW_INTS;
 521                   return SCM_UNSPECIFIED;
 522                 }
 523             }
 524           SCM_VELTS (o)[hval] =
 525             scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]);
 526         }
 527         SCM_REALLOW_INTS;
 528         return SCM_UNSPECIFIED;
 529 }
 530
 531 SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol);
 532 #ifdef __STDC__
 533 SCM
 534 scm_unintern_symbol(SCM o, SCM s)
 535 #else
 536 SCM
 537 scm_unintern_symbol(o, s)
 538      SCM o;
 539      SCM s;
 540 #endif
 541 {
 542         scm_sizet hval;
 543         SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol);
 544         if (o == SCM_BOOL_F)
 545           o = scm_symhash;
 546         SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol);
 547         hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
 548         SCM_DEFER_INTS;
 549         {
 550           SCM lsym_follow;
 551           SCM lsym;
 552           SCM sym;
 553           for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F;
 554                SCM_NIMP (lsym);
 555                lsym_follow = lsym, lsym = SCM_CDR (lsym))
 556             {
 557               sym = SCM_CAR (lsym);
 558               if (SCM_CAR (sym) == s)
 559                 {
 560                   /* Found the symbol to unintern. */
 561                   if (lsym_follow == SCM_BOOL_F)
 562                     SCM_VELTS(o)[hval] = lsym;
 563                   else
 564                     SCM_CDR(lsym_follow) = SCM_CDR(lsym);
 565                   SCM_ALLOW_INTS;
 566                   return SCM_BOOL_T;
 567                 }
 568             }
 569         }
 570         SCM_ALLOW_INTS;
 571         return SCM_BOOL_F;
 572 }
 573
 574 SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding);
 575 #ifdef __STDC__
 576 SCM
 577 scm_symbol_binding (SCM o, SCM s)
 578 #else
 579 SCM
 580 scm_symbol_binding (o, s)
 581      SCM o;
 582      SCM s;
 583 #endif
 584 {
 585   SCM vcell;
 586   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding);
 587   if (o == SCM_BOOL_F)
 588     o = scm_symhash;
 589   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_binding);
 590   vcell = scm_sym2ovcell (s, o);
 591   return SCM_CDR(vcell);
 592 }
 593
 594
 595 SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p);
 596 #ifdef __STDC__
 597 SCM
 598 scm_symbol_interned_p (SCM o, SCM s)
 599 #else
 600 SCM
 601 scm_symbol_interned_p (o, s)
 602      SCM o;
 603      SCM s;
 604 #endif
 605 {
 606   SCM vcell;
 607   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p);
 608   if (o == SCM_BOOL_F)
 609     o = scm_symhash;
 610   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_interned_p);
 611   vcell = scm_sym2ovcell_soft (s, o);
 612   if (SCM_IMP(vcell) && (o == scm_symhash))
 613     vcell = scm_sym2ovcell_soft (s, scm_weak_symhash);
 614   return (SCM_NIMP(vcell)
 615           ? SCM_BOOL_T
 616           : SCM_BOOL_F);
 617 }
 618
 619
 620 SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p);
 621 #ifdef __STDC__
 622 SCM
 623 scm_symbol_bound_p (SCM o, SCM s)
 624 #else
 625 SCM
 626 scm_symbol_bound_p (o, s)
 627      SCM o;
 628      SCM s;
 629 #endif
 630 {
 631   SCM vcell;
 632   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_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_bound_p);
 636   vcell = scm_sym2ovcell_soft (s, o);
 637   return ((  SCM_NIMP(vcell)
 638            && (SCM_CDR(vcell) != SCM_UNDEFINED))
 639           ? SCM_BOOL_T
 640           : SCM_BOOL_F);
 641 }
 642
 643
 644 SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x);
 645 #ifdef __STDC__
 646 SCM
 647 scm_symbol_set_x (SCM o, SCM s, SCM v)
 648 #else
 649 SCM
 650 scm_symbol_set_x (o, s, v)
 651      SCM o;
 652      SCM s;
 653      SCM v;
 654 #endif
 655 {
 656   SCM vcell;
 657   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x);
 658   if (o == SCM_BOOL_F)
 659     o = scm_symhash;
 660   SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x);
 661   vcell = scm_sym2ovcell (s, o);
 662   SCM_CDR(vcell) = v;
 663   return SCM_UNSPECIFIED;
 664 }
 665
 666 static void
 667 msymbolize (s)
 668      SCM s;
 669 {
 670   SCM string;
 671   string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
 672   SCM_SETCHARS (s, SCM_CHARS (string));
 673   SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol);
 674   SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (s) = SCM_BOOL_F;
 675   SCM_CDR (string) = SCM_EOL;
 676   SCM_CAR (string) = SCM_EOL;
 677 }
 678
 679
 680 SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref);
 681 #ifdef __STDC__
 682 SCM
 683 scm_symbol_fref (SCM s)
 684 #else
 685 SCM
 686 scm_symbol_fref (s)
 687      SCM s;
 688 #endif
 689 {
 690   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref);
 691   SCM_DEFER_INTS;
 692   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 693     msymbolize (s);
 694   SCM_ALLOW_INTS;
 695   return SCM_SYMBOL_FUNC (s);
 696 }
 697
 698
 699 SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref);
 700 #ifdef __STDC__
 701 SCM
 702 scm_symbol_pref (SCM s)
 703 #else
 704 SCM
 705 scm_symbol_pref (s)
 706      SCM s;
 707 #endif
 708 {
 709   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref);
 710   SCM_DEFER_INTS;
 711   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 712     msymbolize (s);
 713   SCM_ALLOW_INTS;
 714   return SCM_SYMBOL_PROPS (s);
 715 }
 716
 717
 718 SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x);
 719 #ifdef __STDC__
 720 SCM
 721 scm_symbol_fset_x (SCM s, SCM val)
 722 #else
 723 SCM
 724 scm_symbol_fset_x (s, val)
 725      SCM s;
 726      SCM val;
 727 #endif
 728 {
 729   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x);
 730   SCM_DEFER_INTS;
 731   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 732     msymbolize (s);
 733   SCM_ALLOW_INTS;
 734   SCM_SYMBOL_FUNC (s) = val;
 735   return SCM_UNSPECIFIED;
 736 }
 737
 738
 739 SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x);
 740 #ifdef __STDC__
 741 SCM
 742 scm_symbol_pset_x (SCM s, SCM val)
 743 #else
 744 SCM
 745 scm_symbol_pset_x (s, val)
 746      SCM s;
 747      SCM val;
 748 #endif
 749 {
 750   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x);
 751   SCM_DEFER_INTS;
 752   if (SCM_TYP7(s) == scm_tc7_ssymbol)
 753     msymbolize (s);
 754   SCM_SYMBOL_PROPS (s) = val;
 755   SCM_ALLOW_INTS;
 756   return SCM_UNSPECIFIED;
 757 }
 758
 759
 760 SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash);
 761 #ifdef __STDC__
 762 SCM
 763 scm_symbol_hash (SCM s)
 764 #else
 765 SCM
 766 scm_symbol_hash (s)
 767      SCM s;
 768 #endif
 769 {
 770   SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash);
 771   return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s));
 772 }
 773
 774
 775 #ifdef __STDC__
 776 void
 777 scm_init_symbols (void)
 778 #else
 779 void
 780 scm_init_symbols ()
 781 #endif
 782 {
 783 #include "symbols.x"
 784 }
 785