mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
(scm_strhash, scm_sym2ovcell_soft, scm_sym2ovcell,
scm_intern_obarray_soft, scm_intern_obarray, scm_symbol_value0, scm_string_to_obarray_symbol scm_intern_symbol, scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned_p, scm_symbol_bound_p, scm_symbol_set_x, scm_gentemp): Re-added from the release_1_6 branch.
This commit is contained in:
Marius Vollmer
parent
66c8ded2a5
commit
cc5c1b6606
2 changed files with 452 additions and 28 deletions
|
|
@ -40,6 +40,7 @@
|
|||
#include "libguile/read.h"
|
||||
#include "libguile/strports.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/alist.h"
|
||||
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
|
|
@ -667,6 +668,435 @@ scm_i_object_length (SCM obj)
|
|||
abort ();
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_sym2ovcell_soft (SCM sym, SCM obarray)
|
||||
{
|
||||
SCM lsym, z;
|
||||
size_t hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray);
|
||||
|
||||
scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
SCM_REDEFER_INTS;
|
||||
for (lsym = SCM_VECTOR_REF (obarray, hash);
|
||||
SCM_NIMP (lsym);
|
||||
lsym = SCM_CDR (lsym))
|
||||
{
|
||||
z = SCM_CAR (lsym);
|
||||
if (SCM_EQ_P (SCM_CAR (z), sym))
|
||||
{
|
||||
SCM_REALLOW_INTS;
|
||||
return z;
|
||||
}
|
||||
}
|
||||
SCM_REALLOW_INTS;
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
|
||||
SCM
|
||||
scm_sym2ovcell (SCM sym, SCM obarray)
|
||||
#define FUNC_NAME "scm_sym2ovcell"
|
||||
{
|
||||
SCM answer;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
answer = scm_sym2ovcell_soft (sym, obarray);
|
||||
if (!SCM_FALSEP (answer))
|
||||
return answer;
|
||||
SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym));
|
||||
return SCM_UNSPECIFIED; /* not reached */
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
|
||||
|
||||
OBARRAY should be a vector of lists, indexed by the name's hash
|
||||
value, modulo OBARRAY's length. Each list has the form
|
||||
((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
|
||||
value associated with that symbol (in the current module? in the
|
||||
system module?)
|
||||
|
||||
To "intern" a symbol means: if OBARRAY already contains a symbol by
|
||||
that name, return its (SYMBOL . VALUE) pair; otherwise, create a
|
||||
new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
|
||||
appropriate list of the OBARRAY, and return the pair.
|
||||
|
||||
If softness is non-zero, don't create a symbol if it isn't already
|
||||
in OBARRAY; instead, just return #f.
|
||||
|
||||
If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
|
||||
return (SYMBOL . SCM_UNDEFINED). */
|
||||
|
||||
|
||||
SCM
|
||||
scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness)
|
||||
{
|
||||
SCM symbol = scm_mem2symbol (name, len);
|
||||
size_t raw_hash = SCM_SYMBOL_HASH (symbol);
|
||||
size_t hash;
|
||||
SCM lsym;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
if (SCM_FALSEP (obarray))
|
||||
{
|
||||
if (softness)
|
||||
return SCM_BOOL_F;
|
||||
else
|
||||
return scm_cons (symbol, SCM_UNDEFINED);
|
||||
}
|
||||
|
||||
hash = raw_hash % SCM_VECTOR_LENGTH (obarray);
|
||||
|
||||
for (lsym = SCM_VECTOR_REF(obarray, hash);
|
||||
SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
|
||||
{
|
||||
SCM a = SCM_CAR (lsym);
|
||||
SCM z = SCM_CAR (a);
|
||||
if (SCM_EQ_P (z, symbol))
|
||||
return a;
|
||||
}
|
||||
|
||||
if (softness)
|
||||
{
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
else
|
||||
{
|
||||
SCM cell = scm_cons (symbol, SCM_UNDEFINED);
|
||||
SCM slot = SCM_VECTOR_REF (obarray, hash);
|
||||
|
||||
SCM_VECTOR_SET (obarray, hash, scm_cons (cell, slot));
|
||||
|
||||
return cell;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
SCM
|
||||
scm_intern_obarray (const char *name,size_t len,SCM obarray)
|
||||
{
|
||||
scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
return scm_intern_obarray_soft (name, len, obarray, 0);
|
||||
}
|
||||
|
||||
/* Lookup the value of the symbol named by the nul-terminated string
|
||||
NAME in the current module. */
|
||||
SCM
|
||||
scm_symbol_value0 (const char *name)
|
||||
{
|
||||
scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
|
||||
"Use `scm_lookup' instead.");
|
||||
|
||||
return scm_variable_ref (scm_c_lookup (name));
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
|
||||
(SCM o, SCM s, SCM softp),
|
||||
"Intern a new symbol in @var{obarray}, a symbol table, with name\n"
|
||||
"@var{string}.\n\n"
|
||||
"If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
|
||||
"@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
|
||||
"symbol table; merely return the pair (@var{symbol}\n"
|
||||
". @var{#<undefined>}).\n\n"
|
||||
"The @var{soft?} argument determines whether new symbol table entries\n"
|
||||
"should be created when the specified symbol is not already present in\n"
|
||||
"@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
|
||||
"new entries should not be added for symbols not already present in the\n"
|
||||
"table; instead, simply return @code{#f}.")
|
||||
#define FUNC_NAME s_scm_string_to_obarray_symbol
|
||||
{
|
||||
SCM vcell;
|
||||
SCM answer;
|
||||
int softness;
|
||||
|
||||
SCM_VALIDATE_STRING (2, s);
|
||||
SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME);
|
||||
|
||||
scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp));
|
||||
/* iron out some screwy calling conventions */
|
||||
if (SCM_FALSEP (o))
|
||||
{
|
||||
/* nothing interesting to do here. */
|
||||
return scm_string_to_symbol (s);
|
||||
}
|
||||
else if (SCM_EQ_P (o, SCM_BOOL_T))
|
||||
o = SCM_BOOL_F;
|
||||
|
||||
vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s),
|
||||
SCM_STRING_LENGTH (s),
|
||||
o,
|
||||
softness);
|
||||
if (SCM_FALSEP (vcell))
|
||||
return vcell;
|
||||
answer = SCM_CAR (vcell);
|
||||
return answer;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
|
||||
(SCM o, SCM s),
|
||||
"Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
|
||||
"unspecified initial value. The symbol table is not modified if a symbol\n"
|
||||
"with this name is already present.")
|
||||
#define FUNC_NAME s_scm_intern_symbol
|
||||
{
|
||||
size_t hval;
|
||||
SCM_VALIDATE_SYMBOL (2,s);
|
||||
if (SCM_FALSEP (o))
|
||||
return SCM_UNSPECIFIED;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
SCM_VALIDATE_VECTOR (1,o);
|
||||
hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o);
|
||||
/* If the symbol is already interned, simply return. */
|
||||
SCM_REDEFER_INTS;
|
||||
{
|
||||
SCM lsym;
|
||||
SCM sym;
|
||||
for (lsym = SCM_VECTOR_REF (o, hval);
|
||||
SCM_NIMP (lsym);
|
||||
lsym = SCM_CDR (lsym))
|
||||
{
|
||||
sym = SCM_CAR (lsym);
|
||||
if (SCM_EQ_P (SCM_CAR (sym), s))
|
||||
{
|
||||
SCM_REALLOW_INTS;
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
}
|
||||
SCM_VECTOR_SET (o, hval,
|
||||
scm_acons (s, SCM_UNDEFINED,
|
||||
SCM_VECTOR_REF (o, hval)));
|
||||
}
|
||||
SCM_REALLOW_INTS;
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
|
||||
(SCM o, SCM s),
|
||||
"Remove the symbol with name @var{string} from @var{obarray}. This\n"
|
||||
"function returns @code{#t} if the symbol was present and @code{#f}\n"
|
||||
"otherwise.")
|
||||
#define FUNC_NAME s_scm_unintern_symbol
|
||||
{
|
||||
size_t hval;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
SCM_VALIDATE_SYMBOL (2,s);
|
||||
if (SCM_FALSEP (o))
|
||||
return SCM_BOOL_F;
|
||||
SCM_VALIDATE_VECTOR (1,o);
|
||||
hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o);
|
||||
SCM_DEFER_INTS;
|
||||
{
|
||||
SCM lsym_follow;
|
||||
SCM lsym;
|
||||
SCM sym;
|
||||
for (lsym = SCM_VECTOR_REF (o, hval), lsym_follow = SCM_BOOL_F;
|
||||
SCM_NIMP (lsym);
|
||||
lsym_follow = lsym, lsym = SCM_CDR (lsym))
|
||||
{
|
||||
sym = SCM_CAR (lsym);
|
||||
if (SCM_EQ_P (SCM_CAR (sym), s))
|
||||
{
|
||||
/* Found the symbol to unintern. */
|
||||
if (SCM_FALSEP (lsym_follow))
|
||||
SCM_VECTOR_SET (o, hval, lsym);
|
||||
else
|
||||
SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
|
||||
SCM_ALLOW_INTS;
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
}
|
||||
}
|
||||
SCM_ALLOW_INTS;
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0,
|
||||
(SCM o, SCM s),
|
||||
"Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
|
||||
"return the value to which it is bound. If @var{obarray} is @code{#f},\n"
|
||||
"use the global symbol table. If @var{string} is not interned in\n"
|
||||
"@var{obarray}, an error is signalled.")
|
||||
#define FUNC_NAME s_scm_symbol_binding
|
||||
{
|
||||
SCM vcell;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
SCM_VALIDATE_SYMBOL (2,s);
|
||||
if (SCM_FALSEP (o))
|
||||
return scm_variable_ref (scm_lookup (s));
|
||||
SCM_VALIDATE_VECTOR (1,o);
|
||||
vcell = scm_sym2ovcell (s, o);
|
||||
return SCM_CDR(vcell);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
#if 0
|
||||
SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0,
|
||||
(SCM o, SCM s),
|
||||
"Return @code{#t} if @var{obarray} contains a symbol with name\n"
|
||||
"@var{string}, and @code{#f} otherwise.")
|
||||
#define FUNC_NAME s_scm_symbol_interned_p
|
||||
{
|
||||
SCM vcell;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
SCM_VALIDATE_SYMBOL (2,s);
|
||||
if (SCM_FALSEP (o))
|
||||
{
|
||||
SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
|
||||
if (var != SCM_BOOL_F)
|
||||
return SCM_BOOL_T;
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
SCM_VALIDATE_VECTOR (1,o);
|
||||
vcell = scm_sym2ovcell_soft (s, o);
|
||||
return (SCM_NIMP(vcell)
|
||||
? SCM_BOOL_T
|
||||
: SCM_BOOL_F);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
#endif
|
||||
|
||||
SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0,
|
||||
(SCM o, SCM s),
|
||||
"Return @code{#t} if @var{obarray} contains a symbol with name\n"
|
||||
"@var{string} bound to a defined value. This differs from\n"
|
||||
"@var{symbol-interned?} in that the mere mention of a symbol\n"
|
||||
"usually causes it to be interned; @code{symbol-bound?}\n"
|
||||
"determines whether a symbol has been given any meaningful\n"
|
||||
"value.")
|
||||
#define FUNC_NAME s_scm_symbol_bound_p
|
||||
{
|
||||
SCM vcell;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
|
||||
"Use hashtables instead.");
|
||||
|
||||
SCM_VALIDATE_SYMBOL (2,s);
|
||||
if (SCM_FALSEP (o))
|
||||
{
|
||||
SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
|
||||
if (SCM_VARIABLEP(var) && !SCM_UNBNDP(SCM_VARIABLE_REF(var)))
|
||||
return SCM_BOOL_T;
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
SCM_VALIDATE_VECTOR (1,o);
|
||||
vcell = scm_sym2ovcell_soft (s, o);
|
||||
return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0,
|
||||
(SCM o, SCM s, SCM v),
|
||||
"Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
|
||||
"it to @var{value}. An error is signalled if @var{string} is not present\n"
|
||||
"in @var{obarray}.")
|
||||
#define FUNC_NAME s_scm_symbol_set_x
|
||||
{
|
||||
SCM vcell;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
|
||||
"Use the module system instead.");
|
||||
|
||||
SCM_VALIDATE_SYMBOL (2,s);
|
||||
if (SCM_FALSEP (o))
|
||||
{
|
||||
scm_define (s, v);
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
SCM_VALIDATE_VECTOR (1,o);
|
||||
vcell = scm_sym2ovcell (s, o);
|
||||
SCM_SETCDR (vcell, v);
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
#define MAX_PREFIX_LENGTH 30
|
||||
|
||||
static int gentemp_counter;
|
||||
|
||||
SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
|
||||
(SCM prefix, SCM obarray),
|
||||
"Create a new symbol with a name unique in an obarray.\n"
|
||||
"The name is constructed from an optional string @var{prefix}\n"
|
||||
"and a counter value. The default prefix is @code{t}. The\n"
|
||||
"@var{obarray} is specified as a second optional argument.\n"
|
||||
"Default is the system obarray where all normal symbols are\n"
|
||||
"interned. The counter is increased by 1 at each\n"
|
||||
"call. There is no provision for resetting the counter.")
|
||||
#define FUNC_NAME s_scm_gentemp
|
||||
{
|
||||
char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
|
||||
char *name = buf;
|
||||
int len, n_digits;
|
||||
|
||||
scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
|
||||
"Use `gensym' instead.");
|
||||
|
||||
if (SCM_UNBNDP (prefix))
|
||||
{
|
||||
name[0] = 't';
|
||||
len = 1;
|
||||
}
|
||||
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);
|
||||
}
|
||||
|
||||
if (SCM_UNBNDP (obarray))
|
||||
return scm_gensym (prefix);
|
||||
else
|
||||
SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)),
|
||||
obarray,
|
||||
SCM_ARG2,
|
||||
FUNC_NAME);
|
||||
do
|
||||
n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]);
|
||||
while (!SCM_FALSEP (scm_intern_obarray_soft (name,
|
||||
len + n_digits,
|
||||
obarray,
|
||||
1)));
|
||||
{
|
||||
SCM vcell = scm_intern_obarray_soft (name,
|
||||
len + n_digits,
|
||||
obarray,
|
||||
0);
|
||||
if (name != buf)
|
||||
scm_must_free (name);
|
||||
return SCM_CAR (vcell);
|
||||
}
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
void
|
||||
scm_i_init_deprecated ()
|
||||
{
|
||||
|
|
|
|||
|
|
@ -218,6 +218,28 @@ SCM_API long scm_i_object_length (SCM);
|
|||
|
||||
#define SCM_LENGTH(x) scm_i_object_length(x)
|
||||
|
||||
#define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n))
|
||||
|
||||
SCM_API SCM scm_sym2ovcell_soft (SCM sym, SCM obarray);
|
||||
SCM_API SCM scm_sym2ovcell (SCM sym, SCM obarray);
|
||||
SCM_API SCM scm_intern_obarray_soft (const char *name, size_t len,
|
||||
SCM obarray, unsigned int softness);
|
||||
SCM_API SCM scm_intern_obarray (const char *name, size_t len, SCM obarray);
|
||||
SCM_API SCM scm_symbol_value0 (const char *name);
|
||||
|
||||
SCM_API SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp);
|
||||
SCM_API SCM scm_intern_symbol (SCM o, SCM s);
|
||||
SCM_API SCM scm_unintern_symbol (SCM o, SCM s);
|
||||
SCM_API SCM scm_symbol_binding (SCM o, SCM s);
|
||||
#if 0
|
||||
/* This name has been reused for real uninterned symbols. */
|
||||
SCM_API SCM scm_symbol_interned_p (SCM o, SCM s);
|
||||
#endif
|
||||
SCM_API SCM scm_symbol_bound_p (SCM o, SCM s);
|
||||
SCM_API SCM scm_symbol_set_x (SCM o, SCM s, SCM v);
|
||||
|
||||
SCM_API SCM scm_gentemp (SCM prefix, SCM obarray);
|
||||
|
||||
void scm_i_init_deprecated (void);
|
||||
|
||||
#endif
|
||||
|
|
@ -227,34 +249,6 @@ void scm_i_init_deprecated (void);
|
|||
#if 0
|
||||
/* TODO */
|
||||
|
||||
scm_strhash
|
||||
|
||||
scm_sym2vcell
|
||||
scm_sym2ovcell_soft
|
||||
scm_sym2ovcell
|
||||
|
||||
scm_intern_obarray_soft
|
||||
scm_intern_obarray
|
||||
scm_intern
|
||||
scm_intern0
|
||||
|
||||
scm_sysintern
|
||||
scm_sysintern0
|
||||
scm_sysintern0_no_module_lookup
|
||||
|
||||
scm_symbol_value0
|
||||
scm_string_to_obarray_symbol
|
||||
scm_intern_symbol
|
||||
|
||||
scm_unintern_symbol
|
||||
scm_symbol_binding
|
||||
scm_symbol_interned_p
|
||||
|
||||
scm_symbol_bound_p
|
||||
scm_symbol_set_x
|
||||
scm_gentemp
|
||||
|
||||
scm_init_symbols_deprecated
|
||||
scm_vector_set_length_x
|
||||
|
||||
SCM_OPDIRP
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue