XSYMBOL (sym)->name = name;
}
-DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
- doc: /* Return a newly allocated uninterned symbol whose name is NAME.
-Its value is void, and its function definition and property list are nil. */)
- (Lisp_Object name)
+void
+initialize_symbol (Lisp_Object val, Lisp_Object name)
{
- register Lisp_Object val;
- register struct Lisp_Symbol *p;
-
- CHECK_STRING (name);
+ struct Lisp_Symbol *p = xmalloc (sizeof *p);
- p = xmalloc (sizeof *p);
- SCM_NEWSMOB (p->self, lisp_symbol_tag, p);
- XSETSYMBOL (val, p);
+ scm_module_define (symbol_module, val, scm_from_pointer (p, NULL));
p = XSYMBOL (val);
+ p->self = val;
set_symbol_name (val, name);
set_symbol_plist (val, Qnil);
p->redirect = SYMBOL_PLAINVAL;
SET_SYMBOL_VAL (p, Qunbound);
set_symbol_function (val, Qnil);
- set_symbol_next (val, NULL);
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
p->declared_special = false;
- p->pinned = false;
+}
+
+DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
+ doc: /* Return a newly allocated uninterned symbol whose name is NAME.
+Its value is void, and its function definition and property list are nil. */)
+ (Lisp_Object name)
+{
+ register Lisp_Object val;
+
+ CHECK_STRING (name);
+
+ val = scm_make_symbol (scm_from_utf8_stringn (SSDATA (name),
+ SBYTES (name)));
+ initialize_symbol (val, name);
return val;
}
void
init_alloc_once (void)
{
- lisp_symbol_tag = scm_make_smob_type ("elisp-symbol", 0);
lisp_misc_tag = scm_make_smob_type ("elisp-misc", 0);
lisp_string_tag = scm_make_smob_type ("elisp-string", 0);
lisp_vectorlike_tag = scm_make_smob_type ("elisp-vectorlike", 0);
#define lisp_h_SYMBOL_CONSTANT_P(sym) (XSYMBOL (sym)->constant)
#define lisp_h_SYMBOL_VAL(sym) \
(eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value)
-#define lisp_h_SYMBOLP(x) (SMOB_TYPEP (x, lisp_symbol_tag))
+#define lisp_h_SYMBOLP(x) (x && scm_is_symbol (x))
#define lisp_h_VECTORLIKEP(x) (SMOB_TYPEP (x, lisp_vectorlike_tag))
#define lisp_h_XCAR(c) (scm_car (c))
#define lisp_h_XCDR(c) (scm_cdr (c))
#define lisp_h_XHASH(a) (SCM_UNPACK (a))
-#define lisp_h_XSYMBOL(a) \
- (eassert (SYMBOLP (a)), (struct Lisp_Symbol *) SMOB_PTR (a))
-
-/* When compiling via gcc -O0, define the key operations as macros, as
- Emacs is too slow otherwise. To disable this optimization, compile
- with -DINLINING=false. */
-#if 0
-#if (defined __NO_INLINE__ \
- && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__ \
- && ! (defined INLINING && ! INLINING))
-# define XLI(o) lisp_h_XLI (o)
-# define XIL(i) lisp_h_XIL (i)
-# define CHECK_LIST_CONS(x, y) lisp_h_CHECK_LIST_CONS (x, y)
-# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x)
-# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
-# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
-# define CONSP(x) lisp_h_CONSP (x)
-# define EQ(x, y) lisp_h_EQ (x, y)
-# define FLOATP(x) lisp_h_FLOATP (x)
-# define INTEGERP(x) lisp_h_INTEGERP (x)
-# define MARKERP(x) lisp_h_MARKERP (x)
-# define MISCP(x) lisp_h_MISCP (x)
-# define NILP(x) lisp_h_NILP (x)
-# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v)
-# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
-# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
-# define SYMBOLP(x) lisp_h_SYMBOLP (x)
-# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
-# define XCAR(c) lisp_h_XCAR (c)
-# define XCDR(c) lisp_h_XCDR (c)
-# define XHASH(a) lisp_h_XHASH (a)
-# define XSYMBOL(a) lisp_h_XSYMBOL (a)
-#endif
-#endif
/* Define NAME as a lisp.h inline function that returns TYPE and has
arguments declared as ARGDECLS and passed as ARGS. ARGDECLS and
#define ENUM_BF(TYPE) enum TYPE
#endif
-scm_t_bits lisp_symbol_tag;
scm_t_bits lisp_misc_tag;
scm_t_bits lisp_string_tag;
scm_t_bits lisp_vectorlike_tag;
return SMOB_PTR (a);
}
-LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a))
+extern void initialize_symbol (Lisp_Object, Lisp_Object);
+INLINE Lisp_Object build_string (const char *);
+extern Lisp_Object symbol_module;
+
+INLINE struct Lisp_Symbol *
+XSYMBOL (Lisp_Object a)
+{
+ Lisp_Object tem;
+ eassert (SYMBOLP (a));
+ tem = scm_variable_ref (scm_module_lookup (symbol_module, a));
+ return scm_to_pointer (tem);
+}
/* Pseudovector types. */
/* The symbol's property list. */
Lisp_Object plist;
-
- /* Next symbol in obarray bucket, if the symbol is interned. */
- struct Lisp_Symbol *next;
};
/* Value is name of symbol. */
XSYMBOL (sym)->plist = plist;
}
-INLINE void
-set_symbol_next (Lisp_Object sym, struct Lisp_Symbol *next)
-{
- XSYMBOL (sym)->next = next;
-}
-
/* Buffer-local (also frame-local) variable access functions. */
INLINE int
extern Lisp_Object check_obarray (Lisp_Object);
extern Lisp_Object intern_1 (const char *, ptrdiff_t);
extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t);
+extern Lisp_Object obhash (Lisp_Object);
extern Lisp_Object oblookup (Lisp_Object, const char *, ptrdiff_t, ptrdiff_t);
INLINE void
LOADHIST_ATTACH (Lisp_Object x)
#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. */
tem = oblookup (obarray, SSDATA (string),
SCHARS (string),
SBYTES (string));
- if (!INTEGERP (tem))
+ if (SYMBOLP (tem))
return tem;
if (!NILP (Vpurify_flag))
string = Fpurecopy (string);
- sym = Fmake_symbol (string);
+
+ sym = scm_intern (scm_from_utf8_stringn (SSDATA (string),
+ SBYTES (string)),
+ obhash (obarray));
+ initialize_symbol (sym, string);
if (EQ (obarray, initial_obarray))
XSYMBOL (sym)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
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;
+ return scm_intern (scm_from_utf8_stringn (SSDATA (string),
+ SBYTES (string)),
+ obhash (obarray));
}
DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
else
return tem;
}
+
+DEFUN ("find-symbol", Ffind_symbol, Sfind_symbol, 1, 2, 0,
+ doc: /* find-symbol */)
+ (Lisp_Object string, Lisp_Object obarray)
+{
+ Lisp_Object tem;
+
+ obarray = check_obarray (NILP (obarray) ? Vobarray : obarray);
+ CHECK_STRING (string);
+
+ tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
+ if (INTEGERP (tem))
+ return scm_values (scm_list_2 (Qnil, Qnil));
+ else
+ return scm_values (scm_list_2 (tem, Qt));
+}
\f
DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
doc: /* Delete the symbol named NAME, if any, from OBARRAY.
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;
+ //XSYMBOL (tem)->interned = SYMBOL_UNINTERNED;
+ return (scm_is_true (scm_unintern (name, obhash (obarray))) ? Qt : Qnil);
}
\f
/* Return the symbol in OBARRAY whose names matches the string
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;
+ Lisp_Object sym;
+ Lisp_Object string2 = scm_from_utf8_stringn (ptr, size_byte);
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. */
+ sym = scm_find_symbol (string2, obhash (obarray));
+ if (scm_is_true (sym)
+ && scm_is_true (scm_module_variable (symbol_module, sym)))
+ return sym;
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 make_number (0);
}
\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);
+ obarrays = scm_make_hash_table (SCM_UNDEFINED);
+ scm_hashq_set_x (obarrays, Vobarray, SCM_UNDEFINED);
+
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. */
HCoop / bpt / emacs.git / commitdiff