X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/d23d13c03ca02a56c7f7f95e5712e482b320629f..0e2a38a135d92254367f680995ffab092919d266:/src/lread.c diff --git a/src/lread.c b/src/lread.c index 71ba6790a1..1413a793f0 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3120,12 +3120,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (ch < 0) end_of_file_error (); - /* If purifying, and string starts with \ newline, - return zero instead. This is for doc strings - that we are really going to find in etc/DOC.nn.nn. */ - if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel) - return make_number (0); - if (! force_multibyte && force_singlebyte) { /* READ_BUFFER contains raw 8-bit bytes and no multibyte @@ -3786,30 +3780,38 @@ check_obarray (Lisp_Object obarray) 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); +} + +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)) + { + 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)); } - + 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. @@ -3824,36 +3826,23 @@ it defaults to the value of `obarray'. */) CHECK_STRING (string); - tem = oblookup (obarray, SSDATA (string), - SCHARS (string), - SBYTES (string)); - if (SYMBOLP (tem)) - return tem; - - if (!NILP (Vpurify_flag)) - string = Fpurecopy (string); + tem = Ffind_symbol (string, obarray); + if (! NILP (scm_c_value_ref (tem, 1))) + return scm_c_value_ref (tem, 0); 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; - else - XSYMBOL (sym)->interned = SYMBOL_INTERNED; 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); } - return scm_intern (scm_from_utf8_stringn (SSDATA (string), - SBYTES (string)), - obhash (obarray)); + return sym; } DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0, @@ -3864,41 +3853,18 @@ A second optional argument specifies the obarray to use; 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); - - if (!SYMBOLP (name)) - { - CHECK_STRING (name); - string = name; - } - else - string = SYMBOL_NAME (name); + 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); - 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; } - -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)); -} DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0, doc: /* Delete the symbol named NAME, if any, from OBARRAY. @@ -3931,32 +3897,9 @@ usage: (unintern NAME OBARRAY) */) } - //XSYMBOL (tem)->interned = SYMBOL_UNINTERNED; return (scm_is_true (scm_unintern (name, obhash (obarray))) ? Qt : Qnil); } -/* 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) -{ - Lisp_Object sym; - Lisp_Object string2 = scm_from_utf8_stringn (ptr, size_byte); - - obarray = check_obarray (obarray); - sym = scm_find_symbol (string2, obhash (obarray)); - if (scm_is_true (sym) - && scm_is_true (scm_module_variable (symbol_module, sym))) - return sym; - else - return make_number (0); -} - void map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg) { @@ -4008,27 +3951,21 @@ init_obarray (void) 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. */ - Qnil = make_number (-1); Vpurify_flag = make_number (1); - Qnil = intern_c_string ("nil"); + Qnil = SCM_ELISP_NIL; + Qt = SCM_BOOL_T; - /* Fmake_symbol inits fields of new symbols with Qunbound and Qnil, - so those two need to be fixed manually. */ + Qnil_ = intern_c_string ("nil"); + SET_SYMBOL_VAL (XSYMBOL (Qnil_), Qnil); + SET_SYMBOL_CONSTANT (XSYMBOL (Qnil_), 1); + SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (Qnil_), 1); + + 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 = scm_c_public_ref ("language elisp runtime", "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; @@ -4040,14 +3977,32 @@ init_obarray (void) } 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 @@ -4061,8 +4016,8 @@ defvar_int (struct Lisp_Intfwd *i_fwd, 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); } @@ -4076,8 +4031,8 @@ defvar_bool (struct Lisp_Boolfwd *b_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); } @@ -4095,8 +4050,8 @@ defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd, 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); } @@ -4119,8 +4074,8 @@ defvar_kboard (struct Lisp_Kboard_Objfwd *ko_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); } @@ -4427,7 +4382,7 @@ to find all the symbols in an obarray, use `mapatoms'. */); 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.