#define file_tell ftell
#endif
+static SCM obarrays;
+
/* Hash table read constants. */
static Lisp_Object Qhash_table, Qdata;
static Lisp_Object Qtest, Qsize;
\f
static Lisp_Object initial_obarray;
-/* `oblookup' stores the bucket number here, for the sake of Funintern. */
-
-static size_t oblookup_last_bucket_number;
+Lisp_Object
+obhash (Lisp_Object obarray)
+{
+ Lisp_Object tem = scm_hashq_get_handle (obarrays, obarray);
+ if (SCM_UNLIKELY (scm_is_false (tem)))
+ tem = scm_hashq_create_handle_x (obarrays, obarray,
+ scm_make_obarray ());
+ return scm_cdr (tem);
+}
/* Get an error if OBARRAY is not an obarray.
If it is one, return it. */
Lisp_Object
intern_1 (const char *str, ptrdiff_t len)
{
- Lisp_Object obarray = check_obarray (Vobarray);
- Lisp_Object tem = oblookup (obarray, str, len, len);
-
- return SYMBOLP (tem) ? tem : Fintern (make_string (str, len), obarray);
+ return Fintern (make_string (str, len), Qnil);
}
Lisp_Object
intern_c_string_1 (const char *str, ptrdiff_t len)
{
- Lisp_Object obarray = check_obarray (Vobarray);
- Lisp_Object tem = oblookup (obarray, str, len, len);
-
- if (SYMBOLP (tem))
- return tem;
+ return Fintern (make_pure_c_string (str, len), Qnil);
+}
+\f
+DEFUN ("find-symbol", Ffind_symbol, Sfind_symbol, 1, 2, 0,
+ doc: /* find-symbol */)
+ (Lisp_Object string, Lisp_Object obarray)
+{
+ Lisp_Object tem, sstring, found;
- if (NILP (Vpurify_flag))
- /* Creating a non-pure string from a string literal not
- implemented yet. We could just use make_string here and live
- with the extra copy. */
- emacs_abort ();
+ obarray = check_obarray (NILP (obarray) ? Vobarray : obarray);
+ CHECK_STRING (string);
- return Fintern (make_pure_c_string (str, len), obarray);
+ sstring = scm_from_utf8_stringn (SSDATA (string), SBYTES (string));
+ tem = scm_find_symbol (sstring, obhash (obarray));
+ if (scm_is_true (tem)
+ && scm_is_true (scm_module_variable (symbol_module, tem)))
+ {
+ if (EQ (tem, Qnil_))
+ tem = Qnil;
+ else if (EQ (tem, Qt_))
+ tem = Qt;
+ return scm_values (scm_list_2 (tem, Qt));
+ }
+ else
+ return scm_values (scm_list_2 (Qnil, Qnil));
}
-\f
+
DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
doc: /* Return the canonical symbol whose name is STRING.
If there is none, one is created by this function and returned.
CHECK_STRING (string);
- tem = oblookup (obarray, SSDATA (string),
- SCHARS (string),
- SBYTES (string));
- if (!INTEGERP (tem))
- return tem;
+ tem = Ffind_symbol (string, obarray);
+ if (! NILP (scm_c_value_ref (tem, 1)))
+ return scm_c_value_ref (tem, 0);
- if (!NILP (Vpurify_flag))
- string = Fpurecopy (string);
- sym = Fmake_symbol (string);
-
- if (EQ (obarray, initial_obarray))
- XSYMBOL (sym)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
- else
- XSYMBOL (sym)->interned = SYMBOL_INTERNED;
+ sym = scm_intern (scm_from_utf8_stringn (SSDATA (string),
+ SBYTES (string)),
+ obhash (obarray));
+ initialize_symbol (sym, string);
if ((SREF (string, 0) == ':')
&& EQ (obarray, initial_obarray))
{
- XSYMBOL (sym)->constant = 1;
- XSYMBOL (sym)->redirect = SYMBOL_PLAINVAL;
+ SET_SYMBOL_CONSTANT (XSYMBOL (sym), 1);
+ SET_SYMBOL_REDIRECT (XSYMBOL (sym), SYMBOL_PLAINVAL);
SET_SYMBOL_VAL (XSYMBOL (sym), sym);
}
- ptr = aref_addr (obarray, XINT (tem));
- if (SYMBOLP (*ptr))
- set_symbol_next (sym, XSYMBOL (*ptr));
- else
- set_symbol_next (sym, NULL);
- *ptr = sym;
return sym;
}
it defaults to the value of `obarray'. */)
(Lisp_Object name, Lisp_Object obarray)
{
- register Lisp_Object tem, string;
+ register Lisp_Object tem, string, mv, found;
- if (NILP (obarray)) obarray = Vobarray;
- obarray = check_obarray (obarray);
+ string = SYMBOLP (name) ? SYMBOL_NAME (name) : name;
+ mv = Ffind_symbol (string, obarray);
+ tem = scm_c_value_ref (mv, 0);
+ found = scm_c_value_ref (mv, 1);
- if (!SYMBOLP (name))
- {
- CHECK_STRING (name);
- string = name;
- }
- else
- string = SYMBOL_NAME (name);
-
- tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
- if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
+ if (NILP (found) || (SYMBOLP (name) && !EQ (name, tem)))
return Qnil;
else
return tem;
usage: (unintern NAME OBARRAY) */)
(Lisp_Object name, Lisp_Object obarray)
{
- register Lisp_Object string, tem;
- size_t hash;
+ Lisp_Object string;
+ Lisp_Object tem;
- if (NILP (obarray)) obarray = Vobarray;
+ if (NILP (obarray))
+ obarray = Vobarray;
obarray = check_obarray (obarray);
if (SYMBOLP (name))
- string = SYMBOL_NAME (name);
- else
- {
- CHECK_STRING (name);
- string = name;
- }
-
- tem = oblookup (obarray, SSDATA (string),
- SCHARS (string),
- SBYTES (string));
- if (INTEGERP (tem))
- return Qnil;
- /* If arg was a symbol, don't delete anything but that symbol itself. */
- if (SYMBOLP (name) && !EQ (name, tem))
- return Qnil;
-
- /* There are plenty of other symbols which will screw up the Emacs
- session if we unintern them, as well as even more ways to use
- `setq' or `fset' or whatnot to make the Emacs session
- unusable. Let's not go down this silly road. --Stef */
- /* if (EQ (tem, Qnil) || EQ (tem, Qt))
- error ("Attempt to unintern t or nil"); */
-
- XSYMBOL (tem)->interned = SYMBOL_UNINTERNED;
-
- hash = oblookup_last_bucket_number;
-
- if (EQ (AREF (obarray, hash), tem))
{
- if (XSYMBOL (tem)->next)
- {
- Lisp_Object sym;
- XSETSYMBOL (sym, XSYMBOL (tem)->next);
- ASET (obarray, hash, sym);
- }
- else
- ASET (obarray, hash, make_number (0));
+ if (! EQ (name,
+ scm_find_symbol (scm_symbol_to_string (name),
+ obhash (obarray))))
+ return Qnil;
+ string = SYMBOL_NAME (name);
}
else
{
- Lisp_Object tail, following;
-
- for (tail = AREF (obarray, hash);
- XSYMBOL (tail)->next;
- tail = following)
- {
- XSETSYMBOL (following, XSYMBOL (tail)->next);
- if (EQ (following, tem))
- {
- set_symbol_next (tail, XSYMBOL (following)->next);
- break;
- }
- }
+ CHECK_STRING (name);
+ string = name;
+
}
- return Qt;
-}
-\f
-/* Return the symbol in OBARRAY whose names matches the string
- of SIZE characters (SIZE_BYTE bytes) at PTR.
- If there is no such symbol, return the integer bucket number of
- where the symbol would be if it were present.
-
- Also store the bucket number in oblookup_last_bucket_number. */
-
-Lisp_Object
-oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff_t size_byte)
-{
- size_t hash;
- size_t obsize;
- register Lisp_Object tail;
- Lisp_Object bucket, tem;
-
- obarray = check_obarray (obarray);
- obsize = ASIZE (obarray);
- hash = hash_string (ptr, size_byte) % obsize;
- bucket = AREF (obarray, hash);
- oblookup_last_bucket_number = hash;
- if (EQ (bucket, make_number (0)))
- ;
- else if (!SYMBOLP (bucket))
- error ("Bad data in guts of obarray"); /* Like CADR error message. */
- else
- for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
- {
- if (SBYTES (SYMBOL_NAME (tail)) == size_byte
- && SCHARS (SYMBOL_NAME (tail)) == size
- && !memcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
- return tail;
- else if (XSYMBOL (tail)->next == 0)
- break;
- }
- XSETINT (tem, hash);
- return tem;
+ return (scm_is_true (scm_unintern (name, obhash (obarray))) ? Qt : Qnil);
}
\f
void
map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
{
- ptrdiff_t i;
- register Lisp_Object tail;
+ Lisp_Object proc (Lisp_Object sym)
+ {
+ Lisp_Object tem = Ffind_symbol (SYMBOL_NAME (sym), obarray);
+ if (scm_is_true (scm_c_value_ref (tem, 1))
+ && EQ (sym, scm_c_value_ref (tem, 0)))
+ fn (sym, arg);
+ return SCM_UNSPECIFIED;
+ }
CHECK_VECTOR (obarray);
- for (i = ASIZE (obarray) - 1; i >= 0; i--)
- {
- tail = AREF (obarray, i);
- if (SYMBOLP (tail))
- while (1)
- {
- (*fn) (tail, arg);
- if (XSYMBOL (tail)->next == 0)
- break;
- XSETSYMBOL (tail, XSYMBOL (tail)->next);
- }
- }
+ scm_obarray_for_each (scm_c_make_gsubr ("proc", 1, 0, 0, proc),
+ obhash (obarray));
}
static void
initial_obarray = Vobarray;
staticpro (&initial_obarray);
- Qunbound = Fmake_symbol (build_pure_c_string ("unbound"));
- /* Set temporary dummy values to Qnil and Vpurify_flag to satisfy the
- NILP (Vpurify_flag) check in intern_c_string. */
- Qnil = make_number (-1); Vpurify_flag = make_number (1);
- Qnil = intern_c_string ("nil");
+ obarrays = scm_make_hash_table (SCM_UNDEFINED);
+ scm_hashq_set_x (obarrays, Vobarray, SCM_UNDEFINED);
+
+ Qnil = SCM_ELISP_NIL;
+ Qt = SCM_BOOL_T;
+
+ Qnil_ = intern_c_string ("nil");
+ SET_SYMBOL_VAL (XSYMBOL (Qnil_), Qnil);
+ SET_SYMBOL_CONSTANT (XSYMBOL (Qnil_), 1);
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (Qnil_), 1);
- /* Fmake_symbol inits fields of new symbols with Qunbound and Qnil,
- so those two need to be fixed manually. */
+ Qt_ = intern_c_string ("t");
+ SET_SYMBOL_VAL (XSYMBOL (Qt_), Qt);
+ SET_SYMBOL_CONSTANT (XSYMBOL (Qt_), 1);
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (Qt_), 1);
+
+ Qunbound = Fmake_symbol (build_pure_c_string ("unbound"));
SET_SYMBOL_VAL (XSYMBOL (Qunbound), Qunbound);
- set_symbol_function (Qunbound, Qnil);
- set_symbol_plist (Qunbound, Qnil);
- SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil);
- XSYMBOL (Qnil)->constant = 1;
- XSYMBOL (Qnil)->declared_special = 1;
- set_symbol_plist (Qnil, Qnil);
- set_symbol_function (Qnil, Qnil);
-
- Qt = intern_c_string ("t");
- SET_SYMBOL_VAL (XSYMBOL (Qt), Qt);
- XSYMBOL (Qnil)->declared_special = 1;
- XSYMBOL (Qt)->constant = 1;
/* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
Vpurify_flag = Qt;
}
\f
void
-defsubr (struct Lisp_Subr *sname)
+defsubr (const char *lname, scm_t_subr gsubr_fn, short min_args, short max_args, const char *intspec)
{
- Lisp_Object sym, tem;
- sym = intern_c_string (sname->symbol_name);
- SCM_NEWSMOB (sname->header.self, lisp_vectorlike_tag, sname);
- XSETPVECTYPE (sname, PVEC_SUBR);
- XSETSUBR (tem, sname);
- set_symbol_function (sym, tem);
+ Lisp_Object sym = intern_c_string (lname);
+ Lisp_Object fn;
+ switch (max_args)
+ {
+ case MANY:
+ fn = scm_c_make_gsubr (lname, 0, 0, 1, gsubr_fn);
+ break;
+ case UNEVALLED:
+ fn = Fcons (Qspecial_operator,
+ scm_c_make_gsubr (lname, 0, 0, 1, gsubr_fn));
+ break;
+ default:
+ fn = scm_c_make_gsubr (lname, min_args, max_args - min_args, 0, gsubr_fn);
+ break;
+ }
+ set_symbol_function (sym, fn);
+ if (intspec)
+ {
+ Lisp_Object tem = ((*intspec != '(')
+ ? build_string (intspec)
+ : Fcar (Fread_from_string (build_string (intspec),
+ Qnil, Qnil)));
+ scm_set_procedure_property_x (fn, Qinteractive_form, tem);
+ }
}
/* Define an "integer variable"; a symbol whose value is forwarded to a
sym = intern_c_string (namestring);
i_fwd->type = Lisp_Fwd_Int;
i_fwd->intvar = address;
- XSYMBOL (sym)->declared_special = 1;
- XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (sym), 1);
+ SET_SYMBOL_REDIRECT (XSYMBOL (sym), SYMBOL_FORWARDED);
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd);
}
sym = intern_c_string (namestring);
b_fwd->type = Lisp_Fwd_Bool;
b_fwd->boolvar = address;
- XSYMBOL (sym)->declared_special = 1;
- XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (sym), 1);
+ SET_SYMBOL_REDIRECT (XSYMBOL (sym), SYMBOL_FORWARDED);
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd);
Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
}
sym = intern_c_string (namestring);
o_fwd->type = Lisp_Fwd_Obj;
o_fwd->objvar = address;
- XSYMBOL (sym)->declared_special = 1;
- XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (sym), 1);
+ SET_SYMBOL_REDIRECT (XSYMBOL (sym), SYMBOL_FORWARDED);
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd);
}
sym = intern_c_string (namestring);
ko_fwd->type = Lisp_Fwd_Kboard_Obj;
ko_fwd->offset = offset;
- XSYMBOL (sym)->declared_special = 1;
- XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (sym), 1);
+ SET_SYMBOL_REDIRECT (XSYMBOL (sym), SYMBOL_FORWARDED);
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd);
}
\f
DEFVAR_LISP ("values", Vvalues,
doc: /* List of values of all expressions which were read, evaluated and printed.
Order is reverse chronological. */);
- XSYMBOL (intern ("values"))->declared_special = 0;
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (intern ("values")), 0);
DEFVAR_LISP ("standard-input", Vstandard_input,
doc: /* Stream for read to get input from.