Commit | Line | Data |
---|---|---|
ceed7709 | 1 | /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, |
8c76a897 | 2 | * 2006, 2009, 2011, 2013 Free Software Foundation, Inc. |
ceed7709 | 3 | * |
73be1d9e | 4 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
5 | * modify it under the terms of the GNU Lesser General Public License |
6 | * as published by the Free Software Foundation; either version 3 of | |
7 | * the License, or (at your option) any later version. | |
0f2d19dd | 8 | * |
53befeb7 NJ |
9 | * This library is distributed in the hope that it will be useful, but |
10 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | * Lesser General Public License for more details. | |
0f2d19dd | 13 | * |
73be1d9e MV |
14 | * You should have received a copy of the GNU Lesser General Public |
15 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
17 | * 02110-1301 USA | |
73be1d9e | 18 | */ |
1bbd0b84 | 19 | |
1bbd0b84 | 20 | |
0f2d19dd | 21 | \f |
dbb605f5 | 22 | #ifdef HAVE_CONFIG_H |
cf007485 RB |
23 | # include <config.h> |
24 | #endif | |
0f2d19dd | 25 | |
f80d15c5 AW |
26 | #include <unistr.h> |
27 | ||
a0599745 MD |
28 | #include "libguile/_scm.h" |
29 | #include "libguile/chars.h" | |
30 | #include "libguile/eval.h" | |
ba393257 | 31 | #include "libguile/hash.h" |
fb43bf74 | 32 | #include "libguile/smob.h" |
a0599745 MD |
33 | #include "libguile/variable.h" |
34 | #include "libguile/alist.h" | |
7e73eaee | 35 | #include "libguile/fluids.h" |
a0599745 MD |
36 | #include "libguile/strings.h" |
37 | #include "libguile/vectors.h" | |
7887be7d | 38 | #include "libguile/weak-set.h" |
eb8db440 | 39 | #include "libguile/modules.h" |
1206efbe MV |
40 | #include "libguile/read.h" |
41 | #include "libguile/srfi-13.h" | |
a0599745 MD |
42 | |
43 | #include "libguile/validate.h" | |
44 | #include "libguile/symbols.h" | |
0f2d19dd | 45 | |
22fc179a HWN |
46 | #include "libguile/private-options.h" |
47 | ||
48 | ||
95b88819 GH |
49 | #ifdef HAVE_STRING_H |
50 | #include <string.h> | |
51 | #endif | |
52 | ||
0f2d19dd JB |
53 | \f |
54 | ||
0f979f3f DH |
55 | static SCM symbols; |
56 | ||
a4c91488 MD |
57 | #ifdef GUILE_DEBUG |
58 | SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, | |
59 | (), | |
60 | "Return the system symbol obarray.") | |
61 | #define FUNC_NAME s_scm_sys_symbols | |
62 | { | |
63 | return symbols; | |
64 | } | |
65 | #undef FUNC_NAME | |
66 | #endif | |
67 | ||
0f979f3f DH |
68 | \f |
69 | ||
0f2d19dd JB |
70 | /* {Symbols} |
71 | */ | |
72 | ||
c35738c1 MD |
73 | unsigned long |
74 | scm_i_hash_symbol (SCM obj, unsigned long n, void *closure) | |
75 | { | |
3ee86942 | 76 | return scm_i_symbol_hash (obj) % n; |
c35738c1 | 77 | } |
1cc91f1b | 78 | |
e0c83bf5 AW |
79 | struct string_lookup_data |
80 | { | |
17072fd2 | 81 | SCM string; |
e0c83bf5 AW |
82 | unsigned long string_hash; |
83 | }; | |
84 | ||
17072fd2 AW |
85 | static int |
86 | string_lookup_predicate_fn (SCM sym, void *closure) | |
e0c83bf5 AW |
87 | { |
88 | struct string_lookup_data *data = closure; | |
89 | ||
17072fd2 AW |
90 | if (scm_i_symbol_hash (sym) == data->string_hash |
91 | && scm_i_symbol_length (sym) == scm_i_string_length (data->string)) | |
fd0a5bbc | 92 | { |
17072fd2 AW |
93 | size_t n = scm_i_symbol_length (sym); |
94 | while (n--) | |
95 | if (scm_i_symbol_ref (sym, n) != scm_i_string_ref (data->string, n)) | |
96 | return 0; | |
97 | return 1; | |
fd0a5bbc | 98 | } |
17072fd2 AW |
99 | else |
100 | return 0; | |
e0c83bf5 | 101 | } |
488b10b5 | 102 | |
e0c83bf5 | 103 | static SCM |
293670e8 | 104 | lookup_interned_symbol (SCM name, unsigned long raw_hash, SCM obarray) |
e0c83bf5 AW |
105 | { |
106 | struct string_lookup_data data; | |
e0c83bf5 | 107 | |
17072fd2 | 108 | data.string = name; |
e0c83bf5 AW |
109 | data.string_hash = raw_hash; |
110 | ||
293670e8 | 111 | return scm_c_weak_set_lookup (obarray, raw_hash, |
7887be7d AW |
112 | string_lookup_predicate_fn, |
113 | &data, SCM_BOOL_F); | |
fd0a5bbc | 114 | } |
3ee86942 | 115 | |
30c282bf AW |
116 | struct latin1_lookup_data |
117 | { | |
118 | const char *str; | |
119 | size_t len; | |
120 | unsigned long string_hash; | |
121 | }; | |
122 | ||
123 | static int | |
124 | latin1_lookup_predicate_fn (SCM sym, void *closure) | |
125 | { | |
126 | struct latin1_lookup_data *data = closure; | |
127 | ||
128 | return scm_i_symbol_hash (sym) == data->string_hash | |
129 | && scm_i_is_narrow_symbol (sym) | |
130 | && scm_i_symbol_length (sym) == data->len | |
131 | && strncmp (scm_i_symbol_chars (sym), data->str, data->len) == 0; | |
132 | } | |
133 | ||
134 | static SCM | |
135 | lookup_interned_latin1_symbol (const char *str, size_t len, | |
293670e8 BT |
136 | unsigned long raw_hash, |
137 | SCM obarray) | |
30c282bf AW |
138 | { |
139 | struct latin1_lookup_data data; | |
30c282bf AW |
140 | |
141 | data.str = str; | |
142 | data.len = len; | |
143 | data.string_hash = raw_hash; | |
144 | ||
293670e8 | 145 | return scm_c_weak_set_lookup (obarray, raw_hash, |
7887be7d AW |
146 | latin1_lookup_predicate_fn, |
147 | &data, SCM_BOOL_F); | |
30c282bf AW |
148 | } |
149 | ||
f80d15c5 AW |
150 | struct utf8_lookup_data |
151 | { | |
152 | const char *str; | |
153 | size_t len; | |
154 | unsigned long string_hash; | |
155 | }; | |
156 | ||
157 | static int | |
158 | utf8_string_equals_wide_string (const scm_t_uint8 *narrow, size_t nlen, | |
159 | const scm_t_wchar *wide, size_t wlen) | |
160 | { | |
161 | size_t byte_idx = 0, char_idx = 0; | |
162 | ||
163 | while (byte_idx < nlen && char_idx < wlen) | |
164 | { | |
165 | ucs4_t c; | |
166 | int nbytes; | |
167 | ||
168 | nbytes = u8_mbtouc (&c, narrow + byte_idx, nlen - byte_idx); | |
169 | if (nbytes == 0) | |
170 | break; | |
8c76a897 | 171 | else if (c == 0xfffd) |
f80d15c5 AW |
172 | /* Bad UTF-8. */ |
173 | return 0; | |
174 | else if (c != wide[char_idx]) | |
175 | return 0; | |
176 | ||
177 | byte_idx += nbytes; | |
178 | char_idx++; | |
179 | } | |
180 | ||
181 | return byte_idx == nlen && char_idx == wlen; | |
182 | } | |
183 | ||
184 | static int | |
185 | utf8_lookup_predicate_fn (SCM sym, void *closure) | |
186 | { | |
187 | struct utf8_lookup_data *data = closure; | |
188 | ||
189 | if (scm_i_symbol_hash (sym) != data->string_hash) | |
190 | return 0; | |
191 | ||
192 | if (scm_i_is_narrow_symbol (sym)) | |
193 | return (scm_i_symbol_length (sym) == data->len | |
194 | && strncmp (scm_i_symbol_chars (sym), data->str, data->len) == 0); | |
195 | else | |
196 | return utf8_string_equals_wide_string ((const scm_t_uint8 *) data->str, | |
197 | data->len, | |
198 | scm_i_symbol_wide_chars (sym), | |
199 | scm_i_symbol_length (sym)); | |
200 | } | |
201 | ||
202 | static SCM | |
203 | lookup_interned_utf8_symbol (const char *str, size_t len, | |
293670e8 BT |
204 | unsigned long raw_hash, |
205 | SCM obarray) | |
f80d15c5 AW |
206 | { |
207 | struct utf8_lookup_data data; | |
208 | ||
209 | data.str = str; | |
210 | data.len = len; | |
211 | data.string_hash = raw_hash; | |
212 | ||
293670e8 | 213 | return scm_c_weak_set_lookup (obarray, raw_hash, |
f80d15c5 AW |
214 | utf8_lookup_predicate_fn, |
215 | &data, SCM_BOOL_F); | |
216 | } | |
217 | ||
7887be7d AW |
218 | static int |
219 | symbol_lookup_predicate_fn (SCM sym, void *closure) | |
e0c83bf5 | 220 | { |
21041372 | 221 | SCM other = SCM_PACK_POINTER (closure); |
e0c83bf5 | 222 | |
7887be7d AW |
223 | if (scm_i_symbol_hash (sym) == scm_i_symbol_hash (other) |
224 | && scm_i_symbol_length (sym) == scm_i_symbol_length (other)) | |
e0c83bf5 | 225 | { |
7887be7d AW |
226 | if (scm_i_is_narrow_symbol (sym)) |
227 | return scm_i_is_narrow_symbol (other) | |
228 | && (strncmp (scm_i_symbol_chars (sym), | |
229 | scm_i_symbol_chars (other), | |
230 | scm_i_symbol_length (other)) == 0); | |
231 | else | |
232 | return scm_is_true | |
233 | (scm_string_equal_p (scm_symbol_to_string (sym), | |
234 | scm_symbol_to_string (other))); | |
e0c83bf5 | 235 | } |
7887be7d | 236 | return 0; |
e0c83bf5 | 237 | } |
7887be7d | 238 | |
fd0a5bbc | 239 | static SCM |
293670e8 | 240 | scm_i_str2symbol (SCM str, SCM obarray) |
fd0a5bbc HWN |
241 | { |
242 | SCM symbol; | |
e23106d5 | 243 | size_t raw_hash = scm_i_string_hash (str); |
b52e071b | 244 | |
293670e8 | 245 | symbol = lookup_interned_symbol (str, raw_hash, obarray); |
e0c83bf5 AW |
246 | if (scm_is_true (symbol)) |
247 | return symbol; | |
248 | else | |
05588a1a LC |
249 | { |
250 | /* The symbol was not found, create it. */ | |
251 | symbol = scm_i_make_symbol (str, 0, raw_hash, | |
252 | scm_cons (SCM_BOOL_F, SCM_EOL)); | |
7887be7d AW |
253 | |
254 | /* Might return a different symbol, if another one was interned at | |
255 | the same time. */ | |
293670e8 | 256 | return scm_c_weak_set_add_x (obarray, raw_hash, |
7887be7d | 257 | symbol_lookup_predicate_fn, |
21041372 | 258 | SCM_UNPACK_POINTER (symbol), symbol); |
05588a1a | 259 | } |
b52e071b DH |
260 | } |
261 | ||
fd0a5bbc | 262 | |
3ee86942 | 263 | static SCM |
e23106d5 | 264 | scm_i_str2uninterned_symbol (SCM str) |
ac48757b | 265 | { |
e23106d5 | 266 | size_t raw_hash = scm_i_string_hash (str); |
3ee86942 | 267 | |
6869328b MV |
268 | return scm_i_make_symbol (str, SCM_I_F_SYMBOL_UNINTERNED, |
269 | raw_hash, scm_cons (SCM_BOOL_F, SCM_EOL)); | |
b52e071b DH |
270 | } |
271 | ||
3b3b36dd | 272 | SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, |
8e93e199 | 273 | (SCM obj), |
1e6808ea MG |
274 | "Return @code{#t} if @var{obj} is a symbol, otherwise return\n" |
275 | "@code{#f}.") | |
1bbd0b84 | 276 | #define FUNC_NAME s_scm_symbol_p |
0f2d19dd | 277 | { |
3ee86942 | 278 | return scm_from_bool (scm_is_symbol (obj)); |
0f2d19dd | 279 | } |
1bbd0b84 | 280 | #undef FUNC_NAME |
0f2d19dd | 281 | |
ac48757b MV |
282 | SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0, |
283 | (SCM symbol), | |
284 | "Return @code{#t} if @var{symbol} is interned, otherwise return\n" | |
285 | "@code{#f}.") | |
286 | #define FUNC_NAME s_scm_symbol_interned_p | |
287 | { | |
288 | SCM_VALIDATE_SYMBOL (1, symbol); | |
3ee86942 | 289 | return scm_from_bool (scm_i_symbol_is_interned (symbol)); |
ac48757b MV |
290 | } |
291 | #undef FUNC_NAME | |
292 | ||
293 | SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, | |
294 | (SCM name), | |
295 | "Return a new uninterned symbol with the name @var{name}. " | |
296 | "The returned symbol is guaranteed to be unique and future " | |
d58d5bfc | 297 | "calls to @code{string->symbol} will not return it.") |
ac48757b MV |
298 | #define FUNC_NAME s_scm_make_symbol |
299 | { | |
ac48757b | 300 | SCM_VALIDATE_STRING (1, name); |
e23106d5 | 301 | return scm_i_str2uninterned_symbol (name); |
ac48757b MV |
302 | } |
303 | #undef FUNC_NAME | |
304 | ||
3b3b36dd | 305 | SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, |
1bbd0b84 | 306 | (SCM s), |
1e6808ea MG |
307 | "Return the name of @var{symbol} as a string. If the symbol was\n" |
308 | "part of an object returned as the value of a literal expression\n" | |
7a095584 | 309 | "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n" |
1e6808ea MG |
310 | "Report on Scheme}) or by a call to the @code{read} procedure,\n" |
311 | "and its name contains alphabetic characters, then the string\n" | |
312 | "returned will contain characters in the implementation's\n" | |
313 | "preferred standard case---some implementations will prefer\n" | |
314 | "upper case, others lower case. If the symbol was returned by\n" | |
315 | "@code{string->symbol}, the case of characters in the string\n" | |
316 | "returned will be the same as the case in the string that was\n" | |
317 | "passed to @code{string->symbol}. It is an error to apply\n" | |
318 | "mutation procedures like @code{string-set!} to strings returned\n" | |
319 | "by this procedure.\n" | |
320 | "\n" | |
942e5b91 | 321 | "The following examples assume that the implementation's\n" |
1e6808ea MG |
322 | "standard case is lower case:\n" |
323 | "\n" | |
942e5b91 | 324 | "@lisp\n" |
1e6808ea MG |
325 | "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n" |
326 | "(symbol->string 'Martin) @result{} \"martin\"\n" | |
5ffe9968 | 327 | "(symbol->string\n" |
942e5b91 MG |
328 | " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n" |
329 | "@end lisp") | |
1bbd0b84 | 330 | #define FUNC_NAME s_scm_symbol_to_string |
0f2d19dd | 331 | { |
28b06554 | 332 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 333 | return scm_i_symbol_substring (s, 0, scm_i_symbol_length (s)); |
0f2d19dd | 334 | } |
1bbd0b84 | 335 | #undef FUNC_NAME |
0f2d19dd JB |
336 | |
337 | ||
3b3b36dd | 338 | SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, |
1e6808ea MG |
339 | (SCM string), |
340 | "Return the symbol whose name is @var{string}. This procedure\n" | |
942e5b91 MG |
341 | "can create symbols with names containing special characters or\n" |
342 | "letters in the non-standard case, but it is usually a bad idea\n" | |
1e6808ea MG |
343 | "to create such symbols because in some implementations of\n" |
344 | "Scheme they cannot be read as themselves. See\n" | |
345 | "@code{symbol->string}.\n" | |
346 | "\n" | |
942e5b91 | 347 | "The following examples assume that the implementation's\n" |
1e6808ea MG |
348 | "standard case is lower case:\n" |
349 | "\n" | |
942e5b91 MG |
350 | "@lisp\n" |
351 | "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n" | |
352 | "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n" | |
353 | "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n" | |
354 | "(eq? 'JollyWog\n" | |
355 | " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n" | |
356 | "(string=? \"K. Harper, M.D.\"\n" | |
357 | " (symbol->string\n" | |
358 | " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n" | |
359 | "@end lisp") | |
1bbd0b84 | 360 | #define FUNC_NAME s_scm_string_to_symbol |
0f2d19dd | 361 | { |
1e6808ea | 362 | SCM_VALIDATE_STRING (1, string); |
293670e8 | 363 | return scm_i_str2symbol (string, symbols); |
0f2d19dd | 364 | } |
1bbd0b84 | 365 | #undef FUNC_NAME |
0f2d19dd | 366 | |
1206efbe MV |
367 | SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, |
368 | (SCM str), | |
369 | "Return the symbol whose name is @var{str}. @var{str} is\n" | |
370 | "converted to lowercase before the conversion is done, if Guile\n" | |
371 | "is currently reading symbols case-insensitively.") | |
372 | #define FUNC_NAME s_scm_string_ci_to_symbol | |
373 | { | |
374 | return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P | |
375 | ? scm_string_downcase(str) | |
376 | : str); | |
377 | } | |
378 | #undef FUNC_NAME | |
379 | ||
293670e8 BT |
380 | SCM_DEFINE (scm_make_obarray, "make-obarray", 0, 0, 0, |
381 | (void), | |
382 | "Return a fresh obarray.") | |
383 | #define FUNC_NAME s_scm_make_obarray | |
384 | { | |
385 | return scm_c_make_weak_set (0); | |
386 | } | |
387 | #undef FUNC_NAME | |
388 | ||
389 | SCM_DEFINE (scm_find_symbol, "find-symbol", 1, 1, 0, | |
390 | (SCM string, SCM obarray), | |
391 | "Return the symbol named @var{string} if it is present in\n" | |
392 | "@var{obarray}. Return false otherwise.") | |
393 | #define FUNC_NAME s_scm_find_symbol | |
394 | { | |
395 | if (SCM_UNBNDP (obarray)) | |
396 | obarray = symbols; | |
397 | ||
398 | return lookup_interned_symbol (string, | |
399 | scm_i_string_hash (string), | |
400 | obarray); | |
401 | } | |
402 | #undef FUNC_NAME | |
403 | ||
404 | SCM_DEFINE (scm_intern, "intern", 1, 1, 0, | |
405 | (SCM string, SCM obarray), | |
406 | "Intern @var{string} in @var{obarray}.") | |
407 | #define FUNC_NAME s_scm_intern | |
408 | { | |
409 | if (SCM_UNBNDP (obarray)) | |
410 | obarray = symbols; | |
411 | ||
412 | SCM_VALIDATE_STRING (1, string); | |
413 | return scm_i_str2symbol (string, obarray); | |
414 | } | |
415 | #undef FUNC_NAME | |
416 | ||
417 | SCM_DEFINE (scm_unintern, "unintern", 1, 1, 0, | |
418 | (SCM symbol, SCM obarray), | |
419 | "Unintern @var{symbol} from @var{obarray}.") | |
420 | #define FUNC_NAME s_scm_unintern | |
421 | { | |
422 | if (SCM_UNBNDP (obarray)) | |
423 | obarray = symbols; | |
424 | ||
425 | scm_weak_set_remove_x (obarray, symbol); | |
426 | return SCM_UNSPECIFIED; | |
427 | } | |
428 | #undef FUNC_NAME | |
429 | ||
430 | SCM_DEFINE (scm_obarray_for_each, "obarray-for-each", 1, 1, 0, | |
431 | (SCM proc, SCM obarray), | |
432 | "") | |
433 | #define FUNC_NAME s_scm_obarray_for_each | |
434 | { | |
435 | if (SCM_UNBNDP (obarray)) | |
436 | obarray = symbols; | |
437 | ||
438 | scm_weak_set_for_each (proc, obarray); | |
439 | return SCM_UNSPECIFIED; | |
440 | } | |
441 | #undef FUNC_NAME | |
442 | ||
ceed7709 LC |
443 | /* The default prefix for `gensym'd symbols. */ |
444 | static SCM default_gensym_prefix; | |
445 | ||
4496c9c1 | 446 | #define MAX_PREFIX_LENGTH 30 |
0f2d19dd | 447 | |
86d31dfe MV |
448 | SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, |
449 | (SCM prefix), | |
450 | "Create a new symbol with a name constructed from a prefix and\n" | |
451 | "a counter value. The string @var{prefix} can be specified as\n" | |
68dc153d | 452 | "an optional argument. Default prefix is @code{ g}. The counter\n" |
86d31dfe MV |
453 | "is increased by 1 at each call. There is no provision for\n" |
454 | "resetting the counter.") | |
455 | #define FUNC_NAME s_scm_gensym | |
0f2d19dd | 456 | { |
4496c9c1 AW |
457 | static int gensym_counter = 0; |
458 | ||
3ee86942 | 459 | SCM suffix, name; |
4496c9c1 AW |
460 | int n, n_digits; |
461 | char buf[SCM_INTBUFLEN]; | |
7426a638 | 462 | |
86d31dfe | 463 | if (SCM_UNBNDP (prefix)) |
ceed7709 LC |
464 | prefix = default_gensym_prefix; |
465 | ||
4496c9c1 AW |
466 | /* mutex in case another thread looks and incs at the exact same moment */ |
467 | scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); | |
468 | n = gensym_counter++; | |
469 | scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); | |
3ee86942 | 470 | |
4496c9c1 AW |
471 | n_digits = scm_iint2str (n, 10, buf); |
472 | suffix = scm_from_latin1_stringn (buf, n_digits); | |
3ee86942 MV |
473 | name = scm_string_append (scm_list_2 (prefix, suffix)); |
474 | return scm_string_to_symbol (name); | |
0f2d19dd | 475 | } |
1bbd0b84 | 476 | #undef FUNC_NAME |
0f2d19dd | 477 | |
86d31dfe MV |
478 | SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, |
479 | (SCM symbol), | |
480 | "Return a hash value for @var{symbol}.") | |
481 | #define FUNC_NAME s_scm_symbol_hash | |
0f2d19dd | 482 | { |
86d31dfe | 483 | SCM_VALIDATE_SYMBOL (1, symbol); |
3ee86942 | 484 | return scm_from_ulong (scm_i_symbol_hash (symbol)); |
0f2d19dd | 485 | } |
1bbd0b84 | 486 | #undef FUNC_NAME |
0f2d19dd | 487 | |
3b3b36dd | 488 | SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, |
1bbd0b84 | 489 | (SCM s), |
b7e64f8b | 490 | "Return the contents of the symbol @var{s}'s @dfn{function slot}.") |
1bbd0b84 | 491 | #define FUNC_NAME s_scm_symbol_fref |
0f2d19dd | 492 | { |
34d19ef6 | 493 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 494 | return SCM_CAR (SCM_CELL_OBJECT_3 (s)); |
0f2d19dd | 495 | } |
1bbd0b84 | 496 | #undef FUNC_NAME |
0f2d19dd JB |
497 | |
498 | ||
3b3b36dd | 499 | SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, |
1bbd0b84 | 500 | (SCM s), |
b7e64f8b BT |
501 | "Return the @dfn{property list} currently associated with the\n" |
502 | "symbol @var{s}.") | |
1bbd0b84 | 503 | #define FUNC_NAME s_scm_symbol_pref |
0f2d19dd | 504 | { |
34d19ef6 | 505 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 506 | return SCM_CDR (SCM_CELL_OBJECT_3 (s)); |
0f2d19dd | 507 | } |
1bbd0b84 | 508 | #undef FUNC_NAME |
0f2d19dd JB |
509 | |
510 | ||
3b3b36dd | 511 | SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, |
1bbd0b84 | 512 | (SCM s, SCM val), |
b7e64f8b | 513 | "Change the binding of the symbol @var{s}'s function slot.") |
1bbd0b84 | 514 | #define FUNC_NAME s_scm_symbol_fset_x |
0f2d19dd | 515 | { |
34d19ef6 | 516 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 517 | SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val); |
0f2d19dd JB |
518 | return SCM_UNSPECIFIED; |
519 | } | |
1bbd0b84 | 520 | #undef FUNC_NAME |
0f2d19dd JB |
521 | |
522 | ||
3b3b36dd | 523 | SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, |
1bbd0b84 | 524 | (SCM s, SCM val), |
b7e64f8b | 525 | "Change the binding of the symbol @var{s}'s property slot.") |
1bbd0b84 | 526 | #define FUNC_NAME s_scm_symbol_pset_x |
0f2d19dd | 527 | { |
34d19ef6 | 528 | SCM_VALIDATE_SYMBOL (1, s); |
3ee86942 | 529 | SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val); |
0f2d19dd JB |
530 | return SCM_UNSPECIFIED; |
531 | } | |
1bbd0b84 | 532 | #undef FUNC_NAME |
0f2d19dd | 533 | |
3ee86942 MV |
534 | SCM |
535 | scm_from_locale_symbol (const char *sym) | |
af68e5e5 | 536 | { |
e23106d5 | 537 | return scm_from_locale_symboln (sym, -1); |
af68e5e5 | 538 | } |
af68e5e5 | 539 | |
3ee86942 MV |
540 | SCM |
541 | scm_from_locale_symboln (const char *sym, size_t len) | |
542 | { | |
e23106d5 | 543 | SCM str = scm_from_locale_stringn (sym, len); |
293670e8 | 544 | return scm_i_str2symbol (str, symbols); |
fd0a5bbc HWN |
545 | } |
546 | ||
547 | SCM | |
548 | scm_take_locale_symboln (char *sym, size_t len) | |
549 | { | |
e23106d5 | 550 | SCM str; |
fd0a5bbc | 551 | |
e23106d5 | 552 | str = scm_take_locale_stringn (sym, len); |
293670e8 | 553 | return scm_i_str2symbol (str, symbols); |
fd0a5bbc HWN |
554 | } |
555 | ||
556 | SCM | |
557 | scm_take_locale_symbol (char *sym) | |
558 | { | |
559 | return scm_take_locale_symboln (sym, (size_t)-1); | |
3ee86942 | 560 | } |
af68e5e5 | 561 | |
ad5cbc47 AW |
562 | SCM |
563 | scm_from_latin1_symbol (const char *sym) | |
564 | { | |
565 | return scm_from_latin1_symboln (sym, -1); | |
566 | } | |
567 | ||
568 | SCM | |
569 | scm_from_latin1_symboln (const char *sym, size_t len) | |
570 | { | |
30c282bf AW |
571 | unsigned long hash; |
572 | SCM ret; | |
573 | ||
574 | if (len == (size_t) -1) | |
575 | len = strlen (sym); | |
576 | hash = scm_i_latin1_string_hash (sym, len); | |
577 | ||
293670e8 | 578 | ret = lookup_interned_latin1_symbol (sym, len, hash, symbols); |
30c282bf AW |
579 | if (scm_is_false (ret)) |
580 | { | |
581 | SCM str = scm_from_latin1_stringn (sym, len); | |
293670e8 | 582 | ret = scm_i_str2symbol (str, symbols); |
30c282bf AW |
583 | } |
584 | ||
585 | return ret; | |
ad5cbc47 AW |
586 | } |
587 | ||
588 | SCM | |
589 | scm_from_utf8_symbol (const char *sym) | |
590 | { | |
591 | return scm_from_utf8_symboln (sym, -1); | |
592 | } | |
593 | ||
594 | SCM | |
595 | scm_from_utf8_symboln (const char *sym, size_t len) | |
596 | { | |
f80d15c5 AW |
597 | unsigned long hash; |
598 | SCM ret; | |
599 | ||
600 | if (len == (size_t) -1) | |
601 | len = strlen (sym); | |
602 | hash = scm_i_utf8_string_hash (sym, len); | |
603 | ||
293670e8 | 604 | ret = lookup_interned_utf8_symbol (sym, len, hash, symbols); |
f80d15c5 AW |
605 | if (scm_is_false (ret)) |
606 | { | |
607 | SCM str = scm_from_utf8_stringn (sym, len); | |
293670e8 | 608 | ret = scm_i_str2symbol (str, symbols); |
f80d15c5 AW |
609 | } |
610 | ||
611 | return ret; | |
ad5cbc47 AW |
612 | } |
613 | ||
0f979f3f DH |
614 | void |
615 | scm_symbols_prehistory () | |
616 | { | |
7887be7d | 617 | symbols = scm_c_make_weak_set (5000); |
0f979f3f DH |
618 | } |
619 | ||
620 | ||
0f2d19dd JB |
621 | void |
622 | scm_init_symbols () | |
0f2d19dd | 623 | { |
a0599745 | 624 | #include "libguile/symbols.x" |
ceed7709 LC |
625 | |
626 | default_gensym_prefix = scm_from_latin1_string (" g"); | |
0f2d19dd | 627 | } |
89e00824 ML |
628 | |
629 | /* | |
630 | Local Variables: | |
631 | c-file-style: "gnu" | |
632 | End: | |
633 | */ |