X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/2829d05f57301e7f397be3a6bd92af3e56acdf64..0c59a1b7f5e2869956f9d2d2fe490fc638bd4dfb:/src/data.c diff --git a/src/data.c b/src/data.c index f4ee843a1a..c85e5485d6 100644 --- a/src/data.c +++ b/src/data.c @@ -1,5 +1,5 @@ /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. - Copyright (C) 1985,86,88,93,94,95,97,98, 1999 Free Software Foundation, Inc. + Copyright (C) 1985,86,88,93,94,95,97,98,99,2000 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -25,17 +25,11 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" #include "puresize.h" #include "charset.h" - -#ifndef standalone #include "buffer.h" #include "keyboard.h" #include "frame.h" -#endif - #include "syssignal.h" -#ifdef LISP_FLOAT_TYPE - #ifdef STDC_HEADERS #include #endif @@ -61,16 +55,11 @@ Boston, MA 02111-1307, USA. */ #endif #include -#endif /* LISP_FLOAT_TYPE */ #if !defined (atof) extern double atof (); #endif /* !atof */ -/* Nonzero means it is an error to set a symbol whose name starts with - colon. */ -int keyword_symbols_constant_flag; - Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound; Lisp_Object Qerror_conditions, Qerror_message, Qtop_level; Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range; @@ -93,16 +82,15 @@ Lisp_Object Qad_advice_info, Qad_activate_internal; Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error; Lisp_Object Qoverflow_error, Qunderflow_error; -#ifdef LISP_FLOAT_TYPE Lisp_Object Qfloatp; Lisp_Object Qnumberp, Qnumber_or_marker_p; -#endif static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; static Lisp_Object Qfloat, Qwindow_configuration, Qwindow; Lisp_Object Qprocess; static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; +static Lisp_Object Qsubrp, Qmany, Qunevalled; static Lisp_Object swap_in_symval_forwarding (); @@ -252,10 +240,8 @@ for example, (type-of 1) returns `integer'.") return Qhash_table; return Qvector; -#ifdef LISP_FLOAT_TYPE case Lisp_Float: return Qfloat; -#endif default: abort (); @@ -506,7 +492,6 @@ DEFUN ("number-or-marker-p", Fnumber_or_marker_p, return Qnil; } -#ifdef LISP_FLOAT_TYPE DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, "Return t if OBJECT is a floating point number.") (object) @@ -516,7 +501,7 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, return Qt; return Qnil; } -#endif /* LISP_FLOAT_TYPE */ + /* Extract and set components of lists */ @@ -636,8 +621,7 @@ DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be CHECK_SYMBOL (symbol, 0); if (NILP (symbol) || EQ (symbol, Qt) || (XSYMBOL (symbol)->name->data[0] == ':' - && EQ (XSYMBOL (symbol)->obarray, initial_obarray) - && keyword_symbols_constant_flag)) + && EQ (XSYMBOL (symbol)->obarray, initial_obarray))) return Fsignal (Qsetting_constant, Fcons (symbol, Qnil)); Fset (symbol, Qunbound); return symbol; @@ -726,6 +710,28 @@ DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0, return newplist; } +DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0, + "Return minimum and maximum number of args allowed for SUBR.\n\ +SUBR must be a built-in function.\n\ +The returned value is a pair (MIN . MAX). MIN is the minimum number\n\ +of args. MAX is the maximum number or the symbol `many', for a\n\ +function with `&rest' args, or `unevalled' for a special form.") + (subr) + Lisp_Object subr; +{ + short minargs, maxargs; + if (!SUBRP (subr)) + wrong_type_argument (Qsubrp, subr); + minargs = XSUBR (subr)->min_args; + maxargs = XSUBR (subr)->max_args; + if (maxargs == MANY) + return Fcons (make_number (minargs), Qmany); + else if (maxargs == UNEVALLED) + return Fcons (make_number (minargs), Qunevalled); + else + return Fcons (make_number (minargs), make_number (maxargs)); +} + /* Getting and setting values of symbols */ @@ -755,7 +761,7 @@ do_symval_forwarding (valcontents) case Lisp_Misc_Buffer_Objfwd: offset = XBUFFER_OBJFWD (valcontents)->offset; - return *(Lisp_Object *)(offset + (char *)current_buffer); + return PER_BUFFER_VALUE (current_buffer, offset); case Lisp_Misc_Kboard_Objfwd: offset = XKBOARD_OBJFWD (valcontents)->offset; @@ -800,7 +806,7 @@ store_symval_forwarding (symbol, valcontents, newval) int offset = XBUFFER_OBJFWD (valcontents)->offset; Lisp_Object type; - type = *(Lisp_Object *)(offset + (char *)&buffer_local_types); + type = PER_BUFFER_TYPE (offset); if (XINT (type) == -1) error ("Variable %s is read-only", XSYMBOL (symbol)->name->data); @@ -808,7 +814,7 @@ store_symval_forwarding (symbol, valcontents, newval) && XTYPE (newval) != XINT (type)) buffer_slot_type_mismatch (offset); - *(Lisp_Object *)(offset + (char *)current_buffer) = newval; + PER_BUFFER_VALUE (current_buffer, offset) = newval; } break; @@ -834,40 +840,60 @@ store_symval_forwarding (symbol, valcontents, newval) } } -/* Set up the buffer-local symbol SYMBOL for validity in the current buffer. - VALCONTENTS is the contents of its value cell. - Return the value forwarded one step past the buffer-local indicator. */ +/* Set up SYMBOL to refer to its global binding. + This makes it safe to alter the status of other bindings. */ -static Lisp_Object -swap_in_symval_forwarding (symbol, valcontents) - Lisp_Object symbol, valcontents; +void +swap_in_global_binding (symbol) + Lisp_Object symbol; { - /* valcontents is a pointer to a struct resembling the cons - (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)). + Lisp_Object valcontents, cdr; + + valcontents = XSYMBOL (symbol)->value; + if (!BUFFER_LOCAL_VALUEP (valcontents) + && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) + abort (); + cdr = XBUFFER_LOCAL_VALUE (valcontents)->cdr; + + /* Unload the previously loaded binding. */ + Fsetcdr (XCAR (cdr), + do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); + + /* Select the global binding in the symbol. */ + XCAR (cdr) = cdr; + store_symval_forwarding (symbol, valcontents, XCDR (cdr)); - CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's - local_var_alist, that being the element whose car is this - variable. Or it can be a pointer to the - (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have - an element in its alist for this variable. + /* Indicate that the global binding is set up now. */ + XBUFFER_LOCAL_VALUE (valcontents)->frame = Qnil; + XBUFFER_LOCAL_VALUE (valcontents)->buffer = Qnil; + XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; + XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; +} - If the current buffer is not BUFFER, we store the current - REALVALUE value into CURRENT-ALIST-ELEMENT, then find the - appropriate alist element for the buffer now current and set up - CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that - element, and store into BUFFER. +/* Set up the buffer-local symbol SYMBOL for validity in the current buffer. + VALCONTENTS is the contents of its value cell, + which points to a struct Lisp_Buffer_Local_Value. - Note that REALVALUE can be a forwarding pointer. */ + Return the value forwarded one step past the buffer-local stage. + This could be another forwarding pointer. */ +static Lisp_Object +swap_in_symval_forwarding (symbol, valcontents) + Lisp_Object symbol, valcontents; +{ register Lisp_Object tem1; tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer; - if (NILP (tem1) || current_buffer != XBUFFER (tem1) - || !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame)) + if (NILP (tem1) + || current_buffer != XBUFFER (tem1) + || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame + && ! EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))) { + /* Unload the previously loaded binding. */ tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); Fsetcdr (tem1, do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); + /* Choose the new binding. */ tem1 = assq_no_quit (symbol, current_buffer->local_var_alist); XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; @@ -883,6 +909,7 @@ swap_in_symval_forwarding (symbol, valcontents) else XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1; + /* Load the new binding. */ XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr) = tem1; XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer); XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame; @@ -928,8 +955,8 @@ find_symbol_value (symbol) return *XOBJFWD (valcontents)->objvar; case Lisp_Misc_Buffer_Objfwd: - return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset - + (char *)current_buffer); + return PER_BUFFER_VALUE (current_buffer, + XBUFFER_OBJFWD (valcontents)->offset); case Lisp_Misc_Kboard_Objfwd: return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset @@ -962,6 +989,25 @@ DEFUN ("set", Fset, Sset, 2, 2, 0, return set_internal (symbol, newval, current_buffer, 0); } +/* Return 1 if SYMBOL currently has a let-binding + which was made in the buffer that is now current. */ + +static int +let_shadows_buffer_binding_p (symbol) + Lisp_Object symbol; +{ + struct specbinding *p; + + for (p = specpdl_ptr - 1; p >= specpdl; p--) + if (p->func == 0 + && CONSP (p->symbol) + && EQ (symbol, XCAR (p->symbol)) + && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer) + return 1; + + return 0; +} + /* Store the value NEWVAL into SYMBOL. If buffer-locality is an issue, BUF specifies which buffer to use. (0 stands for the current buffer.) @@ -978,7 +1024,7 @@ set_internal (symbol, newval, buf, bindflag) { int voide = EQ (newval, Qunbound); - register Lisp_Object valcontents, tem1, current_alist_element; + register Lisp_Object valcontents, innercontents, tem1, current_alist_element; if (buf == 0) buf = current_buffer; @@ -991,71 +1037,51 @@ set_internal (symbol, newval, buf, bindflag) if (NILP (symbol) || EQ (symbol, Qt) || (XSYMBOL (symbol)->name->data[0] == ':' && EQ (XSYMBOL (symbol)->obarray, initial_obarray) - && keyword_symbols_constant_flag && ! EQ (newval, symbol))) + && !EQ (newval, symbol))) return Fsignal (Qsetting_constant, Fcons (symbol, Qnil)); - valcontents = XSYMBOL (symbol)->value; + + innercontents = valcontents = XSYMBOL (symbol)->value; if (BUFFER_OBJFWDP (valcontents)) { - register int idx = XBUFFER_OBJFWD (valcontents)->offset; - register int mask = XINT (*((Lisp_Object *) - (idx + (char *)&buffer_local_flags))); - if (mask > 0 && ! bindflag) - buf->local_var_flags |= mask; + int offset = XBUFFER_OBJFWD (valcontents)->offset; + int idx = PER_BUFFER_IDX (offset); + if (idx > 0 + && !bindflag + && !let_shadows_buffer_binding_p (symbol)) + SET_PER_BUFFER_VALUE_P (buf, idx, 1); } else if (BUFFER_LOCAL_VALUEP (valcontents) || SOME_BUFFER_LOCAL_VALUEP (valcontents)) { - /* valcontents is actually a pointer to a struct resembling a cons, - with contents something like: - (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE). - - BUFFER is the last buffer for which this symbol's value was - made up to date. - - CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's - local_var_alist, that being the element whose car is this - variable. Or it can be a pointer to the - (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not - have an element in its alist for this variable (that is, if - BUFFER sees the default value of this variable). - - If we want to examine or set the value and BUFFER is current, - we just examine or set REALVALUE. If BUFFER is not current, we - store the current REALVALUE value into CURRENT-ALIST-ELEMENT, - then find the appropriate alist element for the buffer now - current and set up CURRENT-ALIST-ELEMENT. Then we set - REALVALUE out of that element, and store into BUFFER. - - If we are setting the variable and the current buffer does - not have an alist entry for this variable, an alist entry is - created. - - Note that REALVALUE can be a forwarding pointer. Each time - it is examined or set, forwarding must be done. */ - - /* What value are we caching right now? */ + /* valcontents is a struct Lisp_Buffer_Local_Value. */ + + /* What binding is loaded right now? */ current_alist_element = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); /* If the current buffer is not the buffer whose binding is - currently cached, or if it's a Lisp_Buffer_Local_Value and - we're looking at the default value, the cache is invalid; we - need to write it out, and find the new CURRENT-ALIST-ELEMENT. */ - if (buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer) - || !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame) + loaded, or if there may be frame-local bindings and the frame + isn't the right one, or if it's a Lisp_Buffer_Local_Value and + the default binding is loaded, the loaded binding may be the + wrong one. */ + if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents)->buffer) + || buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer) + || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame + && !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame)) || (BUFFER_LOCAL_VALUEP (valcontents) && EQ (XCAR (current_alist_element), current_alist_element))) { - /* Write out the cached value for the old buffer; copy it - back to its alist element. This works if the current - buffer only sees the default value, too. */ + /* The currently loaded binding is not necessarily valid. + We need to unload it, and choose a new binding. */ + + /* Write out `realvalue' to the old loaded binding. */ Fsetcdr (current_alist_element, do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); - /* Find the new value for CURRENT-ALIST-ELEMENT. */ + /* Find the new binding. */ tem1 = Fassq (symbol, buf->local_var_alist); XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1; XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; @@ -1067,8 +1093,11 @@ set_internal (symbol, newval, buf, bindflag) /* If the variable is a Lisp_Some_Buffer_Local_Value, or if this is `let' rather than `set', make CURRENT-ALIST-ELEMENT point to itself, - indicating that we're seeing the default value. */ - if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents)) + indicating that we're seeing the default value. + Likewise if the variable has been let-bound + in the current buffer. */ + if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents) + || let_shadows_buffer_binding_p (symbol)) { XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; @@ -1082,8 +1111,10 @@ set_internal (symbol, newval, buf, bindflag) tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr; } /* If it's a Lisp_Buffer_Local_Value, being set not bound, - give this buffer a new assoc for a local value and set - CURRENT-ALIST-ELEMENT to point to that. */ + and we're not within a let that was made for this buffer, + create a new buffer-local binding for the variable. + That means, give this buffer a new assoc for a local value + and load that binding. */ else { tem1 = Fcons (symbol, Fcdr (current_alist_element)); @@ -1092,15 +1123,15 @@ set_internal (symbol, newval, buf, bindflag) } } - /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */ + /* Record which binding is now loaded. */ XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr) = tem1; - /* Set BUFFER and FRAME for binding now loaded. */ + /* Set `buffer' and `frame' slots for thebinding now loaded. */ XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf); XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame; } - valcontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue; + innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue; } /* If storing void (making the symbol void), forward only through @@ -1108,7 +1139,26 @@ set_internal (symbol, newval, buf, bindflag) if (voide) store_symval_forwarding (symbol, Qnil, newval); else - store_symval_forwarding (symbol, valcontents, newval); + store_symval_forwarding (symbol, innercontents, newval); + + /* If we just set a variable whose current binding is frame-local, + store the new value in the frame parameter too. */ + + if (BUFFER_LOCAL_VALUEP (valcontents) + || SOME_BUFFER_LOCAL_VALUEP (valcontents)) + { + /* What binding is loaded right now? */ + current_alist_element + = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); + + /* If the current buffer is not the buffer whose binding is + loaded, or if there may be frame-local bindings and the frame + isn't the right one, or if it's a Lisp_Buffer_Local_Value and + the default binding is loaded, the loaded binding may be the + wrong one. */ + if (XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame) + XCDR (current_alist_element) = newval; + } return newval; } @@ -1131,10 +1181,9 @@ default_value (symbol) rather than letting do_symval_forwarding get the current value. */ if (BUFFER_OBJFWDP (valcontents)) { - register int idx = XBUFFER_OBJFWD (valcontents)->offset; - - if (XINT (*(Lisp_Object *) (idx + (char *) &buffer_local_flags)) != 0) - return *(Lisp_Object *)(idx + (char *) &buffer_defaults); + int offset = XBUFFER_OBJFWD (valcontents)->offset; + if (PER_BUFFER_IDX (offset) != 0) + return PER_BUFFER_DEFAULT (offset); } /* Handle user-created local variables. */ @@ -1143,7 +1192,7 @@ default_value (symbol) { /* If var is set up for a buffer that lacks a local value for it, the current value is nominally the default value. - But the current value slot may be more up to date, since + But the `realvalue' slot may be more up to date, since ordinary setq stores just that slot. So use that. */ Lisp_Object current_alist_element, alist_element_car; current_alist_element @@ -1204,20 +1253,20 @@ for this variable.") variables. */ if (BUFFER_OBJFWDP (valcontents)) { - register int idx = XBUFFER_OBJFWD (valcontents)->offset; - register struct buffer *b; - register int mask = XINT (*((Lisp_Object *) - (idx + (char *)&buffer_local_flags))); + int offset = XBUFFER_OBJFWD (valcontents)->offset; + int idx = PER_BUFFER_IDX (offset); - *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value; + PER_BUFFER_DEFAULT (offset) = value; /* If this variable is not always local in all buffers, set it in the buffers that don't nominally have a local value. */ - if (mask > 0) + if (idx > 0) { + struct buffer *b; + for (b = all_buffers; b; b = b->next) - if (!(b->local_var_flags & mask)) - *(Lisp_Object *)(idx + (char *) b) = value; + if (!PER_BUFFER_VALUE_P (b, idx)) + PER_BUFFER_VALUE (b, offset) = value; } return value; } @@ -1226,10 +1275,10 @@ for this variable.") && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) return Fset (symbol, value); - /* Store new value into the DEFAULT-VALUE slot */ + /* Store new value into the DEFAULT-VALUE slot. */ XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr) = value; - /* If that slot is current, we must set the REALVALUE slot too */ + /* If the default binding is now loaded, set the REALVALUE slot too. */ current_alist_element = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); alist_element_buffer = Fcar (current_alist_element); @@ -1282,12 +1331,14 @@ of previous SYMs.") DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local, 1, 1, "vMake Variable Buffer Local: ", - "Make VARIABLE have a separate value for each buffer.\n\ -At any time, the value for the current buffer is in effect.\n\ -There is also a default value which is seen in any buffer which has not yet\n\ -set its own value.\n\ -Using `set' or `setq' to set the variable causes it to have a separate value\n\ -for the current buffer if it was previously using the default value.\n\ + "Make VARIABLE become buffer-local whenever it is set.\n\ +At any time, the value for the current buffer is in effect,\n\ +unless the variable has never been set in this buffer,\n\ +in which case the default value is in effect.\n\ +Note that binding the variable with `let', or setting it while\n\ +a `let'-style binding made in this buffer is in effect,\n\ +does not make the variable buffer-local.\n\ +\n\ The function `default-value' gets the default value and `set-default' sets it.") (variable) register Lisp_Object variable; @@ -1316,7 +1367,7 @@ The function `default-value' gets the default value and `set-default' sets it.") XBUFFER_LOCAL_VALUE (newval)->realvalue = XSYMBOL (variable)->value; XBUFFER_LOCAL_VALUE (newval)->buffer = Fcurrent_buffer (); XBUFFER_LOCAL_VALUE (newval)->frame = Qnil; - XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 1; + XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0; XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0; XBUFFER_LOCAL_VALUE (newval)->check_frame = 0; XBUFFER_LOCAL_VALUE (newval)->cdr = tem; @@ -1362,7 +1413,7 @@ Use `make-local-hook' instead.") Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound)); return variable; } - /* Make sure symbol is set up to hold per-buffer values */ + /* Make sure symbol is set up to hold per-buffer values. */ if (!SOME_BUFFER_LOCAL_VALUEP (valcontents)) { Lisp_Object newval; @@ -1379,7 +1430,7 @@ Use `make-local-hook' instead.") XBUFFER_LOCAL_VALUE (newval)->cdr = tem; XSYMBOL (variable)->value = newval; } - /* Make sure this buffer has its own value of symbol */ + /* Make sure this buffer has its own value of symbol. */ tem = Fassq (variable, current_buffer->local_var_alist); if (NILP (tem)) { @@ -1393,7 +1444,7 @@ Use `make-local-hook' instead.") current_buffer->local_var_alist); /* Make sure symbol does not think it is set up for this buffer; - force it to look once again for this buffer's value */ + force it to look once again for this buffer's value. */ { Lisp_Object *pvalbuf; @@ -1406,10 +1457,10 @@ Use `make-local-hook' instead.") } } - /* If the symbol forwards into a C variable, then swap in the - variable for this buffer immediately. If C code modifies the - variable before we swap in, then that new value will clobber the - default value the next time we swap. */ + /* If the symbol forwards into a C variable, then load the binding + for this buffer now. If C code modifies the variable before we + load the binding in, then that new value will clobber the default + binding the next time we unload it. */ valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->realvalue; if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents)) swap_in_symval_forwarding (variable, XSYMBOL (variable)->value); @@ -1432,15 +1483,14 @@ From now on the default value will apply in this buffer.") if (BUFFER_OBJFWDP (valcontents)) { - register int idx = XBUFFER_OBJFWD (valcontents)->offset; - register int mask = XINT (*((Lisp_Object*) - (idx + (char *)&buffer_local_flags))); + int offset = XBUFFER_OBJFWD (valcontents)->offset; + int idx = PER_BUFFER_IDX (offset); - if (mask > 0) + if (idx > 0) { - *(Lisp_Object *)(idx + (char *) current_buffer) - = *(Lisp_Object *)(idx + (char *) &buffer_defaults); - current_buffer->local_var_flags &= ~mask; + SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0); + PER_BUFFER_VALUE (current_buffer, offset) + = PER_BUFFER_DEFAULT (offset); } return variable; } @@ -1449,16 +1499,16 @@ From now on the default value will apply in this buffer.") && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) return variable; - /* Get rid of this buffer's alist element, if any */ + /* Get rid of this buffer's alist element, if any. */ tem = Fassq (variable, current_buffer->local_var_alist); if (!NILP (tem)) current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist); - /* If the symbol is set up for the current buffer, recompute its - value. We have to do it now, or else forwarded objects won't - work right. */ + /* If the symbol is set up with the current buffer's binding + loaded, recompute its value. We have to do it now, or else + forwarded objects won't work right. */ { Lisp_Object *pvalbuf; valcontents = XSYMBOL (variable)->value; @@ -1499,7 +1549,10 @@ See `modify-frame-parameters'.") if (BUFFER_LOCAL_VALUEP (valcontents) || SOME_BUFFER_LOCAL_VALUEP (valcontents)) - return variable; + { + XBUFFER_LOCAL_VALUE (valcontents)->check_frame = 1; + return variable; + } if (EQ (valcontents, Qunbound)) XSYMBOL (variable)->value = Qnil; @@ -1553,8 +1606,8 @@ BUFFER defaults to the current buffer.") if (BUFFER_OBJFWDP (valcontents)) { int offset = XBUFFER_OBJFWD (valcontents)->offset; - int mask = XINT (*(Lisp_Object *)(offset + (char *)&buffer_local_flags)); - if (mask == -1 || (buf->local_var_flags & mask)) + int idx = PER_BUFFER_IDX (offset); + if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) return Qt; } return Qnil; @@ -1698,6 +1751,8 @@ or a byte-code object. IDX starts at 0.") { Lisp_Object val; + val = Qnil; + if (idxval < 0) args_out_of_range (array, idx); if (idxval < CHAR_TABLE_ORDINARY_SLOTS) @@ -1723,7 +1778,7 @@ or a byte-code object. IDX starts at 0.") int code[4], i; Lisp_Object sub_table; - SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]); + SPLIT_CHAR (idxval, code[0], code[1], code[2]); if (code[1] < 32) code[1] = -1; else if (code[2] < 32) code[2] = -1; @@ -1768,7 +1823,7 @@ or a byte-code object. IDX starts at 0.") } else { - int size; + int size = 0; if (VECTORP (array)) size = XVECTOR (array)->size; else if (COMPILEDP (array)) @@ -1782,6 +1837,11 @@ or a byte-code object. IDX starts at 0.") } } +/* Don't use alloca for relocating string data larger than this, lest + we overflow their stack. The value is the same as what used in + fns.c for base64 handling. */ +#define MAX_ALLOCA 16*1024 + DEFUN ("aset", Faset, Saset, 3, 3, 0, "Store into the element of ARRAY at index IDX the value NEWELT.\n\ ARRAY may be a vector, a string, a char-table or a bool-vector.\n\ @@ -1831,7 +1891,7 @@ IDX starts at 0.") int code[4], i; Lisp_Object val; - SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]); + SPLIT_CHAR (idxval, code[0], code[1], code[2]); if (code[1] < 32) code[1] = -1; else if (code[2] < 32) code[2] = -1; @@ -1863,41 +1923,81 @@ IDX starts at 0.") } else if (STRING_MULTIBYTE (array)) { - int idxval_byte, new_len, actual_len; - int prev_byte; - unsigned char *p, workbuf[MAX_MULTIBYTE_LENGTH], *str = workbuf; + int idxval_byte, prev_bytes, new_bytes; + unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; if (idxval < 0 || idxval >= XSTRING (array)->size) args_out_of_range (array, idx); + CHECK_NUMBER (newelt, 2); idxval_byte = string_char_to_byte (array, idxval); - p = &XSTRING (array)->data[idxval_byte]; - - actual_len = MULTIBYTE_FORM_LENGTH (p, STRING_BYTES (XSTRING (array))); - CHECK_NUMBER (newelt, 2); - new_len = CHAR_STRING (XINT (newelt), str); - if (actual_len != new_len) - error ("Attempt to change byte length of a string"); - - /* We can't accept a change causing byte combining. */ - if (!ASCII_BYTE_P (*str) - && ((idxval > 0 && !CHAR_HEAD_P (*str) - && (prev_byte = string_char_to_byte (array, idxval - 1), - BYTES_BY_CHAR_HEAD (XSTRING (array)->data[prev_byte]) - > idxval_byte - prev_byte)) - || (idxval < XSTRING (array)->size - 1 - && !CHAR_HEAD_P (p[actual_len]) - && new_len < BYTES_BY_CHAR_HEAD (*str)))) - error ("Attempt to change char length of a string"); - while (new_len--) - *p++ = *str++; + p1 = &XSTRING (array)->data[idxval_byte]; + PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes); + new_bytes = CHAR_STRING (XINT (newelt), p0); + if (prev_bytes != new_bytes) + { + /* We must relocate the string data. */ + int nchars = XSTRING (array)->size; + int nbytes = STRING_BYTES (XSTRING (array)); + unsigned char *str; + + str = (nbytes <= MAX_ALLOCA + ? (unsigned char *) alloca (nbytes) + : (unsigned char *) xmalloc (nbytes)); + bcopy (XSTRING (array)->data, str, nbytes); + allocate_string_data (XSTRING (array), nchars, + nbytes + new_bytes - prev_bytes); + bcopy (str, XSTRING (array)->data, idxval_byte); + p1 = XSTRING (array)->data + idxval_byte; + bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes, + nbytes - (idxval_byte + prev_bytes)); + if (nbytes > MAX_ALLOCA) + xfree (str); + clear_string_char_byte_cache (); + } + while (new_bytes--) + *p1++ = *p0++; } else { if (idxval < 0 || idxval >= XSTRING (array)->size) args_out_of_range (array, idx); CHECK_NUMBER (newelt, 2); - XSTRING (array)->data[idxval] = XINT (newelt); + + if (XINT (newelt) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt))) + XSTRING (array)->data[idxval] = XINT (newelt); + else + { + /* We must relocate the string data while converting it to + multibyte. */ + int idxval_byte, prev_bytes, new_bytes; + unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; + unsigned char *origstr = XSTRING (array)->data, *str; + int nchars, nbytes; + + nchars = XSTRING (array)->size; + nbytes = idxval_byte = count_size_as_multibyte (origstr, idxval); + nbytes += count_size_as_multibyte (origstr + idxval, + nchars - idxval); + str = (nbytes <= MAX_ALLOCA + ? (unsigned char *) alloca (nbytes) + : (unsigned char *) xmalloc (nbytes)); + copy_text (XSTRING (array)->data, str, nchars, 0, 1); + PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte, + prev_bytes); + new_bytes = CHAR_STRING (XINT (newelt), p0); + allocate_string_data (XSTRING (array), nchars, + nbytes + new_bytes - prev_bytes); + bcopy (str, XSTRING (array)->data, idxval_byte); + p1 = XSTRING (array)->data + idxval_byte; + while (new_bytes--) + *p1++ = *p0++; + bcopy (str + idxval_byte + prev_bytes, p1, + nbytes - (idxval_byte + prev_bytes)); + if (nbytes > MAX_ALLOCA) + xfree (str); + clear_string_char_byte_cache (); + } } return newelt; @@ -1912,10 +2012,9 @@ arithcompare (num1, num2, comparison) Lisp_Object num1, num2; enum comparison comparison; { - double f1, f2; + double f1 = 0, f2 = 0; int floatp = 0; -#ifdef LISP_FLOAT_TYPE CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0); CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0); @@ -1925,10 +2024,6 @@ arithcompare (num1, num2, comparison) f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1); f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2); } -#else - CHECK_NUMBER_COERCE_MARKER (num1, 0); - CHECK_NUMBER_COERCE_MARKER (num2, 0); -#endif /* LISP_FLOAT_TYPE */ switch (comparison) { @@ -2021,7 +2116,6 @@ DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "Return t if NUMBER is zero.") (number) register Lisp_Object number; { -#ifdef LISP_FLOAT_TYPE CHECK_NUMBER_OR_FLOAT (number, 0); if (FLOATP (number)) @@ -2030,9 +2124,6 @@ DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "Return t if NUMBER is zero.") return Qt; return Qnil; } -#else - CHECK_NUMBER (number, 0); -#endif /* LISP_FLOAT_TYPE */ if (!XINT (number)) return Qt; @@ -2077,9 +2168,6 @@ NUMBER may be an integer or a floating point number.") { char buffer[VALBITS]; -#ifndef LISP_FLOAT_TYPE - CHECK_NUMBER (number, 0); -#else CHECK_NUMBER_OR_FLOAT (number, 0); if (FLOATP (number)) @@ -2089,7 +2177,6 @@ NUMBER may be an integer or a floating point number.") float_to_string (pigbuf, XFLOAT_DATA (number)); return build_string (pigbuf); } -#endif /* LISP_FLOAT_TYPE */ if (sizeof (int) == sizeof (EMACS_INT)) sprintf (buffer, "%d", XINT (number)); @@ -2133,8 +2220,9 @@ If the base used is not 10, floating point is not recognized.") register Lisp_Object string, base; { register unsigned char *p; - register int b, v = 0; - int negative = 1; + register int b; + int sign = 1; + Lisp_Object val; CHECK_STRING (string, 0); @@ -2148,35 +2236,41 @@ If the base used is not 10, floating point is not recognized.") Fsignal (Qargs_out_of_range, Fcons (base, Qnil)); } - p = XSTRING (string)->data; - /* Skip any whitespace at the front of the number. Some versions of atoi do this anyway, so we might as well make Emacs lisp consistent. */ + p = XSTRING (string)->data; while (*p == ' ' || *p == '\t') p++; if (*p == '-') { - negative = -1; + sign = -1; p++; } else if (*p == '+') p++; -#ifdef LISP_FLOAT_TYPE if (isfloat_string (p) && b == 10) - return make_float (negative * atof (p)); -#endif /* LISP_FLOAT_TYPE */ - - while (1) + val = make_float (sign * atof (p)); + else { - int digit = digit_to_number (*p++, b); - if (digit < 0) - break; - v = v * b + digit; + double v = 0; + + while (1) + { + int digit = digit_to_number (*p++, b); + if (digit < 0) + break; + v = v * b + digit; + } + + if (v > (EMACS_UINT) (VALMASK >> 1)) + val = make_float (sign * v); + else + val = make_number (sign * (int) v); } - - return make_number (negative * v); + + return val; } @@ -2213,15 +2307,11 @@ arith_driver (code, nargs, args) for (argnum = 0; argnum < nargs; argnum++) { val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ -#ifdef LISP_FLOAT_TYPE CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum); if (FLOATP (val)) /* time to do serious math */ return (float_arith_driver ((double) accum, argnum, code, nargs, args)); -#else - CHECK_NUMBER_COERCE_MARKER (val, argnum); -#endif /* LISP_FLOAT_TYPE */ args[argnum] = val; /* runs into a compiler bug. */ next = XINT (args[argnum]); switch (SWITCH_ENUM_CAST (code)) @@ -2255,8 +2345,6 @@ arith_driver (code, nargs, args) #undef isnan #define isnan(x) ((x) != (x)) -#ifdef LISP_FLOAT_TYPE - Lisp_Object float_arith_driver (accum, argnum, code, nargs, args) double accum; @@ -2320,7 +2408,7 @@ float_arith_driver (accum, argnum, code, nargs, args) return make_float (accum); } -#endif /* LISP_FLOAT_TYPE */ + DEFUN ("+", Fplus, Splus, 0, MANY, 0, "Return sum of any number of arguments, which are numbers or markers.") @@ -2412,18 +2500,12 @@ Both X and Y must be numbers or markers.") Lisp_Object val; EMACS_INT i1, i2; -#ifdef LISP_FLOAT_TYPE CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x, 0); CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y, 1); if (FLOATP (x) || FLOATP (y)) return fmod_float (x, y); -#else /* not LISP_FLOAT_TYPE */ - CHECK_NUMBER_COERCE_MARKER (x, 0); - CHECK_NUMBER_COERCE_MARKER (y, 1); -#endif /* not LISP_FLOAT_TYPE */ - i1 = XINT (x); i2 = XINT (y); @@ -2542,14 +2624,10 @@ Markers are converted to integers.") (number) register Lisp_Object number; { -#ifdef LISP_FLOAT_TYPE CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0); if (FLOATP (number)) return (make_float (1.0 + XFLOAT_DATA (number))); -#else - CHECK_NUMBER_COERCE_MARKER (number, 0); -#endif /* LISP_FLOAT_TYPE */ XSETINT (number, XINT (number) + 1); return number; @@ -2561,14 +2639,10 @@ Markers are converted to integers.") (number) register Lisp_Object number; { -#ifdef LISP_FLOAT_TYPE CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0); if (FLOATP (number)) return (make_float (-1.0 + XFLOAT_DATA (number))); -#else - CHECK_NUMBER_COERCE_MARKER (number, 0); -#endif /* LISP_FLOAT_TYPE */ XSETINT (number, XINT (number) - 1); return number; @@ -2636,15 +2710,17 @@ syms_of_data () Qboundp = intern ("boundp"); Qfboundp = intern ("fboundp"); -#ifdef LISP_FLOAT_TYPE Qfloatp = intern ("floatp"); Qnumberp = intern ("numberp"); Qnumber_or_marker_p = intern ("number-or-marker-p"); -#endif /* LISP_FLOAT_TYPE */ Qchar_table_p = intern ("char-table-p"); Qvector_or_char_table_p = intern ("vector-or-char-table-p"); + Qsubrp = intern ("subrp"); + Qunevalled = intern ("unevalled"); + Qmany = intern ("many"); + Qcdr = intern ("cdr"); /* Handle automatic advice activation */ @@ -2746,7 +2822,6 @@ syms_of_data () Fput (Qtext_read_only, Qerror_message, build_string ("Text is read-only")); -#ifdef LISP_FLOAT_TYPE Qrange_error = intern ("range-error"); Qdomain_error = intern ("domain-error"); Qsingularity_error = intern ("singularity-error"); @@ -2783,7 +2858,6 @@ syms_of_data () staticpro (&Qsingularity_error); staticpro (&Qoverflow_error); staticpro (&Qunderflow_error); -#endif /* LISP_FLOAT_TYPE */ staticpro (&Qnil); staticpro (&Qt); @@ -2831,13 +2905,14 @@ syms_of_data () staticpro (&Qmarkerp); staticpro (&Qbuffer_or_string_p); staticpro (&Qinteger_or_marker_p); -#ifdef LISP_FLOAT_TYPE staticpro (&Qfloatp); staticpro (&Qnumberp); staticpro (&Qnumber_or_marker_p); -#endif /* LISP_FLOAT_TYPE */ staticpro (&Qchar_table_p); staticpro (&Qvector_or_char_table_p); + staticpro (&Qsubrp); + staticpro (&Qmany); + staticpro (&Qunevalled); staticpro (&Qboundp); staticpro (&Qfboundp); @@ -2884,11 +2959,6 @@ syms_of_data () staticpro (&Qbool_vector); staticpro (&Qhash_table); - DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag, - "Non-nil means it is an error to set a keyword symbol.\n\ -A keyword symbol is a symbol whose name starts with a colon (`:')."); - keyword_symbols_constant_flag = 1; - defsubr (&Seq); defsubr (&Snull); defsubr (&Stype_of); @@ -2900,9 +2970,7 @@ A keyword symbol is a symbol whose name starts with a colon (`:')."); defsubr (&Sinteger_or_marker_p); defsubr (&Snumberp); defsubr (&Snumber_or_marker_p); -#ifdef LISP_FLOAT_TYPE defsubr (&Sfloatp); -#endif /* LISP_FLOAT_TYPE */ defsubr (&Snatnump); defsubr (&Ssymbolp); defsubr (&Skeywordp); @@ -2975,6 +3043,7 @@ A keyword symbol is a symbol whose name starts with a colon (`:')."); defsubr (&Sadd1); defsubr (&Ssub1); defsubr (&Slognot); + defsubr (&Ssubr_arity); XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function; }