1 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004,
2 * 2006, 2009, 2011 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
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.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
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
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "libguile/_scm.h"
29 #include "libguile/chars.h"
30 #include "libguile/eval.h"
31 #include "libguile/hash.h"
32 #include "libguile/smob.h"
33 #include "libguile/variable.h"
34 #include "libguile/alist.h"
35 #include "libguile/fluids.h"
36 #include "libguile/strings.h"
37 #include "libguile/vectors.h"
38 #include "libguile/weak-set.h"
39 #include "libguile/modules.h"
40 #include "libguile/read.h"
41 #include "libguile/srfi-13.h"
43 #include "libguile/validate.h"
44 #include "libguile/symbols.h"
46 #include "libguile/private-options.h"
58 SCM_DEFINE (scm_sys_symbols
, "%symbols", 0, 0, 0,
60 "Return the system symbol obarray.")
61 #define FUNC_NAME s_scm_sys_symbols
74 scm_i_hash_symbol (SCM obj
, unsigned long n
, void *closure
)
76 return scm_i_symbol_hash (obj
) % n
;
79 struct string_lookup_data
82 unsigned long string_hash
;
86 string_lookup_predicate_fn (SCM sym
, void *closure
)
88 struct string_lookup_data
*data
= closure
;
90 if (scm_i_symbol_hash (sym
) == data
->string_hash
91 && scm_i_symbol_length (sym
) == scm_i_string_length (data
->string
))
93 size_t n
= scm_i_symbol_length (sym
);
95 if (scm_i_symbol_ref (sym
, n
) != scm_i_string_ref (data
->string
, n
))
104 lookup_interned_symbol (SCM name
, unsigned long raw_hash
)
106 struct string_lookup_data data
;
109 data
.string_hash
= raw_hash
;
111 return scm_c_weak_set_lookup (symbols
, raw_hash
,
112 string_lookup_predicate_fn
,
116 struct latin1_lookup_data
120 unsigned long string_hash
;
124 latin1_lookup_predicate_fn (SCM sym
, void *closure
)
126 struct latin1_lookup_data
*data
= closure
;
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;
135 lookup_interned_latin1_symbol (const char *str
, size_t len
,
136 unsigned long raw_hash
)
138 struct latin1_lookup_data data
;
142 data
.string_hash
= raw_hash
;
144 return scm_c_weak_set_lookup (symbols
, raw_hash
,
145 latin1_lookup_predicate_fn
,
149 struct utf8_lookup_data
153 unsigned long string_hash
;
157 utf8_string_equals_wide_string (const scm_t_uint8
*narrow
, size_t nlen
,
158 const scm_t_wchar
*wide
, size_t wlen
)
160 size_t byte_idx
= 0, char_idx
= 0;
162 while (byte_idx
< nlen
&& char_idx
< wlen
)
167 nbytes
= u8_mbtouc (&c
, narrow
+ byte_idx
, nlen
- byte_idx
);
173 else if (c
!= wide
[char_idx
])
180 return byte_idx
== nlen
&& char_idx
== wlen
;
184 utf8_lookup_predicate_fn (SCM sym
, void *closure
)
186 struct utf8_lookup_data
*data
= closure
;
188 if (scm_i_symbol_hash (sym
) != data
->string_hash
)
191 if (scm_i_is_narrow_symbol (sym
))
192 return (scm_i_symbol_length (sym
) == data
->len
193 && strncmp (scm_i_symbol_chars (sym
), data
->str
, data
->len
) == 0);
195 return utf8_string_equals_wide_string ((const scm_t_uint8
*) data
->str
,
197 scm_i_symbol_wide_chars (sym
),
198 scm_i_symbol_length (sym
));
202 lookup_interned_utf8_symbol (const char *str
, size_t len
,
203 unsigned long raw_hash
)
205 struct utf8_lookup_data data
;
209 data
.string_hash
= raw_hash
;
211 return scm_c_weak_set_lookup (symbols
, raw_hash
,
212 utf8_lookup_predicate_fn
,
217 symbol_lookup_predicate_fn (SCM sym
, void *closure
)
219 SCM other
= SCM_PACK_POINTER (closure
);
221 if (scm_i_symbol_hash (sym
) == scm_i_symbol_hash (other
)
222 && scm_i_symbol_length (sym
) == scm_i_symbol_length (other
))
224 if (scm_i_is_narrow_symbol (sym
))
225 return scm_i_is_narrow_symbol (other
)
226 && (strncmp (scm_i_symbol_chars (sym
),
227 scm_i_symbol_chars (other
),
228 scm_i_symbol_length (other
)) == 0);
231 (scm_string_equal_p (scm_symbol_to_string (sym
),
232 scm_symbol_to_string (other
)));
238 scm_i_str2symbol (SCM str
)
241 size_t raw_hash
= scm_i_string_hash (str
);
243 symbol
= lookup_interned_symbol (str
, raw_hash
);
244 if (scm_is_true (symbol
))
248 /* The symbol was not found, create it. */
249 symbol
= scm_i_make_symbol (str
, 0, raw_hash
,
250 scm_cons (SCM_BOOL_F
, SCM_EOL
));
252 /* Might return a different symbol, if another one was interned at
254 return scm_c_weak_set_add_x (symbols
, raw_hash
,
255 symbol_lookup_predicate_fn
,
256 SCM_UNPACK_POINTER (symbol
), symbol
);
262 scm_i_str2uninterned_symbol (SCM str
)
264 size_t raw_hash
= scm_i_string_hash (str
);
266 return scm_i_make_symbol (str
, SCM_I_F_SYMBOL_UNINTERNED
,
267 raw_hash
, scm_cons (SCM_BOOL_F
, SCM_EOL
));
270 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
272 "Return @code{#t} if @var{obj} is a symbol, otherwise return\n"
274 #define FUNC_NAME s_scm_symbol_p
276 return scm_from_bool (scm_is_symbol (obj
));
280 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 1, 0, 0,
282 "Return @code{#t} if @var{symbol} is interned, otherwise return\n"
284 #define FUNC_NAME s_scm_symbol_interned_p
286 SCM_VALIDATE_SYMBOL (1, symbol
);
287 return scm_from_bool (scm_i_symbol_is_interned (symbol
));
291 SCM_DEFINE (scm_make_symbol
, "make-symbol", 1, 0, 0,
293 "Return a new uninterned symbol with the name @var{name}. "
294 "The returned symbol is guaranteed to be unique and future "
295 "calls to @code{string->symbol} will not return it.")
296 #define FUNC_NAME s_scm_make_symbol
298 SCM_VALIDATE_STRING (1, name
);
299 return scm_i_str2uninterned_symbol (name
);
303 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
305 "Return the name of @var{symbol} as a string. If the symbol was\n"
306 "part of an object returned as the value of a literal expression\n"
307 "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n"
308 "Report on Scheme}) or by a call to the @code{read} procedure,\n"
309 "and its name contains alphabetic characters, then the string\n"
310 "returned will contain characters in the implementation's\n"
311 "preferred standard case---some implementations will prefer\n"
312 "upper case, others lower case. If the symbol was returned by\n"
313 "@code{string->symbol}, the case of characters in the string\n"
314 "returned will be the same as the case in the string that was\n"
315 "passed to @code{string->symbol}. It is an error to apply\n"
316 "mutation procedures like @code{string-set!} to strings returned\n"
317 "by this procedure.\n"
319 "The following examples assume that the implementation's\n"
320 "standard case is lower case:\n"
323 "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n"
324 "(symbol->string 'Martin) @result{} \"martin\"\n"
326 " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
328 #define FUNC_NAME s_scm_symbol_to_string
330 SCM_VALIDATE_SYMBOL (1, s
);
331 return scm_i_symbol_substring (s
, 0, scm_i_symbol_length (s
));
336 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
338 "Return the symbol whose name is @var{string}. This procedure\n"
339 "can create symbols with names containing special characters or\n"
340 "letters in the non-standard case, but it is usually a bad idea\n"
341 "to create such symbols because in some implementations of\n"
342 "Scheme they cannot be read as themselves. See\n"
343 "@code{symbol->string}.\n"
345 "The following examples assume that the implementation's\n"
346 "standard case is lower case:\n"
349 "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
350 "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
351 "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
353 " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
354 "(string=? \"K. Harper, M.D.\"\n"
356 " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
358 #define FUNC_NAME s_scm_string_to_symbol
360 SCM_VALIDATE_STRING (1, string
);
361 return scm_i_str2symbol (string
);
365 SCM_DEFINE (scm_string_ci_to_symbol
, "string-ci->symbol", 1, 0, 0,
367 "Return the symbol whose name is @var{str}. @var{str} is\n"
368 "converted to lowercase before the conversion is done, if Guile\n"
369 "is currently reading symbols case-insensitively.")
370 #define FUNC_NAME s_scm_string_ci_to_symbol
372 return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
373 ? scm_string_downcase(str
)
378 /* The default prefix for `gensym'd symbols. */
379 static SCM default_gensym_prefix
;
381 #define MAX_PREFIX_LENGTH 30
383 SCM_DEFINE (scm_gensym
, "gensym", 0, 1, 0,
385 "Create a new symbol with a name constructed from a prefix and\n"
386 "a counter value. The string @var{prefix} can be specified as\n"
387 "an optional argument. Default prefix is @code{ g}. The counter\n"
388 "is increased by 1 at each call. There is no provision for\n"
389 "resetting the counter.")
390 #define FUNC_NAME s_scm_gensym
392 static int gensym_counter
= 0;
396 char buf
[SCM_INTBUFLEN
];
398 if (SCM_UNBNDP (prefix
))
399 prefix
= default_gensym_prefix
;
401 /* mutex in case another thread looks and incs at the exact same moment */
402 scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex
);
403 n
= gensym_counter
++;
404 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
406 n_digits
= scm_iint2str (n
, 10, buf
);
407 suffix
= scm_from_latin1_stringn (buf
, n_digits
);
408 name
= scm_string_append (scm_list_2 (prefix
, suffix
));
409 return scm_string_to_symbol (name
);
413 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
415 "Return a hash value for @var{symbol}.")
416 #define FUNC_NAME s_scm_symbol_hash
418 SCM_VALIDATE_SYMBOL (1, symbol
);
419 return scm_from_ulong (scm_i_symbol_hash (symbol
));
423 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
425 "Return the contents of the symbol @var{s}'s @dfn{function slot}.")
426 #define FUNC_NAME s_scm_symbol_fref
428 SCM_VALIDATE_SYMBOL (1, s
);
429 return SCM_CAR (SCM_CELL_OBJECT_3 (s
));
434 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
436 "Return the @dfn{property list} currently associated with the\n"
438 #define FUNC_NAME s_scm_symbol_pref
440 SCM_VALIDATE_SYMBOL (1, s
);
441 return SCM_CDR (SCM_CELL_OBJECT_3 (s
));
446 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
448 "Change the binding of the symbol @var{s}'s function slot.")
449 #define FUNC_NAME s_scm_symbol_fset_x
451 SCM_VALIDATE_SYMBOL (1, s
);
452 SCM_SETCAR (SCM_CELL_OBJECT_3 (s
), val
);
453 return SCM_UNSPECIFIED
;
458 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
460 "Change the binding of the symbol @var{s}'s property slot.")
461 #define FUNC_NAME s_scm_symbol_pset_x
463 SCM_VALIDATE_SYMBOL (1, s
);
464 SCM_SETCDR (SCM_CELL_OBJECT_3 (s
), val
);
465 return SCM_UNSPECIFIED
;
470 scm_from_locale_symbol (const char *sym
)
472 return scm_from_locale_symboln (sym
, -1);
476 scm_from_locale_symboln (const char *sym
, size_t len
)
478 SCM str
= scm_from_locale_stringn (sym
, len
);
479 return scm_i_str2symbol (str
);
483 scm_take_locale_symboln (char *sym
, size_t len
)
487 str
= scm_take_locale_stringn (sym
, len
);
488 return scm_i_str2symbol (str
);
492 scm_take_locale_symbol (char *sym
)
494 return scm_take_locale_symboln (sym
, (size_t)-1);
498 scm_from_latin1_symbol (const char *sym
)
500 return scm_from_latin1_symboln (sym
, -1);
504 scm_from_latin1_symboln (const char *sym
, size_t len
)
509 if (len
== (size_t) -1)
511 hash
= scm_i_latin1_string_hash (sym
, len
);
513 ret
= lookup_interned_latin1_symbol (sym
, len
, hash
);
514 if (scm_is_false (ret
))
516 SCM str
= scm_from_latin1_stringn (sym
, len
);
517 ret
= scm_i_str2symbol (str
);
524 scm_from_utf8_symbol (const char *sym
)
526 return scm_from_utf8_symboln (sym
, -1);
530 scm_from_utf8_symboln (const char *sym
, size_t len
)
535 if (len
== (size_t) -1)
537 hash
= scm_i_utf8_string_hash (sym
, len
);
539 ret
= lookup_interned_utf8_symbol (sym
, len
, hash
);
540 if (scm_is_false (ret
))
542 SCM str
= scm_from_utf8_stringn (sym
, len
);
543 ret
= scm_i_str2symbol (str
);
550 scm_symbols_prehistory ()
552 symbols
= scm_c_make_weak_set (5000);
559 #include "libguile/symbols.x"
561 default_gensym_prefix
= scm_from_latin1_string (" g");