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