X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/015936fba1bcaa51b7886a73144d4c088200c0aa..7b13da3a152435d33eb7398cffb9f770fe28780d:/src/lread.c diff --git a/src/lread.c b/src/lread.c index 4edd1177fb..fe285addbd 100644 --- a/src/lread.c +++ b/src/lread.c @@ -64,6 +64,8 @@ along with GNU Emacs. If not, see . */ #define file_tell ftell #endif +static SCM obarrays; + /* Hash table read constants. */ static Lisp_Object Qhash_table, Qdata; static Lisp_Object Qtest, Qsize; @@ -213,7 +215,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) else { c = BUF_FETCH_BYTE (inbuffer, pt_byte); - if (! ASCII_BYTE_P (c)) + if (! ASCII_CHAR_P (c)) c = BYTE8_TO_CHAR (c); pt_byte++; } @@ -242,7 +244,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) else { c = BUF_FETCH_BYTE (inbuffer, bytepos); - if (! ASCII_BYTE_P (c)) + if (! ASCII_CHAR_P (c)) c = BYTE8_TO_CHAR (c); bytepos++; } @@ -324,7 +326,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) return c; if (multibyte) *multibyte = 1; - if (ASCII_BYTE_P (c)) + if (ASCII_CHAR_P (c)) return c; if (emacs_mule_encoding) return read_emacs_mule_char (c, readbyte, readcharfun); @@ -1046,10 +1048,9 @@ Return t if the file exists and loads successfully. */) (Lisp_Object file, Lisp_Object noerror, Lisp_Object nomessage, Lisp_Object nosuffix, Lisp_Object must_suffix) { - FILE *stream; + FILE *stream = NULL; int fd; - int fd_index; - ptrdiff_t count = SPECPDL_INDEX (); + dynwind_begin (); struct gcpro gcpro1, gcpro2, gcpro3; Lisp_Object found, efound, hist_file_name; /* True means we printed the ".el is newer" message. */ @@ -1085,8 +1086,10 @@ Return t if the file exists and loads successfully. */) { file = internal_condition_case_1 (Fsubstitute_in_file_name, file, Qt, load_error_handler); - if (NILP (file)) - return Qnil; + if (NILP (file)) { + dynwind_end (); + return Qnil; + } } else file = Fsubstitute_in_file_name (file); @@ -1142,6 +1145,7 @@ Return t if the file exists and loads successfully. */) { if (NILP (noerror)) report_file_error ("Cannot open load file", file); + dynwind_end (); return Qnil; } @@ -1159,8 +1163,10 @@ Return t if the file exists and loads successfully. */) handler = Ffind_file_name_handler (found, Qt); else handler = Ffind_file_name_handler (found, Qload); - if (! NILP (handler)) - return call5 (handler, Qload, found, noerror, nomessage, Qt); + if (! NILP (handler)) { + dynwind_end (); + return call5 (handler, Qload, found, noerror, nomessage, Qt); + } #ifdef DOS_NT /* Tramp has to deal with semi-broken packages that prepend drive letters to remote files. For that reason, Tramp @@ -1179,15 +1185,10 @@ Return t if the file exists and loads successfully. */) #endif } - if (fd < 0) - { - /* Pacify older GCC with --enable-gcc-warnings. */ - IF_LINT (fd_index = 0); - } - else + if (fd >= 0) { - fd_index = SPECPDL_INDEX (); - record_unwind_protect_int (close_file_unwind, fd); + record_unwind_protect_ptr (close_file_ptr_unwind, &fd); + record_unwind_protect_ptr (fclose_ptr_unwind, &stream); } /* Check if we're stuck in a recursive load cycle. @@ -1300,12 +1301,13 @@ Return t if the file exists and loads successfully. */) if (fd >= 0) { emacs_close (fd); - clear_unwind_protect (fd_index); + fd = -1; } val = call4 (Vload_source_file_function, found, hist_file_name, NILP (noerror) ? Qnil : Qt, (NILP (nomessage) || force_load_messages) ? Qnil : Qt); - return unbind_to (count, val); + dynwind_end (); + return val; } } @@ -1323,7 +1325,7 @@ Return t if the file exists and loads successfully. */) { #ifdef WINDOWSNT emacs_close (fd); - clear_unwind_protect (fd_index); + fd = -1; efound = ENCODE_FILE (found); stream = emacs_fopen (SSDATA (efound), fmode); #else @@ -1332,7 +1334,6 @@ Return t if the file exists and loads successfully. */) } if (! stream) report_file_error ("Opening stdio stream", file); - set_unwind_protect_ptr (fd_index, fclose_unwind, stream); if (! NILP (Vpurify_flag)) Vpreloaded_file_list = Fcons (Fpurecopy (file), Vpreloaded_file_list); @@ -1370,7 +1371,7 @@ Return t if the file exists and loads successfully. */) readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, 0, Qnil, Qnil, Qnil, Qnil); } - unbind_to (count, Qnil); + dynwind_end (); /* Run any eval-after-load forms for this file. */ if (!NILP (Ffboundp (Qdo_after_load_evaluation))) @@ -1803,7 +1804,7 @@ readevalloop (Lisp_Object readcharfun, { register int c; register Lisp_Object val; - ptrdiff_t count = SPECPDL_INDEX (); + dynwind_begin (); struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; struct buffer *b = 0; bool continue_reading_p; @@ -1812,17 +1813,12 @@ readevalloop (Lisp_Object readcharfun, bool whole_buffer = 0; /* True on the first time around. */ bool first_sexp = 1; - Lisp_Object macroexpand = intern ("internal-macroexpand-for-load"); - - if (NILP (Ffboundp (macroexpand)) - /* Don't macroexpand in .elc files, since it should have been done - already. We actually don't know whether we're in a .elc file or not, - so we use circumstantial evidence: .el files normally go through - Vload_source_file_function -> load-with-code-conversion - -> eval-buffer. */ - || EQ (readcharfun, Qget_file_char) - || EQ (readcharfun, Qget_emacs_mule_file_char)) - macroexpand = Qnil; + Lisp_Object form = Fcons (Qprogn, Qnil); + Lisp_Object tail = form; + Lisp_Object compile_fn = 0; + + if (SCM_UNLIKELY (! compile_fn)) + compile_fn = scm_c_public_ref ("language elisp runtime", "compile-elisp"); if (MARKERP (readcharfun)) { @@ -1865,7 +1861,7 @@ readevalloop (Lisp_Object readcharfun, continue_reading_p = 1; while (continue_reading_p) { - ptrdiff_t count1 = SPECPDL_INDEX (); + dynwind_begin (); if (b != 0 && !BUFFER_LIVE_P (b)) error ("Reading from killed buffer"); @@ -1908,7 +1904,7 @@ readevalloop (Lisp_Object readcharfun, } if (c < 0) { - unbind_to (count1, Qnil); + dynwind_end (); break; } @@ -1949,32 +1945,27 @@ readevalloop (Lisp_Object readcharfun, start = Fpoint_marker (); /* Restore saved point and BEGV. */ - unbind_to (count1, Qnil); - - /* Now eval what we just read. */ - if (!NILP (macroexpand)) - val = readevalloop_eager_expand_eval (val, macroexpand); - else - val = eval_sub (val); + dynwind_end (); - if (printflag) - { - Vvalues = Fcons (val, Vvalues); - if (EQ (Vstandard_output, Qt)) - Fprin1 (val, Qnil); - else - Fprint (val, Qnil); - } + tail = Fsetcdr (tail, Fcons (val, Qnil)); first_sexp = 0; } + val = eval_sub (form); + + if (SCM_UNLIKELY (printflag)) + { + Vvalues = Fcons (val, Vvalues); + Fprin1 (val, Qnil); + } + build_load_history (sourcename, stream || whole_buffer); UNGCPRO; - unbind_to (count, Qnil); + dynwind_end (); } DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5, "", @@ -1993,7 +1984,7 @@ DO-ALLOW-PRINT, if non-nil, specifies that `print' and related This function preserves the position of point. */) (Lisp_Object buffer, Lisp_Object printflag, Lisp_Object filename, Lisp_Object unibyte, Lisp_Object do_allow_print) { - ptrdiff_t count = SPECPDL_INDEX (); + dynwind_begin (); Lisp_Object tem, buf; if (NILP (buffer)) @@ -2018,7 +2009,7 @@ This function preserves the position of point. */) specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil); readevalloop (buf, 0, filename, !NILP (printflag), unibyte, Qnil, Qnil, Qnil); - unbind_to (count, Qnil); + dynwind_end (); return Qnil; } @@ -2038,7 +2029,7 @@ This function does not move point. */) (Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function) { /* FIXME: Do the eval-sexp-add-defvars dance! */ - ptrdiff_t count = SPECPDL_INDEX (); + dynwind_begin (); Lisp_Object tem, cbuf; cbuf = Fcurrent_buffer (); @@ -2055,7 +2046,8 @@ This function does not move point. */) !NILP (printflag), Qnil, read_function, start, end); - return unbind_to (count, Qnil); + dynwind_end (); + return Qnil; } @@ -2635,7 +2627,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) XSETPVECTYPE (XVECTOR (tmp), PVEC_SUB_CHAR_TABLE); return tmp; } - invalid_syntax ("#^^"); + invalid_syntax ("#^" "^"); } invalid_syntax ("#^"); } @@ -2778,7 +2770,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (saved_doc_string_size == 0) { - saved_doc_string = xmalloc (nskip + extra); + saved_doc_string = xmalloc_atomic (nskip + extra); saved_doc_string_size = nskip + extra; } if (nskip > saved_doc_string_size) @@ -3118,12 +3110,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 @@ -3307,58 +3293,52 @@ substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Obj /* Recurse according to subtree's type. Every branch must return a Lisp_Object. */ - switch (XTYPE (subtree)) + if (VECTORLIKEP (subtree)) { - case Lisp_Vectorlike: - { - ptrdiff_t i, length = 0; - if (BOOL_VECTOR_P (subtree)) - return subtree; /* No sub-objects anyway. */ - else if (CHAR_TABLE_P (subtree) || SUB_CHAR_TABLE_P (subtree) - || COMPILEDP (subtree) || HASH_TABLE_P (subtree)) - length = ASIZE (subtree) & PSEUDOVECTOR_SIZE_MASK; - else if (VECTORP (subtree)) - length = ASIZE (subtree); - else - /* An unknown pseudovector may contain non-Lisp fields, so we - can't just blindly traverse all its fields. We used to call - `Flength' which signaled `sequencep', so I just preserved this - behavior. */ - wrong_type_argument (Qsequencep, subtree); - - for (i = 0; i < length; i++) - SUBSTITUTE (AREF (subtree, i), - ASET (subtree, i, true_value)); - return subtree; - } - - case Lisp_Cons: - { - SUBSTITUTE (XCAR (subtree), - XSETCAR (subtree, true_value)); - SUBSTITUTE (XCDR (subtree), - XSETCDR (subtree, true_value)); - return subtree; - } - - case Lisp_String: - { - /* Check for text properties in each interval. - substitute_in_interval contains part of the logic. */ - - INTERVAL root_interval = string_intervals (subtree); - Lisp_Object arg = Fcons (object, placeholder); + ptrdiff_t i, length = 0; + if (BOOL_VECTOR_P (subtree)) + return subtree; /* No sub-objects anyway. */ + else if (CHAR_TABLE_P (subtree) || SUB_CHAR_TABLE_P (subtree) + || COMPILEDP (subtree) || HASH_TABLE_P (subtree)) + length = ASIZE (subtree) & PSEUDOVECTOR_SIZE_MASK; + else if (VECTORP (subtree)) + length = ASIZE (subtree); + else + /* An unknown pseudovector may contain non-Lisp fields, so we + can't just blindly traverse all its fields. We used to call + `Flength' which signaled `sequencep', so I just preserved this + behavior. */ + wrong_type_argument (Qsequencep, subtree); + + for (i = 0; i < length; i++) + SUBSTITUTE (AREF (subtree, i), + ASET (subtree, i, true_value)); + return subtree; + } + else if (CONSP (subtree)) + { + SUBSTITUTE (XCAR (subtree), + XSETCAR (subtree, true_value)); + SUBSTITUTE (XCDR (subtree), + XSETCDR (subtree, true_value)); + return subtree; + } + else if (STRINGP (subtree)) + { + /* Check for text properties in each interval. + substitute_in_interval contains part of the logic. */ - traverse_intervals_noorder (root_interval, - &substitute_in_interval, arg); + INTERVAL root_interval = string_intervals (subtree); + Lisp_Object arg = Fcons (object, placeholder); - return subtree; - } + traverse_intervals_noorder (root_interval, + &substitute_in_interval, arg); - /* Other types don't recurse any further. */ - default: return subtree; } + else + /* Other types don't recurse any further. */ + return subtree; } /* Helper function for substitute_object_recurse. */ @@ -3537,7 +3517,6 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) ptrdiff_t i, size; Lisp_Object *ptr; Lisp_Object tem, item, vector; - struct Lisp_Cons *otem; Lisp_Object len; tem = read_list (1, readcharfun); @@ -3582,10 +3561,8 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) if (!CONSP (item)) error ("Invalid byte code"); - otem = XCONS (item); bytestr = XCAR (item); item = XCDR (item); - free_cons (otem); } /* Now handle the bytecode slot. */ @@ -3602,9 +3579,7 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) } } ASET (vector, i, item); - otem = XCONS (tem); tem = Fcdr (tem); - free_cons (otem); } return vector; } @@ -3764,9 +3739,15 @@ read_list (bool flag, Lisp_Object readcharfun) 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. */ @@ -3789,30 +3770,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. @@ -3827,35 +3816,22 @@ it defaults to the value of `obarray'. */) CHECK_STRING (string); - tem = oblookup (obarray, SSDATA (string), - SCHARS (string), - SBYTES (string)); - if (!INTEGERP (tem)) - return tem; - - if (!NILP (Vpurify_flag)) - string = Fpurecopy (string); - sym = Fmake_symbol (string); + tem = Ffind_symbol (string, obarray); + if (! NILP (scm_c_value_ref (tem, 1))) + return scm_c_value_ref (tem, 0); - 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)); 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; } @@ -3867,21 +3843,14 @@ 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; - - if (NILP (obarray)) obarray = Vobarray; - obarray = check_obarray (obarray); + register Lisp_Object tem, string, mv, found; - 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; @@ -3896,130 +3865,45 @@ OBARRAY, if nil, defaults to the value of the variable `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; -} - -/* 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); - - /* This is sometimes needed in the middle of GC. */ - obsize &= ~ARRAY_MARK_FLAG; - 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); } 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 @@ -4054,56 +3938,62 @@ init_obarray (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; - /* 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; DEFSYM (Qvariable_documentation, "variable-documentation"); - read_buffer = xmalloc (size); + read_buffer = xmalloc_atomic (size); read_buffer_size = size; } void -defsubr (struct Lisp_Subr *sname) -{ - Lisp_Object sym, tem; - sym = intern_c_string (sname->symbol_name); - XSETPVECTYPE (sname, PVEC_SUBR); - XSETSUBR (tem, sname); - set_symbol_function (sym, tem); -} - -#ifdef NOTDEF /* Use fset in subr.el now! */ -void -defalias (struct Lisp_Subr *sname, char *string) +defsubr (const char *lname, scm_t_subr gsubr_fn, short min_args, short max_args, const char *intspec) { - Lisp_Object sym; - sym = intern (string); - XSETSUBR (XSYMBOL (sym)->function, sname); + 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); + } } -#endif /* NOTDEF */ /* Define an "integer variable"; a symbol whose value is forwarded to a C variable of type EMACS_INT. Sample call (with "xx" to fool make-docfile): @@ -4116,8 +4006,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); } @@ -4131,8 +4021,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); } @@ -4150,8 +4040,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); } @@ -4174,8 +4064,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); } @@ -4243,7 +4133,7 @@ load_path_default (void) const char *loadpath = ns_load_path (); #endif - normal = PATH_LOADSEARCH; + normal = PATH_DUMPLOADSEARCH; #ifdef HAVE_NS lpath = decode_env_path (0, loadpath ? loadpath : normal, 0); #else @@ -4471,21 +4361,7 @@ dir_warning (char const *use, Lisp_Object dirname) void syms_of_lread (void) { - defsubr (&Sread); - defsubr (&Sread_from_string); - defsubr (&Sintern); - defsubr (&Sintern_soft); - defsubr (&Sunintern); - defsubr (&Sget_load_suffixes); - defsubr (&Sload); - defsubr (&Seval_buffer); - defsubr (&Seval_region); - defsubr (&Sread_char); - defsubr (&Sread_char_exclusive); - defsubr (&Sread_event); - defsubr (&Sget_file_char); - defsubr (&Smapatoms); - defsubr (&Slocate_file_internal); +#include "lread.x" DEFVAR_LISP ("obarray", Vobarray, doc: /* Symbol table for use by `intern' and `read'. @@ -4496,7 +4372,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.