Commit | Line | Data |
---|---|---|
2b829bbb | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 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 | |
92205699 | 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 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" |
1206efbe MV |
37 | #include "libguile/read.h" |
38 | #include "libguile/srfi-13.h" | |
a0599745 MD |
39 | |
40 | #include "libguile/validate.h" | |
41 | #include "libguile/symbols.h" | |
0f2d19dd | 42 | |
95b88819 GH |
43 | #ifdef HAVE_STRING_H |
44 | #include <string.h> | |
45 | #endif | |
46 | ||
0f2d19dd JB |
47 | \f |
48 | ||
0f979f3f DH |
49 | static SCM symbols; |
50 | ||
a4c91488 MD |
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 | ||
0f979f3f DH |
62 | \f |
63 | ||
0f2d19dd JB |
64 | /* {Symbols} |
65 | */ | |
66 | ||
c35738c1 MD |
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 | * | |
3ee86942 | 74 | * 2. We can use the raw hash value stored in scm_i_symbol_hash (sym) |
c35738c1 MD |
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 | { | |
3ee86942 | 84 | return scm_i_symbol_hash (obj) % n; |
c35738c1 | 85 | } |
1cc91f1b | 86 | |
3ee86942 | 87 | static SCM |
fd0a5bbc HWN |
88 | lookup_interned_symbol (const char *name, size_t len, |
89 | unsigned long raw_hash) | |
b52e071b | 90 | { |
fd0a5bbc HWN |
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 sym = SCM_CAAR (l); | |
100 | if (scm_i_symbol_hash (sym) == raw_hash | |
101 | && scm_i_symbol_length (sym) == len) | |
102 | { | |
103 | const char *chrs = scm_i_symbol_chars (sym); | |
104 | size_t i = len; | |
105 | ||
106 | while (i != 0) | |
107 | { | |
108 | --i; | |
109 | if (name[i] != chrs[i]) | |
110 | goto next_symbol; | |
111 | } | |
112 | ||
113 | return sym; | |
114 | } | |
115 | next_symbol: | |
116 | ; | |
117 | } | |
118 | ||
119 | return SCM_BOOL_F; | |
120 | } | |
3ee86942 | 121 | |
fd0a5bbc HWN |
122 | static SCM |
123 | scm_i_c_mem2symbol (const char *name, size_t len) | |
124 | { | |
125 | SCM symbol; | |
6869328b | 126 | size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); |
c35738c1 | 127 | size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols); |
b52e071b | 128 | |
fd0a5bbc HWN |
129 | symbol = lookup_interned_symbol (name, len, raw_hash); |
130 | if (symbol != SCM_BOOL_F) | |
131 | return symbol; | |
132 | ||
b52e071b | 133 | { |
fd0a5bbc HWN |
134 | /* The symbol was not found - create it. */ |
135 | SCM symbol = scm_i_c_make_symbol (name, len, 0, raw_hash, | |
136 | scm_cons (SCM_BOOL_F, SCM_EOL)); | |
137 | ||
138 | SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash); | |
139 | SCM cell = scm_cons (symbol, SCM_UNDEFINED); | |
140 | SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot)); | |
141 | SCM_HASHTABLE_INCREMENT (symbols); | |
142 | if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols)) | |
143 | scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol"); | |
144 | ||
145 | return symbol; | |
b52e071b | 146 | } |
fd0a5bbc HWN |
147 | } |
148 | ||
149 | static SCM | |
150 | scm_i_mem2symbol (SCM str) | |
151 | { | |
152 | SCM symbol; | |
153 | const char *name = scm_i_string_chars (str); | |
154 | size_t len = scm_i_string_length (str); | |
155 | size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); | |
156 | size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols); | |
157 | ||
158 | symbol = lookup_interned_symbol (name, len, raw_hash); | |
159 | if (symbol != SCM_BOOL_F) | |
160 | return symbol; | |
b52e071b DH |
161 | |
162 | { | |
163 | /* The symbol was not found - create it. */ | |
6869328b | 164 | SCM symbol = scm_i_make_symbol (str, 0, raw_hash, |
3ee86942 | 165 | scm_cons (SCM_BOOL_F, SCM_EOL)); |
b52e071b | 166 | |
4057a3e0 | 167 | SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash); |
c8a1bdc4 | 168 | SCM cell = scm_cons (symbol, SCM_UNDEFINED); |
c35738c1 MD |
169 | SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot)); |
170 | SCM_HASHTABLE_INCREMENT (symbols); | |
171 | if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols)) | |
172 | scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol"); | |
b52e071b DH |
173 | |
174 | return symbol; | |
175 | } | |
176 | } | |
177 | ||
fd0a5bbc | 178 | |
3ee86942 MV |
179 | static SCM |
180 | scm_i_mem2uninterned_symbol (SCM str) | |
ac48757b | 181 | { |
3ee86942 MV |
182 | const char *name = scm_i_string_chars (str); |
183 | size_t len = scm_i_string_length (str); | |
6869328b | 184 | size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); |
3ee86942 | 185 | |
6869328b MV |
186 | return scm_i_make_symbol (str, SCM_I_F_SYMBOL_UNINTERNED, |
187 | raw_hash, scm_cons (SCM_BOOL_F, SCM_EOL)); | |
b52e071b DH |
188 | } |
189 | ||
3b3b36dd | 190 | SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, |
8e93e199 | 191 | (SCM obj), |
1e6808ea MG |
192 | "Return @code{#t} if @var{obj} is a symbol, otherwise return\n" |
193 | "@code{#f}.") | |
1bbd0b84 | 194 | #define FUNC_NAME s_scm_symbol_p |
0f2d19dd | 195 | { |
3ee86942 | 196 | return scm_from_bool (scm_is_symbol (obj)); |
0f2d19dd | 197 | } |
1bbd0b84 | 198 | #undef FUNC_NAME |
0f2d19dd | 199 | |
ac48757b MV |
200 | SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0, |
201 | (SCM symbol), | |
202 | "Return @code{#t} if @var{symbol} is interned, otherwise return\n" | |
203 | "@code{#f}.") | |
204 | #define FUNC_NAME s_scm_symbol_interned_p | |
205 | { | |
206 | SCM_VALIDATE_SYMBOL (1, symbol); | |
3ee86942 | 207 | return scm_from_bool (scm_i_symbol_is_interned (symbol)); |
ac48757b MV |
208 | } |
209 | #undef FUNC_NAME | |
210 | ||
211 | SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, | |
212 | (SCM name), | |
213 | "Return a new uninterned symbol with the name @var{name}. " | |
214 | "The returned symbol is guaranteed to be unique and future " | |
d58d5bfc | 215 | "calls to @code{string->symbol} will not return it.") |
ac48757b MV |
216 | #define FUNC_NAME s_scm_make_symbol |
217 | { | |
ac48757b | 218 | SCM_VALIDATE_STRING (1, name); |
3ee86942 | 219 | return scm_i_mem2uninterned_symbol (name); |
ac48757b MV |
220 | } |
221 | #undef FUNC_NAME | |
222 | ||
3b3b36dd | 223 | SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, |
1bbd0b84 | 224 | (SCM s), |
1e6808ea MG |
225 | "Return the name of @var{symbol} as a string. If the symbol was\n" |
226 | "part of an object returned as the value of a literal expression\n" | |
7a095584 | 227 | "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n" |
1e6808ea MG |
228 | "Report on Scheme}) or by a call to the @code{read} procedure,\n" |
229 | "and its name contains alphabetic characters, then the string\n" | |
230 | "returned will contain characters in the implementation's\n" | |
231 | "preferred standard case---some implementations will prefer\n" | |
232 | "upper case, others lower case. If the symbol was returned by\n" | |
233 | "@code{string->symbol}, the case of characters in the string\n" | |
234 | "returned will be the same as the case in the string that was\n" | |
235 | "passed to @code{string->symbol}. It is an error to apply\n" | |
236 | "mutation procedures like @code{string-set!} to strings returned\n" | |
237 | "by this procedure.\n" | |
238 | "\n" | |
942e5b91 | 239 | "The following examples assume that the implementation's\n" |
1e6808ea MG |
240 | "standard case is lower case:\n" |
241 | "\n" | |
942e5b91 | 242 | "@lisp\n" |
1e6808ea MG |
243 | "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n" |
244 | "(symbol->string 'Martin) @result{} \"martin\"\n" | |
5ffe9968 | 245 | "(symbol->string\n" |
942e5b91 MG |
246 | " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n" |
247 | "@end lisp") | |
1bbd0b84 | 248 | #define FUNC_NAME s_scm_symbol_to_string |
0f2d19dd | 249 | { |
28b06554 | 250 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 251 | return scm_i_symbol_substring (s, 0, scm_i_symbol_length (s)); |
0f2d19dd | 252 | } |
1bbd0b84 | 253 | #undef FUNC_NAME |
0f2d19dd JB |
254 | |
255 | ||
3b3b36dd | 256 | SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, |
1e6808ea MG |
257 | (SCM string), |
258 | "Return the symbol whose name is @var{string}. This procedure\n" | |
942e5b91 MG |
259 | "can create symbols with names containing special characters or\n" |
260 | "letters in the non-standard case, but it is usually a bad idea\n" | |
1e6808ea MG |
261 | "to create such symbols because in some implementations of\n" |
262 | "Scheme they cannot be read as themselves. See\n" | |
263 | "@code{symbol->string}.\n" | |
264 | "\n" | |
942e5b91 | 265 | "The following examples assume that the implementation's\n" |
1e6808ea MG |
266 | "standard case is lower case:\n" |
267 | "\n" | |
942e5b91 MG |
268 | "@lisp\n" |
269 | "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n" | |
270 | "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n" | |
271 | "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n" | |
272 | "(eq? 'JollyWog\n" | |
273 | " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n" | |
274 | "(string=? \"K. Harper, M.D.\"\n" | |
275 | " (symbol->string\n" | |
276 | " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n" | |
277 | "@end lisp") | |
1bbd0b84 | 278 | #define FUNC_NAME s_scm_string_to_symbol |
0f2d19dd | 279 | { |
1e6808ea | 280 | SCM_VALIDATE_STRING (1, string); |
3ee86942 | 281 | return scm_i_mem2symbol (string); |
0f2d19dd | 282 | } |
1bbd0b84 | 283 | #undef FUNC_NAME |
0f2d19dd | 284 | |
1206efbe MV |
285 | SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, |
286 | (SCM str), | |
287 | "Return the symbol whose name is @var{str}. @var{str} is\n" | |
288 | "converted to lowercase before the conversion is done, if Guile\n" | |
289 | "is currently reading symbols case-insensitively.") | |
290 | #define FUNC_NAME s_scm_string_ci_to_symbol | |
291 | { | |
292 | return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P | |
293 | ? scm_string_downcase(str) | |
294 | : str); | |
295 | } | |
296 | #undef FUNC_NAME | |
297 | ||
86d31dfe | 298 | #define MAX_PREFIX_LENGTH 30 |
0f2d19dd | 299 | |
86d31dfe MV |
300 | SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, |
301 | (SCM prefix), | |
302 | "Create a new symbol with a name constructed from a prefix and\n" | |
303 | "a counter value. The string @var{prefix} can be specified as\n" | |
68dc153d | 304 | "an optional argument. Default prefix is @code{ g}. The counter\n" |
86d31dfe MV |
305 | "is increased by 1 at each call. There is no provision for\n" |
306 | "resetting the counter.") | |
307 | #define FUNC_NAME s_scm_gensym | |
0f2d19dd | 308 | { |
7426a638 | 309 | static int gensym_counter = 0; |
3ee86942 MV |
310 | |
311 | SCM suffix, name; | |
312 | int n, n_digits; | |
313 | char buf[SCM_INTBUFLEN]; | |
7426a638 | 314 | |
86d31dfe | 315 | if (SCM_UNBNDP (prefix)) |
3ee86942 MV |
316 | prefix = scm_from_locale_string (" g"); |
317 | ||
318 | /* mutex in case another thread looks and incs at the exact same moment */ | |
9de87eea | 319 | scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); |
3ee86942 | 320 | n = gensym_counter++; |
9de87eea | 321 | scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); |
3ee86942 MV |
322 | |
323 | n_digits = scm_iint2str (n, 10, buf); | |
324 | suffix = scm_from_locale_stringn (buf, n_digits); | |
325 | name = scm_string_append (scm_list_2 (prefix, suffix)); | |
326 | return scm_string_to_symbol (name); | |
0f2d19dd | 327 | } |
1bbd0b84 | 328 | #undef FUNC_NAME |
0f2d19dd | 329 | |
86d31dfe MV |
330 | SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, |
331 | (SCM symbol), | |
332 | "Return a hash value for @var{symbol}.") | |
333 | #define FUNC_NAME s_scm_symbol_hash | |
0f2d19dd | 334 | { |
86d31dfe | 335 | SCM_VALIDATE_SYMBOL (1, symbol); |
3ee86942 | 336 | return scm_from_ulong (scm_i_symbol_hash (symbol)); |
0f2d19dd | 337 | } |
1bbd0b84 | 338 | #undef FUNC_NAME |
0f2d19dd | 339 | |
3b3b36dd | 340 | SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, |
1bbd0b84 | 341 | (SCM s), |
b380b885 | 342 | "Return the contents of @var{symbol}'s @dfn{function slot}.") |
1bbd0b84 | 343 | #define FUNC_NAME s_scm_symbol_fref |
0f2d19dd | 344 | { |
34d19ef6 | 345 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 346 | return SCM_CAR (SCM_CELL_OBJECT_3 (s)); |
0f2d19dd | 347 | } |
1bbd0b84 | 348 | #undef FUNC_NAME |
0f2d19dd JB |
349 | |
350 | ||
3b3b36dd | 351 | SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, |
1bbd0b84 | 352 | (SCM s), |
b380b885 | 353 | "Return the @dfn{property list} currently associated with @var{symbol}.") |
1bbd0b84 | 354 | #define FUNC_NAME s_scm_symbol_pref |
0f2d19dd | 355 | { |
34d19ef6 | 356 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 357 | return SCM_CDR (SCM_CELL_OBJECT_3 (s)); |
0f2d19dd | 358 | } |
1bbd0b84 | 359 | #undef FUNC_NAME |
0f2d19dd JB |
360 | |
361 | ||
3b3b36dd | 362 | SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, |
1bbd0b84 | 363 | (SCM s, SCM val), |
b380b885 | 364 | "Change the binding of @var{symbol}'s function slot.") |
1bbd0b84 | 365 | #define FUNC_NAME s_scm_symbol_fset_x |
0f2d19dd | 366 | { |
34d19ef6 | 367 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 368 | SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val); |
0f2d19dd JB |
369 | return SCM_UNSPECIFIED; |
370 | } | |
1bbd0b84 | 371 | #undef FUNC_NAME |
0f2d19dd JB |
372 | |
373 | ||
3b3b36dd | 374 | SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, |
1bbd0b84 | 375 | (SCM s, SCM val), |
b380b885 | 376 | "Change the binding of @var{symbol}'s property slot.") |
1bbd0b84 | 377 | #define FUNC_NAME s_scm_symbol_pset_x |
0f2d19dd | 378 | { |
34d19ef6 | 379 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 380 | SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val); |
0f2d19dd JB |
381 | return SCM_UNSPECIFIED; |
382 | } | |
1bbd0b84 | 383 | #undef FUNC_NAME |
0f2d19dd | 384 | |
3ee86942 MV |
385 | SCM |
386 | scm_from_locale_symbol (const char *sym) | |
af68e5e5 | 387 | { |
fd0a5bbc | 388 | return scm_i_c_mem2symbol (sym, strlen (sym)); |
af68e5e5 | 389 | } |
af68e5e5 | 390 | |
3ee86942 MV |
391 | SCM |
392 | scm_from_locale_symboln (const char *sym, size_t len) | |
393 | { | |
fd0a5bbc HWN |
394 | return scm_i_c_mem2symbol (sym, len); |
395 | } | |
396 | ||
397 | SCM | |
398 | scm_take_locale_symboln (char *sym, size_t len) | |
399 | { | |
400 | SCM res; | |
401 | unsigned long raw_hash; | |
402 | ||
403 | if (len == (size_t)-1) | |
404 | len = strlen (sym); | |
405 | else | |
406 | { | |
407 | /* Ensure STR is null terminated. A realloc for 1 extra byte should | |
408 | often be satisfied from the alignment padding after the block, with | |
409 | no actual data movement. */ | |
410 | sym = scm_realloc (sym, len+1); | |
411 | sym[len] = '\0'; | |
412 | } | |
413 | ||
414 | raw_hash = scm_string_hash ((unsigned char *)sym, len); | |
415 | res = lookup_interned_symbol (sym, len, raw_hash); | |
416 | if (res != SCM_BOOL_F) | |
417 | { | |
418 | free (sym); | |
419 | return res; | |
420 | } | |
421 | ||
422 | res = scm_i_c_take_symbol (sym, len, 0, raw_hash, | |
423 | scm_cons (SCM_BOOL_F, SCM_EOL)); | |
424 | ||
425 | return res; | |
426 | } | |
427 | ||
428 | SCM | |
429 | scm_take_locale_symbol (char *sym) | |
430 | { | |
431 | return scm_take_locale_symboln (sym, (size_t)-1); | |
3ee86942 | 432 | } |
af68e5e5 | 433 | |
0f979f3f DH |
434 | void |
435 | scm_symbols_prehistory () | |
436 | { | |
e11e83f3 | 437 | symbols = scm_make_weak_key_hash_table (scm_from_int (2139)); |
0f979f3f DH |
438 | scm_permanent_object (symbols); |
439 | } | |
440 | ||
441 | ||
0f2d19dd JB |
442 | void |
443 | scm_init_symbols () | |
0f2d19dd | 444 | { |
a0599745 | 445 | #include "libguile/symbols.x" |
0f2d19dd | 446 | } |
89e00824 ML |
447 | |
448 | /* | |
449 | Local Variables: | |
450 | c-file-style: "gnu" | |
451 | End: | |
452 | */ |