libguile/symbols.c

   1 /*      Copyright (C) 1995,1996,1997,1998, 2000, 2001 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, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include "libguile/_scm.h"
  48 #include "libguile/chars.h"
  49 #include "libguile/eval.h"
  50 #include "libguile/hash.h"
  51 #include "libguile/smob.h"
  52 #include "libguile/variable.h"
  53 #include "libguile/alist.h"
  54 #include "libguile/fluids.h"
  55 #include "libguile/strings.h"
  56 #include "libguile/vectors.h"
  57 #include "libguile/hashtab.h"
  58 #include "libguile/weaks.h"
  59 #include "libguile/modules.h"
  60
  61 #include "libguile/validate.h"
  62 #include "libguile/symbols.h"
  63
  64 #ifdef HAVE_STRING_H
  65 #include <string.h>
  66 #endif
  67
  68 \f
  69
  70 static SCM symbols;
  71
  72 #ifdef GUILE_DEBUG
  73 SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
  74             (),
  75             "Return the system symbol obarray.")
  76 #define FUNC_NAME s_scm_sys_symbols
  77 {
  78   return symbols;
  79 }
  80 #undef FUNC_NAME
  81 #endif
  82
  83 \f
  84
  85 /* {Symbols}
  86  */
  87
  88
  89 SCM
  90 scm_mem2symbol (const char *name, size_t len)
  91 {
  92   size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
  93   size_t hash = raw_hash % SCM_VECTOR_LENGTH (symbols);
  94
  95   {
  96     /* Try to find the symbol in the symbols table */
  97
  98     SCM l;
  99
 100     for (l = SCM_VELTS (symbols) [hash]; !SCM_NULLP (l); l = SCM_CDR (l))
 101       {
 102         SCM sym = SCM_CAAR (l);
 103         if (SCM_SYMBOL_HASH (sym) == raw_hash
 104             && SCM_SYMBOL_LENGTH (sym) == len)
 105           {
 106             char *chrs = SCM_SYMBOL_CHARS (sym);
 107             size_t i = len;
 108
 109             while (i != 0)
 110               {
 111                 --i;
 112                 if (name[i] != chrs[i])
 113                   goto next_symbol;
 114               }
 115
 116             return sym;
 117           }
 118       next_symbol:
 119         ;
 120       }
 121   }
 122
 123   {
 124     /* The symbol was not found - create it. */
 125
 126     SCM symbol;
 127     SCM cell;
 128     SCM slot;
 129
 130     SCM_NEWCELL2 (symbol);
 131     SCM_SET_SYMBOL_CHARS (symbol, scm_must_strndup (name, len));
 132     SCM_SET_SYMBOL_HASH (symbol, raw_hash);
 133     SCM_SET_PROP_SLOTS (symbol, scm_cons (SCM_BOOL_F, SCM_EOL));
 134     SCM_SET_SYMBOL_LENGTH (symbol, (long) len);
 135
 136     slot = SCM_VELTS (symbols) [hash];
 137     cell = scm_cons (symbol, SCM_UNDEFINED);
 138     SCM_VELTS (symbols) [hash] = scm_cons (cell, slot);
 139
 140     return symbol;
 141   }
 142 }
 143
 144
 145 SCM
 146 scm_str2symbol (const char *str)
 147 {
 148   return scm_mem2symbol (str, strlen (str));
 149 }
 150
 151 SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0,
 152             (SCM obj),
 153             "Return @code{#t} if @var{obj} is a symbol, otherwise return\n"
 154             "@code{#f}.")
 155 #define FUNC_NAME s_scm_symbol_p
 156 {
 157   return SCM_BOOL (SCM_SYMBOLP (obj));
 158 }
 159 #undef FUNC_NAME
 160
 161 SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0,
 162            (SCM s),
 163             "Return the name of @var{symbol} as a string.  If the symbol was\n"
 164             "part of an object returned as the value of a literal expression\n"
 165             "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n"
 166             "Report on Scheme}) or by a call to the @code{read} procedure,\n"
 167             "and its name contains alphabetic characters, then the string\n"
 168             "returned will contain characters in the implementation's\n"
 169             "preferred standard case---some implementations will prefer\n"
 170             "upper case, others lower case.  If the symbol was returned by\n"
 171             "@code{string->symbol}, the case of characters in the string\n"
 172             "returned will be the same as the case in the string that was\n"
 173             "passed to @code{string->symbol}.  It is an error to apply\n"
 174             "mutation procedures like @code{string-set!} to strings returned\n"
 175             "by this procedure.\n"
 176             "\n"
 177             "The following examples assume that the implementation's\n"
 178             "standard case is lower case:\n"
 179             "\n"
 180             "@lisp\n"
 181             "(symbol->string 'flying-fish)    @result{} \"flying-fish\"\n"
 182             "(symbol->string 'Martin)         @result{}  \"martin\"\n"
 183             "(symbol->string\n"
 184             "   (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
 185             "@end lisp")
 186 #define FUNC_NAME s_scm_symbol_to_string
 187 {
 188   SCM_VALIDATE_SYMBOL (1, s);
 189   return scm_makfromstr (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s), 0);
 190 }
 191 #undef FUNC_NAME
 192
 193
 194 SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0,
 195             (SCM string),
 196             "Return the symbol whose name is @var{string}. This procedure\n"
 197             "can create symbols with names containing special characters or\n"
 198             "letters in the non-standard case, but it is usually a bad idea\n"
 199             "to create such symbols because in some implementations of\n"
 200             "Scheme they cannot be read as themselves.  See\n"
 201             "@code{symbol->string}.\n"
 202             "\n"
 203             "The following examples assume that the implementation's\n"
 204             "standard case is lower case:\n"
 205             "\n"
 206             "@lisp\n"
 207             "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
 208             "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
 209             "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
 210             "(eq? 'JollyWog\n"
 211             "  (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
 212             "(string=? \"K. Harper, M.D.\"\n"
 213             "  (symbol->string\n"
 214             "    (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
 215             "@end lisp")
 216 #define FUNC_NAME s_scm_string_to_symbol
 217 {
 218   SCM_VALIDATE_STRING (1, string);
 219   return scm_mem2symbol (SCM_STRING_CHARS (string),
 220                          SCM_STRING_LENGTH (string));
 221 }
 222 #undef FUNC_NAME
 223
 224 #define MAX_PREFIX_LENGTH 30
 225
 226 static int gensym_counter;
 227
 228 SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
 229             (SCM prefix),
 230             "Create a new symbol with a name constructed from a prefix and\n"
 231             "a counter value. The string @var{prefix} can be specified as\n"
 232             "an optional argument. Default prefix is @code{g}.  The counter\n"
 233             "is increased by 1 at each call. There is no provision for\n"
 234             "resetting the counter.")
 235 #define FUNC_NAME s_scm_gensym
 236 {
 237   char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
 238   char *name = buf;
 239   size_t len;
 240   if (SCM_UNBNDP (prefix))
 241     {
 242       name[0] = 'g';
 243       len = 1;
 244     }
 245   else
 246     {
 247       SCM_VALIDATE_STRING (1, prefix);
 248       len = SCM_STRING_LENGTH (prefix);
 249       if (len > MAX_PREFIX_LENGTH)
 250         name = SCM_MUST_MALLOC (len + SCM_INTBUFLEN);
 251       memcpy (name, SCM_STRING_CHARS (prefix), len);
 252     }
 253   {
 254     int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]);
 255     SCM res = scm_mem2symbol (name, len + n_digits);
 256     if (name != buf)
 257       scm_must_free (name);
 258     return res;
 259   }
 260 }
 261 #undef FUNC_NAME
 262
 263 SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0,
 264             (SCM symbol),
 265             "Return a hash value for @var{symbol}.")
 266 #define FUNC_NAME s_scm_symbol_hash
 267 {
 268   SCM_VALIDATE_SYMBOL (1, symbol);
 269   return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol));
 270 }
 271 #undef FUNC_NAME
 272
 273 SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0,
 274            (SCM s),
 275             "Return the contents of @var{symbol}'s @dfn{function slot}.")
 276 #define FUNC_NAME s_scm_symbol_fref
 277 {
 278   SCM_VALIDATE_SYMBOL (1,s);
 279   return SCM_SYMBOL_FUNC (s);
 280 }
 281 #undef FUNC_NAME
 282
 283
 284 SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0,
 285            (SCM s),
 286             "Return the @dfn{property list} currently associated with @var{symbol}.")
 287 #define FUNC_NAME s_scm_symbol_pref
 288 {
 289   SCM_VALIDATE_SYMBOL (1,s);
 290   return SCM_SYMBOL_PROPS (s);
 291 }
 292 #undef FUNC_NAME
 293
 294
 295 SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
 296            (SCM s, SCM val),
 297             "Change the binding of @var{symbol}'s function slot.")
 298 #define FUNC_NAME s_scm_symbol_fset_x
 299 {
 300   SCM_VALIDATE_SYMBOL (1,s);
 301   SCM_SET_SYMBOL_FUNC (s, val);
 302   return SCM_UNSPECIFIED;
 303 }
 304 #undef FUNC_NAME
 305
 306
 307 SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
 308            (SCM s, SCM val),
 309             "Change the binding of @var{symbol}'s property slot.")
 310 #define FUNC_NAME s_scm_symbol_pset_x
 311 {
 312   SCM_VALIDATE_SYMBOL (1,s);
 313   SCM_DEFER_INTS;
 314   SCM_SET_SYMBOL_PROPS (s, val);
 315   SCM_ALLOW_INTS;
 316   return SCM_UNSPECIFIED;
 317 }
 318 #undef FUNC_NAME
 319
 320 void
 321 scm_symbols_prehistory ()
 322 {
 323   symbols = scm_make_weak_key_hash_table (SCM_MAKINUM (1009));
 324   scm_permanent_object (symbols);
 325 }
 326
 327
 328 void
 329 scm_init_symbols ()
 330 {
 331   gensym_counter = 0;
 332 #ifndef SCM_MAGIC_SNARFER
 333 #include "libguile/symbols.x"
 334 #endif
 335 #if SCM_ENABLE_VCELLS
 336   scm_init_symbols_deprecated ();
 337 #endif
 338 }
 339
 340 /*
 341   Local Variables:
 342   c-file-style: "gnu"
 343   End:
 344 */