Commit | Line | Data |
---|---|---|
c35738c1 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e MV |
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. | |
0f2d19dd | 7 | * |
73be1d9e MV |
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. | |
0f2d19dd | 12 | * |
73be1d9e MV |
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 | |
16 | */ | |
1bbd0b84 | 17 | |
1bbd0b84 | 18 | |
0f2d19dd | 19 | \f |
cf007485 RB |
20 | #if HAVE_CONFIG_H |
21 | # include <config.h> | |
22 | #endif | |
0f2d19dd | 23 | |
a0599745 MD |
24 | #include "libguile/_scm.h" |
25 | #include "libguile/chars.h" | |
26 | #include "libguile/eval.h" | |
ba393257 | 27 | #include "libguile/hash.h" |
fb43bf74 | 28 | #include "libguile/smob.h" |
a0599745 MD |
29 | #include "libguile/variable.h" |
30 | #include "libguile/alist.h" | |
7e73eaee | 31 | #include "libguile/fluids.h" |
a0599745 MD |
32 | #include "libguile/strings.h" |
33 | #include "libguile/vectors.h" | |
00ffa0e7 | 34 | #include "libguile/hashtab.h" |
a0599745 | 35 | #include "libguile/weaks.h" |
eb8db440 | 36 | #include "libguile/modules.h" |
a0599745 MD |
37 | |
38 | #include "libguile/validate.h" | |
39 | #include "libguile/symbols.h" | |
0f2d19dd | 40 | |
95b88819 GH |
41 | #ifdef HAVE_STRING_H |
42 | #include <string.h> | |
43 | #endif | |
44 | ||
0f2d19dd JB |
45 | \f |
46 | ||
0f979f3f DH |
47 | static SCM symbols; |
48 | ||
a4c91488 MD |
49 | #ifdef GUILE_DEBUG |
50 | SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, | |
51 | (), | |
52 | "Return the system symbol obarray.") | |
53 | #define FUNC_NAME s_scm_sys_symbols | |
54 | { | |
55 | return symbols; | |
56 | } | |
57 | #undef FUNC_NAME | |
58 | #endif | |
59 | ||
0f979f3f DH |
60 | \f |
61 | ||
0f2d19dd JB |
62 | /* {Symbols} |
63 | */ | |
64 | ||
c35738c1 MD |
65 | /* In order to optimize reading speed, this function breaks part of |
66 | * the hashtable abstraction. The optimizations are: | |
67 | * | |
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.) | |
71 | * | |
72 | * 2. We can use the raw hash value stored in SCM_SYMBOL_HASH (sym) | |
73 | * to speed up lookup. | |
74 | * | |
75 | * Both optimizations might be possible without breaking the | |
76 | * abstraction if the API in hashtab.c is improved. | |
77 | */ | |
78 | ||
79 | unsigned long | |
80 | scm_i_hash_symbol (SCM obj, unsigned long n, void *closure) | |
81 | { | |
82 | return SCM_SYMBOL_HASH (obj) % n; | |
83 | } | |
1cc91f1b | 84 | |
b52e071b | 85 | SCM |
1be6b49c | 86 | scm_mem2symbol (const char *name, size_t len) |
b52e071b | 87 | { |
c35738c1 MD |
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); | |
b52e071b DH |
90 | |
91 | { | |
0f979f3f | 92 | /* Try to find the symbol in the symbols table */ |
b52e071b DH |
93 | |
94 | SCM l; | |
95 | ||
c35738c1 MD |
96 | for (l = SCM_HASHTABLE_BUCKETS (symbols) [hash]; |
97 | !SCM_NULLP (l); | |
98 | l = SCM_CDR (l)) | |
b52e071b | 99 | { |
a7a59ea9 | 100 | SCM sym = SCM_CAAR (l); |
25c507d9 MV |
101 | if (SCM_SYMBOL_HASH (sym) == raw_hash |
102 | && SCM_SYMBOL_LENGTH (sym) == len) | |
b52e071b DH |
103 | { |
104 | char *chrs = SCM_SYMBOL_CHARS (sym); | |
1be6b49c | 105 | size_t i = len; |
b52e071b DH |
106 | |
107 | while (i != 0) | |
108 | { | |
109 | --i; | |
110 | if (name[i] != chrs[i]) | |
111 | goto next_symbol; | |
112 | } | |
113 | ||
114 | return sym; | |
115 | } | |
116 | next_symbol: | |
8d5a2737 | 117 | ; |
b52e071b DH |
118 | } |
119 | } | |
120 | ||
121 | { | |
122 | /* The symbol was not found - create it. */ | |
c8a1bdc4 | 123 | SCM symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len), |
228a24ef DH |
124 | (scm_t_bits) scm_gc_strndup (name, len, |
125 | "symbol"), | |
126 | raw_hash, | |
127 | SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL))); | |
b52e071b | 128 | |
c35738c1 | 129 | SCM slot = SCM_HASHTABLE_BUCKETS (symbols) [hash]; |
c8a1bdc4 | 130 | SCM cell = scm_cons (symbol, SCM_UNDEFINED); |
c35738c1 MD |
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"); | |
b52e071b DH |
135 | |
136 | return symbol; | |
137 | } | |
138 | } | |
139 | ||
ac48757b MV |
140 | SCM |
141 | scm_mem2uninterned_symbol (const char *name, size_t len) | |
142 | { | |
143 | size_t raw_hash = (scm_string_hash ((const unsigned char *) name, len)/2 | |
144 | + SCM_T_BITS_MAX/2 + 1); | |
145 | ||
228a24ef DH |
146 | return scm_double_cell (SCM_MAKE_SYMBOL_TAG (len), |
147 | (scm_t_bits) scm_gc_strndup (name, len, | |
148 | "symbol"), | |
149 | raw_hash, | |
150 | SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL))); | |
ac48757b MV |
151 | } |
152 | ||
b52e071b DH |
153 | SCM |
154 | scm_str2symbol (const char *str) | |
155 | { | |
156 | return scm_mem2symbol (str, strlen (str)); | |
157 | } | |
158 | ||
3b3b36dd | 159 | SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, |
8e93e199 | 160 | (SCM obj), |
1e6808ea MG |
161 | "Return @code{#t} if @var{obj} is a symbol, otherwise return\n" |
162 | "@code{#f}.") | |
1bbd0b84 | 163 | #define FUNC_NAME s_scm_symbol_p |
0f2d19dd | 164 | { |
7888309b | 165 | return scm_from_bool (SCM_SYMBOLP (obj)); |
0f2d19dd | 166 | } |
1bbd0b84 | 167 | #undef FUNC_NAME |
0f2d19dd | 168 | |
ac48757b MV |
169 | SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0, |
170 | (SCM symbol), | |
171 | "Return @code{#t} if @var{symbol} is interned, otherwise return\n" | |
172 | "@code{#f}.") | |
173 | #define FUNC_NAME s_scm_symbol_interned_p | |
174 | { | |
175 | SCM_VALIDATE_SYMBOL (1, symbol); | |
7888309b | 176 | return scm_from_bool (SCM_SYMBOL_INTERNED_P (symbol)); |
ac48757b MV |
177 | } |
178 | #undef FUNC_NAME | |
179 | ||
180 | SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, | |
181 | (SCM name), | |
182 | "Return a new uninterned symbol with the name @var{name}. " | |
183 | "The returned symbol is guaranteed to be unique and future " | |
d58d5bfc | 184 | "calls to @code{string->symbol} will not return it.") |
ac48757b MV |
185 | #define FUNC_NAME s_scm_make_symbol |
186 | { | |
187 | SCM sym; | |
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); | |
192 | return sym; | |
193 | } | |
194 | #undef FUNC_NAME | |
195 | ||
3b3b36dd | 196 | SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, |
1bbd0b84 | 197 | (SCM s), |
1e6808ea MG |
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" | |
7a095584 | 200 | "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n" |
1e6808ea MG |
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" | |
211 | "\n" | |
942e5b91 | 212 | "The following examples assume that the implementation's\n" |
1e6808ea MG |
213 | "standard case is lower case:\n" |
214 | "\n" | |
942e5b91 | 215 | "@lisp\n" |
1e6808ea MG |
216 | "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n" |
217 | "(symbol->string 'Martin) @result{} \"martin\"\n" | |
5ffe9968 | 218 | "(symbol->string\n" |
942e5b91 MG |
219 | " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n" |
220 | "@end lisp") | |
1bbd0b84 | 221 | #define FUNC_NAME s_scm_symbol_to_string |
0f2d19dd | 222 | { |
36284627 | 223 | SCM str; |
28b06554 | 224 | SCM_VALIDATE_SYMBOL (1, s); |
36284627 DH |
225 | str = scm_mem2string (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s)); |
226 | scm_remember_upto_here_1 (s); | |
227 | return str; | |
0f2d19dd | 228 | } |
1bbd0b84 | 229 | #undef FUNC_NAME |
0f2d19dd JB |
230 | |
231 | ||
3b3b36dd | 232 | SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, |
1e6808ea MG |
233 | (SCM string), |
234 | "Return the symbol whose name is @var{string}. This procedure\n" | |
942e5b91 MG |
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" | |
1e6808ea MG |
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" | |
240 | "\n" | |
942e5b91 | 241 | "The following examples assume that the implementation's\n" |
1e6808ea MG |
242 | "standard case is lower case:\n" |
243 | "\n" | |
942e5b91 MG |
244 | "@lisp\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" | |
248 | "(eq? 'JollyWog\n" | |
249 | " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n" | |
250 | "(string=? \"K. Harper, M.D.\"\n" | |
251 | " (symbol->string\n" | |
252 | " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n" | |
253 | "@end lisp") | |
1bbd0b84 | 254 | #define FUNC_NAME s_scm_string_to_symbol |
0f2d19dd | 255 | { |
68dc153d | 256 | SCM sym; |
1e6808ea | 257 | SCM_VALIDATE_STRING (1, string); |
68dc153d MV |
258 | sym = scm_mem2symbol (SCM_STRING_CHARS (string), |
259 | SCM_STRING_LENGTH (string)); | |
260 | scm_remember_upto_here_1 (string); | |
261 | return sym; | |
0f2d19dd | 262 | } |
1bbd0b84 | 263 | #undef FUNC_NAME |
0f2d19dd | 264 | |
86d31dfe | 265 | #define MAX_PREFIX_LENGTH 30 |
0f2d19dd | 266 | |
86d31dfe | 267 | static int gensym_counter; |
0f2d19dd | 268 | |
86d31dfe MV |
269 | SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, |
270 | (SCM prefix), | |
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" | |
68dc153d | 273 | "an optional argument. Default prefix is @code{ g}. The counter\n" |
86d31dfe MV |
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 | |
0f2d19dd | 277 | { |
86d31dfe MV |
278 | char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; |
279 | char *name = buf; | |
1be6b49c | 280 | size_t len; |
86d31dfe MV |
281 | if (SCM_UNBNDP (prefix)) |
282 | { | |
68dc153d MV |
283 | name[0] = ' '; |
284 | name[1] = 'g'; | |
285 | len = 2; | |
86d31dfe MV |
286 | } |
287 | else | |
288 | { | |
289 | SCM_VALIDATE_STRING (1, prefix); | |
290 | len = SCM_STRING_LENGTH (prefix); | |
291 | if (len > MAX_PREFIX_LENGTH) | |
4c9419ac | 292 | name = scm_malloc (len + SCM_INTBUFLEN); |
8d09eb04 | 293 | memcpy (name, SCM_STRING_CHARS (prefix), len); |
86d31dfe | 294 | } |
49bc24fe | 295 | { |
86d31dfe MV |
296 | int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); |
297 | SCM res = scm_mem2symbol (name, len + n_digits); | |
298 | if (name != buf) | |
4c9419ac | 299 | free (name); |
86d31dfe | 300 | return res; |
49bc24fe | 301 | } |
0f2d19dd | 302 | } |
1bbd0b84 | 303 | #undef FUNC_NAME |
0f2d19dd | 304 | |
86d31dfe MV |
305 | SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, |
306 | (SCM symbol), | |
307 | "Return a hash value for @var{symbol}.") | |
308 | #define FUNC_NAME s_scm_symbol_hash | |
0f2d19dd | 309 | { |
86d31dfe | 310 | SCM_VALIDATE_SYMBOL (1, symbol); |
ac48757b | 311 | return scm_ulong2num (SCM_SYMBOL_HASH (symbol)); |
0f2d19dd | 312 | } |
1bbd0b84 | 313 | #undef FUNC_NAME |
0f2d19dd | 314 | |
3b3b36dd | 315 | SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, |
1bbd0b84 | 316 | (SCM s), |
b380b885 | 317 | "Return the contents of @var{symbol}'s @dfn{function slot}.") |
1bbd0b84 | 318 | #define FUNC_NAME s_scm_symbol_fref |
0f2d19dd | 319 | { |
34d19ef6 | 320 | SCM_VALIDATE_SYMBOL (1, s); |
0f2d19dd JB |
321 | return SCM_SYMBOL_FUNC (s); |
322 | } | |
1bbd0b84 | 323 | #undef FUNC_NAME |
0f2d19dd JB |
324 | |
325 | ||
3b3b36dd | 326 | SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, |
1bbd0b84 | 327 | (SCM s), |
b380b885 | 328 | "Return the @dfn{property list} currently associated with @var{symbol}.") |
1bbd0b84 | 329 | #define FUNC_NAME s_scm_symbol_pref |
0f2d19dd | 330 | { |
34d19ef6 | 331 | SCM_VALIDATE_SYMBOL (1, s); |
0f2d19dd JB |
332 | return SCM_SYMBOL_PROPS (s); |
333 | } | |
1bbd0b84 | 334 | #undef FUNC_NAME |
0f2d19dd JB |
335 | |
336 | ||
3b3b36dd | 337 | SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, |
1bbd0b84 | 338 | (SCM s, SCM val), |
b380b885 | 339 | "Change the binding of @var{symbol}'s function slot.") |
1bbd0b84 | 340 | #define FUNC_NAME s_scm_symbol_fset_x |
0f2d19dd | 341 | { |
34d19ef6 | 342 | SCM_VALIDATE_SYMBOL (1, s); |
cf551a2b | 343 | SCM_SET_SYMBOL_FUNC (s, val); |
0f2d19dd JB |
344 | return SCM_UNSPECIFIED; |
345 | } | |
1bbd0b84 | 346 | #undef FUNC_NAME |
0f2d19dd JB |
347 | |
348 | ||
3b3b36dd | 349 | SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, |
1bbd0b84 | 350 | (SCM s, SCM val), |
b380b885 | 351 | "Change the binding of @var{symbol}'s property slot.") |
1bbd0b84 | 352 | #define FUNC_NAME s_scm_symbol_pset_x |
0f2d19dd | 353 | { |
34d19ef6 | 354 | SCM_VALIDATE_SYMBOL (1, s); |
0f2d19dd | 355 | SCM_DEFER_INTS; |
cf551a2b | 356 | SCM_SET_SYMBOL_PROPS (s, val); |
0f2d19dd JB |
357 | SCM_ALLOW_INTS; |
358 | return SCM_UNSPECIFIED; | |
359 | } | |
1bbd0b84 | 360 | #undef FUNC_NAME |
0f2d19dd | 361 | |
af68e5e5 SJ |
362 | |
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. | |
366 | ||
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. | |
370 | ||
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" | |
377 | char * | |
378 | scm_c_symbol2str (SCM obj, char *str, size_t *lenp) | |
379 | { | |
380 | size_t len; | |
381 | ||
382 | SCM_ASSERT (SCM_SYMBOLP (obj), obj, SCM_ARG1, FUNC_NAME); | |
383 | len = SCM_SYMBOL_LENGTH (obj); | |
384 | ||
385 | if (str == NULL) | |
386 | { | |
387 | /* FIXME: Should we use exported wrappers for malloc (and free), which | |
388 | * allow windows DLLs to call the correct freeing function? */ | |
67329a9e | 389 | str = (char *) scm_malloc ((len + 1) * sizeof (char)); |
af68e5e5 SJ |
390 | if (str == NULL) |
391 | return NULL; | |
392 | } | |
393 | ||
394 | memcpy (str, SCM_SYMBOL_CHARS (obj), len); | |
395 | scm_remember_upto_here_1 (obj); | |
396 | str[len] = '\0'; | |
397 | ||
398 | if (lenp != NULL) | |
399 | *lenp = len; | |
400 | ||
401 | return str; | |
402 | } | |
403 | #undef FUNC_NAME | |
404 | ||
405 | ||
0f979f3f DH |
406 | void |
407 | scm_symbols_prehistory () | |
408 | { | |
e11e83f3 | 409 | symbols = scm_make_weak_key_hash_table (scm_from_int (2139)); |
0f979f3f DH |
410 | scm_permanent_object (symbols); |
411 | } | |
412 | ||
413 | ||
0f2d19dd JB |
414 | void |
415 | scm_init_symbols () | |
0f2d19dd | 416 | { |
1ff4df7a | 417 | gensym_counter = 0; |
a0599745 | 418 | #include "libguile/symbols.x" |
0f2d19dd | 419 | } |
89e00824 ML |
420 | |
421 | /* | |
422 | Local Variables: | |
423 | c-file-style: "gnu" | |
424 | End: | |
425 | */ |