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