1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 Free Software Foundation, Inc.
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.
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.
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
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"
38 #include "libguile/validate.h"
39 #include "libguile/symbols.h"
50 SCM_DEFINE (scm_sys_symbols
, "%symbols", 0, 0, 0,
52 "Return the system symbol obarray.")
53 #define FUNC_NAME s_scm_sys_symbols
65 /* In order to optimize reading speed, this function breaks part of
66 * the hashtable abstraction. The optimizations are:
68 * 1. The argument string can be compared directly to symbol objects
69 * without first creating an SCM string object. (This would have
70 * been necessary if we had used the hashtable API in hashtab.h.)
72 * 2. We can use the raw hash value stored in SCM_SYMBOL_HASH (sym)
75 * Both optimizations might be possible without breaking the
76 * abstraction if the API in hashtab.c is improved.
80 scm_i_hash_symbol (SCM obj
, unsigned long n
, void *closure
)
82 return SCM_SYMBOL_HASH (obj
) % n
;
86 scm_mem2symbol (const char *name
, size_t len
)
88 size_t raw_hash
= scm_string_hash ((const unsigned char *) name
, len
) / 2;
89 size_t hash
= raw_hash
% SCM_HASHTABLE_N_BUCKETS (symbols
);
92 /* Try to find the symbol in the symbols table */
96 for (l
= SCM_HASHTABLE_BUCKETS (symbols
) [hash
];
100 SCM sym
= SCM_CAAR (l
);
101 if (SCM_SYMBOL_HASH (sym
) == raw_hash
102 && SCM_SYMBOL_LENGTH (sym
) == len
)
104 char *chrs
= SCM_SYMBOL_CHARS (sym
);
110 if (name
[i
] != chrs
[i
])
122 /* The symbol was not found - create it. */
123 SCM symbol
= scm_double_cell (SCM_MAKE_SYMBOL_TAG (len
),
124 (scm_t_bits
) scm_gc_strndup (name
, len
,
127 SCM_UNPACK (scm_cons (SCM_BOOL_F
, SCM_EOL
)));
129 SCM slot
= SCM_HASHTABLE_BUCKETS (symbols
) [hash
];
130 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
131 SCM_SET_HASHTABLE_BUCKET (symbols
, hash
, scm_cons (cell
, slot
));
132 SCM_HASHTABLE_INCREMENT (symbols
);
133 if (SCM_HASHTABLE_N_ITEMS (symbols
) > SCM_HASHTABLE_UPPER (symbols
))
134 scm_i_rehash (symbols
, scm_i_hash_symbol
, 0, "scm_mem2symbol");
141 scm_mem2uninterned_symbol (const char *name
, size_t len
)
143 size_t raw_hash
= (scm_string_hash ((const unsigned char *) name
, len
)/2
144 + SCM_T_BITS_MAX
/2 + 1);
146 return scm_double_cell (SCM_MAKE_SYMBOL_TAG (len
),
147 (scm_t_bits
) scm_gc_strndup (name
, len
,
150 SCM_UNPACK (scm_cons (SCM_BOOL_F
, SCM_EOL
)));
154 scm_str2symbol (const char *str
)
156 return scm_mem2symbol (str
, strlen (str
));
159 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
161 "Return @code{#t} if @var{obj} is a symbol, otherwise return\n"
163 #define FUNC_NAME s_scm_symbol_p
165 return scm_from_bool (SCM_SYMBOLP (obj
));
169 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 1, 0, 0,
171 "Return @code{#t} if @var{symbol} is interned, otherwise return\n"
173 #define FUNC_NAME s_scm_symbol_interned_p
175 SCM_VALIDATE_SYMBOL (1, symbol
);
176 return scm_from_bool (SCM_SYMBOL_INTERNED_P (symbol
));
180 SCM_DEFINE (scm_make_symbol
, "make-symbol", 1, 0, 0,
182 "Return a new uninterned symbol with the name @var{name}. "
183 "The returned symbol is guaranteed to be unique and future "
184 "calls to @code{string->symbol} will not return it.")
185 #define FUNC_NAME s_scm_make_symbol
188 SCM_VALIDATE_STRING (1, name
);
189 sym
= scm_mem2uninterned_symbol (SCM_STRING_CHARS (name
),
190 SCM_STRING_LENGTH (name
));
191 scm_remember_upto_here_1 (name
);
196 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
198 "Return the name of @var{symbol} as a string. If the symbol was\n"
199 "part of an object returned as the value of a literal expression\n"
200 "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n"
201 "Report on Scheme}) or by a call to the @code{read} procedure,\n"
202 "and its name contains alphabetic characters, then the string\n"
203 "returned will contain characters in the implementation's\n"
204 "preferred standard case---some implementations will prefer\n"
205 "upper case, others lower case. If the symbol was returned by\n"
206 "@code{string->symbol}, the case of characters in the string\n"
207 "returned will be the same as the case in the string that was\n"
208 "passed to @code{string->symbol}. It is an error to apply\n"
209 "mutation procedures like @code{string-set!} to strings returned\n"
210 "by this procedure.\n"
212 "The following examples assume that the implementation's\n"
213 "standard case is lower case:\n"
216 "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n"
217 "(symbol->string 'Martin) @result{} \"martin\"\n"
219 " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
221 #define FUNC_NAME s_scm_symbol_to_string
224 SCM_VALIDATE_SYMBOL (1, s
);
225 str
= scm_mem2string (SCM_SYMBOL_CHARS (s
), SCM_SYMBOL_LENGTH (s
));
226 scm_remember_upto_here_1 (s
);
232 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
234 "Return the symbol whose name is @var{string}. This procedure\n"
235 "can create symbols with names containing special characters or\n"
236 "letters in the non-standard case, but it is usually a bad idea\n"
237 "to create such symbols because in some implementations of\n"
238 "Scheme they cannot be read as themselves. See\n"
239 "@code{symbol->string}.\n"
241 "The following examples assume that the implementation's\n"
242 "standard case is lower case:\n"
245 "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
246 "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
247 "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
249 " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
250 "(string=? \"K. Harper, M.D.\"\n"
252 " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
254 #define FUNC_NAME s_scm_string_to_symbol
257 SCM_VALIDATE_STRING (1, string
);
258 sym
= scm_mem2symbol (SCM_STRING_CHARS (string
),
259 SCM_STRING_LENGTH (string
));
260 scm_remember_upto_here_1 (string
);
265 #define MAX_PREFIX_LENGTH 30
267 static int gensym_counter
;
269 SCM_DEFINE (scm_gensym
, "gensym", 0, 1, 0,
271 "Create a new symbol with a name constructed from a prefix and\n"
272 "a counter value. The string @var{prefix} can be specified as\n"
273 "an optional argument. Default prefix is @code{ g}. The counter\n"
274 "is increased by 1 at each call. There is no provision for\n"
275 "resetting the counter.")
276 #define FUNC_NAME s_scm_gensym
278 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
281 if (SCM_UNBNDP (prefix
))
289 SCM_VALIDATE_STRING (1, prefix
);
290 len
= SCM_STRING_LENGTH (prefix
);
291 if (len
> MAX_PREFIX_LENGTH
)
292 name
= scm_malloc (len
+ SCM_INTBUFLEN
);
293 memcpy (name
, SCM_STRING_CHARS (prefix
), len
);
296 int n_digits
= scm_iint2str (gensym_counter
++, 10, &name
[len
]);
297 SCM res
= scm_mem2symbol (name
, len
+ n_digits
);
305 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
307 "Return a hash value for @var{symbol}.")
308 #define FUNC_NAME s_scm_symbol_hash
310 SCM_VALIDATE_SYMBOL (1, symbol
);
311 return scm_ulong2num (SCM_SYMBOL_HASH (symbol
));
315 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
317 "Return the contents of @var{symbol}'s @dfn{function slot}.")
318 #define FUNC_NAME s_scm_symbol_fref
320 SCM_VALIDATE_SYMBOL (1, s
);
321 return SCM_SYMBOL_FUNC (s
);
326 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
328 "Return the @dfn{property list} currently associated with @var{symbol}.")
329 #define FUNC_NAME s_scm_symbol_pref
331 SCM_VALIDATE_SYMBOL (1, s
);
332 return SCM_SYMBOL_PROPS (s
);
337 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
339 "Change the binding of @var{symbol}'s function slot.")
340 #define FUNC_NAME s_scm_symbol_fset_x
342 SCM_VALIDATE_SYMBOL (1, s
);
343 SCM_SET_SYMBOL_FUNC (s
, val
);
344 return SCM_UNSPECIFIED
;
349 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
351 "Change the binding of @var{symbol}'s property slot.")
352 #define FUNC_NAME s_scm_symbol_pset_x
354 SCM_VALIDATE_SYMBOL (1, s
);
356 SCM_SET_SYMBOL_PROPS (s
, val
);
358 return SCM_UNSPECIFIED
;
363 /* Converts the given Scheme symbol OBJ into a C string, containing a copy
364 of OBJ's content with a trailing null byte. If LENP is non-NULL, set
365 *LENP to the string's length.
367 When STR is non-NULL it receives the copy and is returned by the function,
368 otherwise new memory is allocated and the caller is responsible for
369 freeing it via free(). If out of memory, NULL is returned.
371 Note that Scheme symbols may contain arbitrary data, including null
372 characters. This means that null termination is not a reliable way to
373 determine the length of the returned value. However, the function always
374 copies the complete contents of OBJ, and sets *LENP to the length of the
375 scheme symbol (if LENP is non-null). */
376 #define FUNC_NAME "scm_c_symbol2str"
378 scm_c_symbol2str (SCM obj
, char *str
, size_t *lenp
)
382 SCM_ASSERT (SCM_SYMBOLP (obj
), obj
, SCM_ARG1
, FUNC_NAME
);
383 len
= SCM_SYMBOL_LENGTH (obj
);
387 /* FIXME: Should we use exported wrappers for malloc (and free), which
388 * allow windows DLLs to call the correct freeing function? */
389 str
= (char *) scm_malloc ((len
+ 1) * sizeof (char));
394 memcpy (str
, SCM_SYMBOL_CHARS (obj
), len
);
395 scm_remember_upto_here_1 (obj
);
407 scm_symbols_prehistory ()
409 symbols
= scm_make_weak_key_hash_table (SCM_MAKINUM (2139));
410 scm_permanent_object (symbols
);
418 #include "libguile/symbols.x"