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
26 #include "libguile/_scm.h"
27 #include "libguile/chars.h"
28 #include "libguile/eval.h"
29 #include "libguile/hash.h"
30 #include "libguile/smob.h"
31 #include "libguile/variable.h"
32 #include "libguile/alist.h"
33 #include "libguile/fluids.h"
34 #include "libguile/strings.h"
35 #include "libguile/vectors.h"
36 #include "libguile/hashtab.h"
37 #include "libguile/weaks.h"
38 #include "libguile/modules.h"
39 #include "libguile/read.h"
40 #include "libguile/srfi-13.h"
42 #include "libguile/validate.h"
43 #include "libguile/symbols.h"
45 #include "libguile/private-options.h"
55 static scm_i_pthread_mutex_t symbols_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
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
;
110 data
.string_hash
= raw_hash
;
112 scm_i_pthread_mutex_lock (&symbols_lock
);
113 handle
= scm_hash_fn_get_handle_by_hash (symbols
, raw_hash
,
114 string_lookup_predicate_fn
,
116 scm_i_pthread_mutex_unlock (&symbols_lock
);
118 if (scm_is_true (handle
))
119 return SCM_CAR (handle
);
124 struct latin1_lookup_data
128 unsigned long string_hash
;
132 latin1_lookup_predicate_fn (SCM sym
, void *closure
)
134 struct latin1_lookup_data
*data
= closure
;
136 return scm_i_symbol_hash (sym
) == data
->string_hash
137 && scm_i_is_narrow_symbol (sym
)
138 && scm_i_symbol_length (sym
) == data
->len
139 && strncmp (scm_i_symbol_chars (sym
), data
->str
, data
->len
) == 0;
143 lookup_interned_latin1_symbol (const char *str
, size_t len
,
144 unsigned long raw_hash
)
146 struct latin1_lookup_data data
;
151 data
.string_hash
= raw_hash
;
153 scm_i_pthread_mutex_lock (&symbols_lock
);
154 handle
= scm_hash_fn_get_handle_by_hash (symbols
, raw_hash
,
155 latin1_lookup_predicate_fn
,
157 scm_i_pthread_mutex_unlock (&symbols_lock
);
159 if (scm_is_true (handle
))
160 return SCM_CAR (handle
);
166 symbol_lookup_hash_fn (SCM obj
, unsigned long max
, void *closure
)
168 return scm_i_symbol_hash (obj
) % max
;
172 symbol_lookup_assoc_fn (SCM obj
, SCM alist
, void *closure
)
174 for (; !scm_is_null (alist
); alist
= SCM_CDR (alist
))
176 SCM sym
= SCM_CAAR (alist
);
178 if (scm_i_symbol_hash (sym
) == scm_i_symbol_hash (obj
)
179 && scm_is_true (scm_string_equal_p (scm_symbol_to_string (sym
),
180 scm_symbol_to_string (obj
))))
181 return SCM_CAR (alist
);
187 /* Intern SYMBOL, an uninterned symbol. Might return a different
188 symbol, if another one was interned at the same time. */
190 intern_symbol (SCM symbol
)
194 scm_i_pthread_mutex_lock (&symbols_lock
);
195 handle
= scm_hash_fn_create_handle_x (symbols
, symbol
, SCM_UNDEFINED
,
196 symbol_lookup_hash_fn
,
197 symbol_lookup_assoc_fn
,
199 scm_i_pthread_mutex_unlock (&symbols_lock
);
201 return SCM_CAR (handle
);
205 scm_i_str2symbol (SCM str
)
208 size_t raw_hash
= scm_i_string_hash (str
);
210 symbol
= lookup_interned_symbol (str
, raw_hash
);
211 if (scm_is_true (symbol
))
215 /* The symbol was not found, create it. */
216 symbol
= scm_i_make_symbol (str
, 0, raw_hash
,
217 scm_cons (SCM_BOOL_F
, SCM_EOL
));
218 return intern_symbol (symbol
);
224 scm_i_str2uninterned_symbol (SCM str
)
226 size_t raw_hash
= scm_i_string_hash (str
);
228 return scm_i_make_symbol (str
, SCM_I_F_SYMBOL_UNINTERNED
,
229 raw_hash
, scm_cons (SCM_BOOL_F
, SCM_EOL
));
232 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
234 "Return @code{#t} if @var{obj} is a symbol, otherwise return\n"
236 #define FUNC_NAME s_scm_symbol_p
238 return scm_from_bool (scm_is_symbol (obj
));
242 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 1, 0, 0,
244 "Return @code{#t} if @var{symbol} is interned, otherwise return\n"
246 #define FUNC_NAME s_scm_symbol_interned_p
248 SCM_VALIDATE_SYMBOL (1, symbol
);
249 return scm_from_bool (scm_i_symbol_is_interned (symbol
));
253 SCM_DEFINE (scm_make_symbol
, "make-symbol", 1, 0, 0,
255 "Return a new uninterned symbol with the name @var{name}. "
256 "The returned symbol is guaranteed to be unique and future "
257 "calls to @code{string->symbol} will not return it.")
258 #define FUNC_NAME s_scm_make_symbol
260 SCM_VALIDATE_STRING (1, name
);
261 return scm_i_str2uninterned_symbol (name
);
265 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
267 "Return the name of @var{symbol} as a string. If the symbol was\n"
268 "part of an object returned as the value of a literal expression\n"
269 "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n"
270 "Report on Scheme}) or by a call to the @code{read} procedure,\n"
271 "and its name contains alphabetic characters, then the string\n"
272 "returned will contain characters in the implementation's\n"
273 "preferred standard case---some implementations will prefer\n"
274 "upper case, others lower case. If the symbol was returned by\n"
275 "@code{string->symbol}, the case of characters in the string\n"
276 "returned will be the same as the case in the string that was\n"
277 "passed to @code{string->symbol}. It is an error to apply\n"
278 "mutation procedures like @code{string-set!} to strings returned\n"
279 "by this procedure.\n"
281 "The following examples assume that the implementation's\n"
282 "standard case is lower case:\n"
285 "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n"
286 "(symbol->string 'Martin) @result{} \"martin\"\n"
288 " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
290 #define FUNC_NAME s_scm_symbol_to_string
292 SCM_VALIDATE_SYMBOL (1, s
);
293 return scm_i_symbol_substring (s
, 0, scm_i_symbol_length (s
));
298 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
300 "Return the symbol whose name is @var{string}. This procedure\n"
301 "can create symbols with names containing special characters or\n"
302 "letters in the non-standard case, but it is usually a bad idea\n"
303 "to create such symbols because in some implementations of\n"
304 "Scheme they cannot be read as themselves. See\n"
305 "@code{symbol->string}.\n"
307 "The following examples assume that the implementation's\n"
308 "standard case is lower case:\n"
311 "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
312 "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
313 "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
315 " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
316 "(string=? \"K. Harper, M.D.\"\n"
318 " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
320 #define FUNC_NAME s_scm_string_to_symbol
322 SCM_VALIDATE_STRING (1, string
);
323 return scm_i_str2symbol (string
);
327 SCM_DEFINE (scm_string_ci_to_symbol
, "string-ci->symbol", 1, 0, 0,
329 "Return the symbol whose name is @var{str}. @var{str} is\n"
330 "converted to lowercase before the conversion is done, if Guile\n"
331 "is currently reading symbols case-insensitively.")
332 #define FUNC_NAME s_scm_string_ci_to_symbol
334 return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
335 ? scm_string_downcase(str
)
340 /* The default prefix for `gensym'd symbols. */
341 static SCM default_gensym_prefix
;
343 #define MAX_PREFIX_LENGTH 30
345 SCM_DEFINE (scm_gensym
, "gensym", 0, 1, 0,
347 "Create a new symbol with a name constructed from a prefix and\n"
348 "a counter value. The string @var{prefix} can be specified as\n"
349 "an optional argument. Default prefix is @code{ g}. The counter\n"
350 "is increased by 1 at each call. There is no provision for\n"
351 "resetting the counter.")
352 #define FUNC_NAME s_scm_gensym
354 static int gensym_counter
= 0;
358 char buf
[SCM_INTBUFLEN
];
360 if (SCM_UNBNDP (prefix
))
361 prefix
= default_gensym_prefix
;
363 /* mutex in case another thread looks and incs at the exact same moment */
364 scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex
);
365 n
= gensym_counter
++;
366 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
368 n_digits
= scm_iint2str (n
, 10, buf
);
369 suffix
= scm_from_latin1_stringn (buf
, n_digits
);
370 name
= scm_string_append (scm_list_2 (prefix
, suffix
));
371 return scm_string_to_symbol (name
);
375 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
377 "Return a hash value for @var{symbol}.")
378 #define FUNC_NAME s_scm_symbol_hash
380 SCM_VALIDATE_SYMBOL (1, symbol
);
381 return scm_from_ulong (scm_i_symbol_hash (symbol
));
385 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
387 "Return the contents of the symbol @var{s}'s @dfn{function slot}.")
388 #define FUNC_NAME s_scm_symbol_fref
390 SCM_VALIDATE_SYMBOL (1, s
);
391 return SCM_CAR (SCM_CELL_OBJECT_3 (s
));
396 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
398 "Return the @dfn{property list} currently associated with the\n"
400 #define FUNC_NAME s_scm_symbol_pref
402 SCM_VALIDATE_SYMBOL (1, s
);
403 return SCM_CDR (SCM_CELL_OBJECT_3 (s
));
408 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
410 "Change the binding of the symbol @var{s}'s function slot.")
411 #define FUNC_NAME s_scm_symbol_fset_x
413 SCM_VALIDATE_SYMBOL (1, s
);
414 SCM_SETCAR (SCM_CELL_OBJECT_3 (s
), val
);
415 return SCM_UNSPECIFIED
;
420 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
422 "Change the binding of the symbol @var{s}'s property slot.")
423 #define FUNC_NAME s_scm_symbol_pset_x
425 SCM_VALIDATE_SYMBOL (1, s
);
426 SCM_SETCDR (SCM_CELL_OBJECT_3 (s
), val
);
427 return SCM_UNSPECIFIED
;
432 scm_from_locale_symbol (const char *sym
)
434 return scm_from_locale_symboln (sym
, -1);
438 scm_from_locale_symboln (const char *sym
, size_t len
)
440 SCM str
= scm_from_locale_stringn (sym
, len
);
441 return scm_i_str2symbol (str
);
445 scm_take_locale_symboln (char *sym
, size_t len
)
449 str
= scm_take_locale_stringn (sym
, len
);
450 return scm_i_str2symbol (str
);
454 scm_take_locale_symbol (char *sym
)
456 return scm_take_locale_symboln (sym
, (size_t)-1);
460 scm_from_latin1_symbol (const char *sym
)
462 return scm_from_latin1_symboln (sym
, -1);
466 scm_from_latin1_symboln (const char *sym
, size_t len
)
471 if (len
== (size_t) -1)
473 hash
= scm_i_latin1_string_hash (sym
, len
);
475 ret
= lookup_interned_latin1_symbol (sym
, len
, hash
);
476 if (scm_is_false (ret
))
478 SCM str
= scm_from_latin1_stringn (sym
, len
);
479 ret
= scm_i_str2symbol (str
);
486 scm_from_utf8_symbol (const char *sym
)
488 return scm_from_utf8_symboln (sym
, -1);
492 scm_from_utf8_symboln (const char *sym
, size_t len
)
494 SCM str
= scm_from_utf8_stringn (sym
, len
);
495 return scm_i_str2symbol (str
);
499 scm_symbols_prehistory ()
501 symbols
= scm_make_weak_key_hash_table (scm_from_int (2139));
508 #include "libguile/symbols.x"
510 default_gensym_prefix
= scm_from_latin1_string (" g");