libguile/symbols.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #if HAVE_CONFIG_H
  21 #  include <config.h>
  22 #endif
  23
  24 #include "libguile/_scm.h"
  25 #include "libguile/chars.h"
  26 #include "libguile/eval.h"
  27 #include "libguile/hash.h"
  28 #include "libguile/smob.h"
  29 #include "libguile/variable.h"
  30 #include "libguile/alist.h"
  31 #include "libguile/fluids.h"
  32 #include "libguile/strings.h"
  33 #include "libguile/vectors.h"
  34 #include "libguile/hashtab.h"
  35 #include "libguile/weaks.h"
  36 #include "libguile/modules.h"
  37 #include "libguile/read.h"
  38 #include "libguile/srfi-13.h"
  39
  40 #include "libguile/validate.h"
  41 #include "libguile/symbols.h"
  42
  43 #ifdef HAVE_STRING_H
  44 #include <string.h>
  45 #endif
  46
  47 \f
  48
  49 static SCM symbols;
  50
  51 #ifdef GUILE_DEBUG
  52 SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
  53             (),
  54             "Return the system symbol obarray.")
  55 #define FUNC_NAME s_scm_sys_symbols
  56 {
  57   return symbols;
  58 }
  59 #undef FUNC_NAME
  60 #endif
  61
  62 \f
  63
  64 /* {Symbols}
  65  */
  66
  67 /* In order to optimize reading speed, this function breaks part of
  68  * the hashtable abstraction.  The optimizations are:
  69  *
  70  * 1. The argument string can be compared directly to symbol objects
  71  *    without first creating an SCM string object.  (This would have
  72  *    been necessary if we had used the hashtable API in hashtab.h.)
  73  *
  74  * 2. We can use the raw hash value stored in scm_i_symbol_hash (sym)
  75  *    to speed up lookup.
  76  *
  77  * Both optimizations might be possible without breaking the
  78  * abstraction if the API in hashtab.c is improved.
  79  */
  80
  81 unsigned long
  82 scm_i_hash_symbol (SCM obj, unsigned long n, void *closure)
  83 {
  84   return scm_i_symbol_hash (obj) % n;
  85 }
  86
  87 static SCM
  88 lookup_interned_symbol (const char *name, size_t len,
  89                         unsigned long raw_hash)
  90 {
  91   /* Try to find the symbol in the symbols table */
  92   SCM l;
  93   unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
  94
  95   for (l = SCM_HASHTABLE_BUCKET (symbols, hash);
  96        !scm_is_null (l);
  97        l = SCM_CDR (l))
  98     {
  99       SCM pair, sym;
 100
 101       pair = SCM_CAR (l);
 102       if (!scm_is_pair (pair))
 103         abort ();
 104       if (SCM_UNPACK (SCM_CAR (pair)) == NULL)
 105         /* Weak pointer.  Ignore it.  */
 106         /* FIXME: Should we as well remove it, as in `scm_fixup_weak_alist'? */
 107         continue;
 108
 109       sym = SCM_CAR (pair);
 110
 111       if (scm_i_symbol_hash (sym) == raw_hash
 112           && scm_i_symbol_length (sym) == len)
 113         {
 114           const char *chrs = scm_i_symbol_chars (sym);
 115           size_t i = len;
 116
 117           while (i != 0)
 118             {
 119               --i;
 120               if (name[i] != chrs[i])
 121                 goto next_symbol;
 122             }
 123
 124           return sym;
 125         }
 126     next_symbol:
 127       ;
 128     }
 129
 130   return SCM_BOOL_F;
 131 }
 132
 133 static SCM
 134 scm_i_c_mem2symbol (const char *name, size_t len)
 135 {
 136   SCM symbol;
 137   size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
 138   size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
 139
 140   symbol = lookup_interned_symbol (name, len, raw_hash);
 141   if (symbol != SCM_BOOL_F)
 142     return symbol;
 143
 144   {
 145     /* The symbol was not found - create it. */
 146     SCM symbol = scm_i_c_make_symbol (name, len, 0, raw_hash,
 147                                       scm_cons (SCM_BOOL_F, SCM_EOL));
 148
 149     SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash);
 150     SCM cell = scm_cons (symbol, SCM_UNDEFINED);
 151     SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot));
 152     SCM_HASHTABLE_INCREMENT (symbols);
 153     if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols))
 154       scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol");
 155
 156     return symbol;
 157   }
 158 }
 159
 160 static SCM
 161 scm_i_mem2symbol (SCM str)
 162 {
 163   SCM symbol;
 164   const char *name = scm_i_string_chars (str);
 165   size_t len = scm_i_string_length (str);
 166   size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
 167   size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
 168
 169   symbol = lookup_interned_symbol (name, len, raw_hash);
 170   if (symbol != SCM_BOOL_F)
 171     return symbol;
 172
 173   {
 174     /* The symbol was not found - create it. */
 175     SCM symbol = scm_i_make_symbol (str, 0, raw_hash,
 176                                     scm_cons (SCM_BOOL_F, SCM_EOL));
 177
 178     SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash);
 179     SCM cell = scm_cons (symbol, SCM_UNDEFINED);
 180     SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot));
 181     SCM_HASHTABLE_INCREMENT (symbols);
 182     if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols))
 183       scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol");
 184
 185     return symbol;
 186   }
 187 }
 188
 189
 190 static SCM
 191 scm_i_mem2uninterned_symbol (SCM str)
 192 {
 193   const char *name = scm_i_string_chars (str);
 194   size_t len = scm_i_string_length (str);
 195   size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
 196
 197   return scm_i_make_symbol (str, SCM_I_F_SYMBOL_UNINTERNED,
 198                             raw_hash, scm_cons (SCM_BOOL_F, SCM_EOL));
 199 }
 200
 201 SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0,
 202             (SCM obj),
 203             "Return @code{#t} if @var{obj} is a symbol, otherwise return\n"
 204             "@code{#f}.")
 205 #define FUNC_NAME s_scm_symbol_p
 206 {
 207   return scm_from_bool (scm_is_symbol (obj));
 208 }
 209 #undef FUNC_NAME
 210
 211 SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0,
 212             (SCM symbol),
 213             "Return @code{#t} if @var{symbol} is interned, otherwise return\n"
 214             "@code{#f}.")
 215 #define FUNC_NAME s_scm_symbol_interned_p
 216 {
 217   SCM_VALIDATE_SYMBOL (1, symbol);
 218   return scm_from_bool (scm_i_symbol_is_interned (symbol));
 219 }
 220 #undef FUNC_NAME
 221
 222 SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0,
 223             (SCM name),
 224             "Return a new uninterned symbol with the name @var{name}.  "
 225             "The returned symbol is guaranteed to be unique and future "
 226             "calls to @code{string->symbol} will not return it.")
 227 #define FUNC_NAME s_scm_make_symbol
 228 {
 229   SCM_VALIDATE_STRING (1, name);
 230   return scm_i_mem2uninterned_symbol (name);
 231 }
 232 #undef FUNC_NAME
 233
 234 SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0,
 235            (SCM s),
 236             "Return the name of @var{symbol} as a string.  If the symbol was\n"
 237             "part of an object returned as the value of a literal expression\n"
 238             "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n"
 239             "Report on Scheme}) or by a call to the @code{read} procedure,\n"
 240             "and its name contains alphabetic characters, then the string\n"
 241             "returned will contain characters in the implementation's\n"
 242             "preferred standard case---some implementations will prefer\n"
 243             "upper case, others lower case.  If the symbol was returned by\n"
 244             "@code{string->symbol}, the case of characters in the string\n"
 245             "returned will be the same as the case in the string that was\n"
 246             "passed to @code{string->symbol}.  It is an error to apply\n"
 247             "mutation procedures like @code{string-set!} to strings returned\n"
 248             "by this procedure.\n"
 249             "\n"
 250             "The following examples assume that the implementation's\n"
 251             "standard case is lower case:\n"
 252             "\n"
 253             "@lisp\n"
 254             "(symbol->string 'flying-fish)    @result{} \"flying-fish\"\n"
 255             "(symbol->string 'Martin)         @result{}  \"martin\"\n"
 256             "(symbol->string\n"
 257             "   (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
 258             "@end lisp")
 259 #define FUNC_NAME s_scm_symbol_to_string
 260 {
 261   SCM_VALIDATE_SYMBOL (1, s);
 262   return scm_i_symbol_substring (s, 0, scm_i_symbol_length (s));
 263 }
 264 #undef FUNC_NAME
 265
 266
 267 SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0,
 268             (SCM string),
 269             "Return the symbol whose name is @var{string}. This procedure\n"
 270             "can create symbols with names containing special characters or\n"
 271             "letters in the non-standard case, but it is usually a bad idea\n"
 272             "to create such symbols because in some implementations of\n"
 273             "Scheme they cannot be read as themselves.  See\n"
 274             "@code{symbol->string}.\n"
 275             "\n"
 276             "The following examples assume that the implementation's\n"
 277             "standard case is lower case:\n"
 278             "\n"
 279             "@lisp\n"
 280             "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
 281             "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
 282             "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
 283             "(eq? 'JollyWog\n"
 284             "  (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
 285             "(string=? \"K. Harper, M.D.\"\n"
 286             "  (symbol->string\n"
 287             "    (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
 288             "@end lisp")
 289 #define FUNC_NAME s_scm_string_to_symbol
 290 {
 291   SCM_VALIDATE_STRING (1, string);
 292   return scm_i_mem2symbol (string);
 293 }
 294 #undef FUNC_NAME
 295
 296 SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
 297             (SCM str),
 298             "Return the symbol whose name is @var{str}.  @var{str} is\n"
 299             "converted to lowercase before the conversion is done, if Guile\n"
 300             "is currently reading symbols case-insensitively.")
 301 #define FUNC_NAME s_scm_string_ci_to_symbol
 302 {
 303   return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
 304                                ? scm_string_downcase(str)
 305                                : str);
 306 }
 307 #undef FUNC_NAME
 308
 309 #define MAX_PREFIX_LENGTH 30
 310
 311 SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
 312             (SCM prefix),
 313             "Create a new symbol with a name constructed from a prefix and\n"
 314             "a counter value. The string @var{prefix} can be specified as\n"
 315             "an optional argument. Default prefix is @code{ g}.  The counter\n"
 316             "is increased by 1 at each call. There is no provision for\n"
 317             "resetting the counter.")
 318 #define FUNC_NAME s_scm_gensym
 319 {
 320   static int gensym_counter = 0;
 321
 322   SCM suffix, name;
 323   int n, n_digits;
 324   char buf[SCM_INTBUFLEN];
 325
 326   if (SCM_UNBNDP (prefix))
 327     prefix = scm_from_locale_string (" g");
 328
 329   /* mutex in case another thread looks and incs at the exact same moment */
 330   scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
 331   n = gensym_counter++;
 332   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 333
 334   n_digits = scm_iint2str (n, 10, buf);
 335   suffix = scm_from_locale_stringn (buf, n_digits);
 336   name = scm_string_append (scm_list_2 (prefix, suffix));
 337   return scm_string_to_symbol (name);
 338 }
 339 #undef FUNC_NAME
 340
 341 SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0,
 342             (SCM symbol),
 343             "Return a hash value for @var{symbol}.")
 344 #define FUNC_NAME s_scm_symbol_hash
 345 {
 346   SCM_VALIDATE_SYMBOL (1, symbol);
 347   return scm_from_ulong (scm_i_symbol_hash (symbol));
 348 }
 349 #undef FUNC_NAME
 350
 351 SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0,
 352            (SCM s),
 353             "Return the contents of @var{symbol}'s @dfn{function slot}.")
 354 #define FUNC_NAME s_scm_symbol_fref
 355 {
 356   SCM_VALIDATE_SYMBOL (1, s);
 357   return SCM_CAR (SCM_CELL_OBJECT_3 (s));
 358 }
 359 #undef FUNC_NAME
 360
 361
 362 SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0,
 363            (SCM s),
 364             "Return the @dfn{property list} currently associated with @var{symbol}.")
 365 #define FUNC_NAME s_scm_symbol_pref
 366 {
 367   SCM_VALIDATE_SYMBOL (1, s);
 368   return SCM_CDR (SCM_CELL_OBJECT_3 (s));
 369 }
 370 #undef FUNC_NAME
 371
 372
 373 SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
 374            (SCM s, SCM val),
 375             "Change the binding of @var{symbol}'s function slot.")
 376 #define FUNC_NAME s_scm_symbol_fset_x
 377 {
 378   SCM_VALIDATE_SYMBOL (1, s);
 379   SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val);
 380   return SCM_UNSPECIFIED;
 381 }
 382 #undef FUNC_NAME
 383
 384
 385 SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
 386            (SCM s, SCM val),
 387             "Change the binding of @var{symbol}'s property slot.")
 388 #define FUNC_NAME s_scm_symbol_pset_x
 389 {
 390   SCM_VALIDATE_SYMBOL (1, s);
 391   SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val);
 392   return SCM_UNSPECIFIED;
 393 }
 394 #undef FUNC_NAME
 395
 396 SCM
 397 scm_from_locale_symbol (const char *sym)
 398 {
 399   return scm_i_c_mem2symbol (sym, strlen (sym));
 400 }
 401
 402 SCM
 403 scm_from_locale_symboln (const char *sym, size_t len)
 404 {
 405   return scm_i_c_mem2symbol (sym, len);
 406 }
 407
 408 SCM
 409 scm_take_locale_symboln (char *sym, size_t len)
 410 {
 411   SCM res;
 412   unsigned long raw_hash;
 413
 414   if (len == (size_t)-1)
 415     len = strlen (sym);
 416   else
 417     {
 418       /* Ensure STR is null terminated.  A realloc for 1 extra byte should
 419          often be satisfied from the alignment padding after the block, with
 420          no actual data movement.  */
 421       sym = scm_realloc (sym, len+1);
 422       sym[len] = '\0';
 423     }
 424
 425   raw_hash = scm_string_hash ((unsigned char *)sym, len);
 426   res = lookup_interned_symbol (sym, len, raw_hash);
 427   if (res != SCM_BOOL_F)
 428     {
 429       free (sym);
 430       return res;
 431     }
 432
 433   res = scm_i_c_take_symbol (sym, len, 0, raw_hash,
 434                              scm_cons (SCM_BOOL_F, SCM_EOL));
 435
 436   return res;
 437 }
 438
 439 SCM
 440 scm_take_locale_symbol (char *sym)
 441 {
 442   return scm_take_locale_symboln (sym, (size_t)-1);
 443 }
 444
 445 void
 446 scm_symbols_prehistory ()
 447 {
 448   symbols = scm_make_weak_key_hash_table (scm_from_int (2139));
 449   scm_permanent_object (symbols);
 450 }
 451
 452
 453 void
 454 scm_init_symbols ()
 455 {
 456 #include "libguile/symbols.x"
 457 }
 458
 459 /*
 460   Local Variables:
 461   c-file-style: "gnu"
 462   End:
 463 */