diff --git a/libguile/deprecated.c b/libguile/deprecated.c index aec5fc909..18a0c24de 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -40,6 +40,7 @@ #include "libguile/read.h" #include "libguile/strports.h" #include "libguile/smob.h" +#include "libguile/alist.h" #include #include @@ -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{#}).\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 () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 4462729e5..8e02b08b8 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -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