-/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
SCM
scm_mem2symbol (const char *name, size_t len)
{
- size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
+ size_t raw_hash = scm_string_hash ((const unsigned char *) name, len)/2;
size_t hash = raw_hash % SCM_VECTOR_LENGTH (symbols);
{
SCM cell;
SCM slot;
- SCM_NEWCELL2 (symbol);
- SCM_SET_SYMBOL_CHARS (symbol, scm_must_strndup (name, len));
- SCM_SET_SYMBOL_HASH (symbol, raw_hash);
- SCM_SET_PROP_SLOTS (symbol, scm_cons (SCM_BOOL_F, SCM_EOL));
- SCM_SET_SYMBOL_LENGTH (symbol, (long) len);
+ symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len),
+ (scm_t_bits) scm_gc_strndup (name, len,
+ "symbol"),
+ raw_hash,
+ SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL)));
slot = SCM_VELTS (symbols) [hash];
cell = scm_cons (symbol, SCM_UNDEFINED);
- SCM_VELTS (symbols) [hash] = scm_cons (cell, slot);
+ SCM_VECTOR_SET (symbols, hash, scm_cons (cell, slot));
return symbol;
}
}
+SCM
+scm_mem2uninterned_symbol (const char *name, size_t len)
+{
+ size_t raw_hash = (scm_string_hash ((const unsigned char *) name, len)/2
+ + SCM_T_BITS_MAX/2 + 1);
+
+ return scm_double_cell (SCM_MAKE_SYMBOL_TAG (len),
+ (scm_t_bits) scm_gc_strndup (name, len,
+ "symbol"),
+ raw_hash,
+ SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL)));
+}
SCM
scm_str2symbol (const char *str)
}
#undef FUNC_NAME
+SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0,
+ (SCM symbol),
+ "Return @code{#t} if @var{symbol} is interned, otherwise return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_symbol_interned_p
+{
+ SCM_VALIDATE_SYMBOL (1, symbol);
+ return SCM_BOOL (SCM_SYMBOL_INTERNED_P (symbol));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0,
+ (SCM name),
+ "Return a new uninterned symbol with the name @var{name}. "
+ "The returned symbol is guaranteed to be unique and future "
+ "calls to @code{string->symbol} will not return it.")
+#define FUNC_NAME s_scm_make_symbol
+{
+ SCM sym;
+ SCM_VALIDATE_STRING (1, name);
+ sym = scm_mem2uninterned_symbol (SCM_STRING_CHARS (name),
+ SCM_STRING_LENGTH (name));
+ scm_remember_upto_here_1 (name);
+ return sym;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0,
(SCM s),
"Return the name of @var{symbol} as a string. If the symbol was\n"
"@end lisp")
#define FUNC_NAME s_scm_symbol_to_string
{
+ SCM str;
SCM_VALIDATE_SYMBOL (1, s);
- return scm_makfromstr (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s), 0);
+ str = scm_mem2string (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s));
+ scm_remember_upto_here_1 (s);
+ return str;
}
#undef FUNC_NAME
"@end lisp")
#define FUNC_NAME s_scm_string_to_symbol
{
+ SCM sym;
SCM_VALIDATE_STRING (1, string);
- return scm_mem2symbol (SCM_STRING_CHARS (string),
- SCM_STRING_LENGTH (string));
+ sym = scm_mem2symbol (SCM_STRING_CHARS (string),
+ SCM_STRING_LENGTH (string));
+ scm_remember_upto_here_1 (string);
+ return sym;
}
#undef FUNC_NAME
(SCM prefix),
"Create a new symbol with a name constructed from a prefix and\n"
"a counter value. The string @var{prefix} can be specified as\n"
- "an optional argument. Default prefix is @code{g}. The counter\n"
+ "an optional argument. Default prefix is @code{ g}. The counter\n"
"is increased by 1 at each call. There is no provision for\n"
"resetting the counter.")
#define FUNC_NAME s_scm_gensym
size_t len;
if (SCM_UNBNDP (prefix))
{
- name[0] = 'g';
- len = 1;
+ name[0] = ' ';
+ name[1] = 'g';
+ len = 2;
}
else
{
SCM_VALIDATE_STRING (1, prefix);
len = SCM_STRING_LENGTH (prefix);
if (len > MAX_PREFIX_LENGTH)
- name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN);
- strncpy (name, SCM_STRING_CHARS (prefix), len);
+ name = scm_malloc (len + SCM_INTBUFLEN);
+ memcpy (name, SCM_STRING_CHARS (prefix), len);
}
{
int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]);
SCM res = scm_mem2symbol (name, len + n_digits);
if (name != buf)
- scm_must_free (name);
+ free (name);
return res;
}
}
#define FUNC_NAME s_scm_symbol_hash
{
SCM_VALIDATE_SYMBOL (1, symbol);
- return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol));
+ return scm_ulong2num (SCM_SYMBOL_HASH (symbol));
}
#undef FUNC_NAME
"Return the contents of @var{symbol}'s @dfn{function slot}.")
#define FUNC_NAME s_scm_symbol_fref
{
- SCM_VALIDATE_SYMBOL (1,s);
+ SCM_VALIDATE_SYMBOL (1, s);
return SCM_SYMBOL_FUNC (s);
}
#undef FUNC_NAME
"Return the @dfn{property list} currently associated with @var{symbol}.")
#define FUNC_NAME s_scm_symbol_pref
{
- SCM_VALIDATE_SYMBOL (1,s);
+ SCM_VALIDATE_SYMBOL (1, s);
return SCM_SYMBOL_PROPS (s);
}
#undef FUNC_NAME
"Change the binding of @var{symbol}'s function slot.")
#define FUNC_NAME s_scm_symbol_fset_x
{
- SCM_VALIDATE_SYMBOL (1,s);
+ SCM_VALIDATE_SYMBOL (1, s);
SCM_SET_SYMBOL_FUNC (s, val);
return SCM_UNSPECIFIED;
}
"Change the binding of @var{symbol}'s property slot.")
#define FUNC_NAME s_scm_symbol_pset_x
{
- SCM_VALIDATE_SYMBOL (1,s);
+ SCM_VALIDATE_SYMBOL (1, s);
SCM_DEFER_INTS;
SCM_SET_SYMBOL_PROPS (s, val);
SCM_ALLOW_INTS;
}
#undef FUNC_NAME
+
+/* Converts the given Scheme symbol OBJ into a C string, containing a copy
+ of OBJ's content with a trailing null byte. If LENP is non-NULL, set
+ *LENP to the string's length.
+
+ When STR is non-NULL it receives the copy and is returned by the function,
+ otherwise new memory is allocated and the caller is responsible for
+ freeing it via free(). If out of memory, NULL is returned.
+
+ Note that Scheme symbols may contain arbitrary data, including null
+ characters. This means that null termination is not a reliable way to
+ determine the length of the returned value. However, the function always
+ copies the complete contents of OBJ, and sets *LENP to the length of the
+ scheme symbol (if LENP is non-null). */
+#define FUNC_NAME "scm_c_symbol2str"
+char *
+scm_c_symbol2str (SCM obj, char *str, size_t *lenp)
+{
+ size_t len;
+
+ SCM_ASSERT (SCM_SYMBOLP (obj), obj, SCM_ARG1, FUNC_NAME);
+ len = SCM_SYMBOL_LENGTH (obj);
+
+ if (str == NULL)
+ {
+ /* FIXME: Should we use exported wrappers for malloc (and free), which
+ * allow windows DLLs to call the correct freeing function? */
+ str = (char *) malloc ((len + 1) * sizeof (char));
+ if (str == NULL)
+ return NULL;
+ }
+
+ memcpy (str, SCM_SYMBOL_CHARS (obj), len);
+ scm_remember_upto_here_1 (obj);
+ str[len] = '\0';
+
+ if (lenp != NULL)
+ *lenp = len;
+
+ return str;
+}
+#undef FUNC_NAME
+
+
void
scm_symbols_prehistory ()
{
scm_init_symbols ()
{
gensym_counter = 0;
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/symbols.x"
-#endif
-#if SCM_ENABLE_VCELLS
- scm_init_symbols_deprecated ();
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff