X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d9b36d19190320c497d9e3776f28b2ae4d132dae..27540e81513199d5d4ec300b4cffd0ae1db74af1:/src/data.c diff --git a/src/data.c b/src/data.c index 5b03f0ebff..92487f82dd 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,99, 2000, 2001, 2003 + Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001, 03, 2004 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -71,6 +71,7 @@ Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch; Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive; Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; Lisp_Object Qtext_read_only; + Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp; Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp; Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; @@ -87,7 +88,8 @@ Lisp_Object Qoverflow_error, Qunderflow_error; Lisp_Object Qfloatp; Lisp_Object Qnumberp, Qnumber_or_marker_p; -static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; +Lisp_Object Qinteger; +static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; static Lisp_Object Qfloat, Qwindow_configuration, Qwindow; Lisp_Object Qprocess; static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; @@ -728,7 +730,7 @@ determined by DEFINITION. */) } DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0, - doc: /* Set SYMBOL's property list to NEWVAL, and return NEWVAL. */) + doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */) (symbol, newplist) register Lisp_Object symbol, newplist; { @@ -759,17 +761,52 @@ function with `&rest' args, or `unevalled' for a special form. */) return Fcons (make_number (minargs), make_number (maxargs)); } -DEFUN ("subr-interactive-form", Fsubr_interactive_form, Ssubr_interactive_form, 1, 1, 0, - doc: /* Return the interactive form of SUBR or nil if none. -SUBR must be a built-in function. Value, if non-nil, is a list -\(interactive SPEC). */) +DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0, + doc: /* Return name of subroutine SUBR. +SUBR must be a built-in function. */) (subr) Lisp_Object subr; { + const char *name; if (!SUBRP (subr)) wrong_type_argument (Qsubrp, subr); - if (XSUBR (subr)->prompt) - return list2 (Qinteractive, build_string (XSUBR (subr)->prompt)); + name = XSUBR (subr)->symbol_name; + return make_string (name, strlen (name)); +} + +DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, + doc: /* Return the interactive form of CMD or nil if none. +If CMD is not a command, the return value is nil. +Value, if non-nil, is a list \(interactive SPEC). */) + (cmd) + Lisp_Object cmd; +{ + Lisp_Object fun = indirect_function (cmd); + + if (SUBRP (fun)) + { + if (XSUBR (fun)->prompt) + return list2 (Qinteractive, build_string (XSUBR (fun)->prompt)); + } + else if (COMPILEDP (fun)) + { + if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE) + return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); + } + else if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qlambda)) + return Fassq (Qinteractive, Fcdr (XCDR (fun))); + else if (EQ (funcar, Qautoload)) + { + struct gcpro gcpro1; + GCPRO1 (cmd); + do_autoload (fun, cmd); + UNGCPRO; + return Finteractive_form (cmd); + } + } return Qnil; } @@ -871,6 +908,8 @@ store_symval_forwarding (symbol, valcontents, newval, buf) register Lisp_Object valcontents, newval; struct buffer *buf; { + int offset; + switch (SWITCH_ENUM_CAST (XTYPE (valcontents))) { case Lisp_Misc: @@ -890,6 +929,36 @@ store_symval_forwarding (symbol, valcontents, newval, buf) case Lisp_Misc_Objfwd: *XOBJFWD (valcontents)->objvar = newval; + + /* If this variable is a default for something stored + in the buffer itself, such as default-fill-column, + find the buffers that don't have local values for it + and update them. */ + if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults + && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1)) + { + int offset = ((char *) XOBJFWD (valcontents)->objvar + - (char *) &buffer_defaults); + int idx = PER_BUFFER_IDX (offset); + + Lisp_Object tail, buf; + + if (idx <= 0) + break; + + for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail)) + { + Lisp_Object buf; + struct buffer *b; + + buf = Fcdr (XCAR (tail)); + if (!BUFFERP (buf)) continue; + b = XBUFFER (buf); + + if (! PER_BUFFER_VALUE_P (b, idx)) + PER_BUFFER_VALUE (b, offset) = newval; + } + } break; case Lisp_Misc_Buffer_Objfwd: @@ -1092,7 +1161,7 @@ static int let_shadows_buffer_binding_p (symbol) Lisp_Object symbol; { - struct specbinding *p; + volatile struct specbinding *p; for (p = specpdl_ptr - 1; p >= specpdl; p--) if (p->func == NULL @@ -1338,7 +1407,7 @@ local bindings in certain buffers. */) } DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0, - doc: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated. + doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated. The default value is seen in buffers that do not have their own values for this variable. */) (symbol, value) @@ -1399,11 +1468,11 @@ The default value of a variable is seen in buffers that do not have their own values for the variable. More generally, you can use multiple variables and values, as in - (setq-default SYMBOL VALUE SYMBOL VALUE...) -This sets each SYMBOL's default value to the corresponding VALUE. -The VALUE for the Nth SYMBOL can refer to the new default values -of previous SYMs. -usage: (setq-default SYMBOL VALUE [SYMBOL VALUE...]) */) + (setq-default VAR VALUE VAR VALUE...) +This sets each VAR's default value to the corresponding VALUE. +The VALUE for the Nth VAR can refer to the new default values +of previous VARs. +usage: (setq-default VAR VALUE [VAR VALUE...]) */) (args) Lisp_Object args; { @@ -1449,6 +1518,7 @@ The function `default-value' gets the default value and `set-default' sets it. register Lisp_Object tem, valcontents, newval; CHECK_SYMBOL (variable); + variable = indirect_variable (variable); valcontents = SYMBOL_VALUE (variable); if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)) @@ -1502,6 +1572,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) register Lisp_Object tem, valcontents; CHECK_SYMBOL (variable); + variable = indirect_variable (variable); valcontents = SYMBOL_VALUE (variable); if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)) @@ -1581,6 +1652,7 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) register Lisp_Object tem, valcontents; CHECK_SYMBOL (variable); + variable = indirect_variable (variable); valcontents = SYMBOL_VALUE (variable); @@ -1645,6 +1717,7 @@ See `modify-frame-parameters' for how to set frame parameters. */) register Lisp_Object tem, valcontents, newval; CHECK_SYMBOL (variable); + variable = indirect_variable (variable); valcontents = SYMBOL_VALUE (variable); if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents) @@ -1694,6 +1767,7 @@ BUFFER defaults to the current buffer. */) } CHECK_SYMBOL (variable); + variable = indirect_variable (variable); valcontents = SYMBOL_VALUE (variable); if (BUFFER_LOCAL_VALUEP (valcontents) @@ -1701,7 +1775,6 @@ BUFFER defaults to the current buffer. */) { Lisp_Object tail, elt; - variable = indirect_variable (variable); for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); @@ -1721,7 +1794,11 @@ BUFFER defaults to the current buffer. */) DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p, 1, 2, 0, - doc: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there. + doc: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there. +More precisely, this means that setting the variable \(with `set' or`setq'), +while it does not have a `let'-style binding that was made in BUFFER, +will produce a buffer local binding. See Info node +`(elisp)Creating Buffer-Local'. BUFFER defaults to the current buffer. */) (variable, buffer) register Lisp_Object variable, buffer; @@ -1738,6 +1815,7 @@ BUFFER defaults to the current buffer. */) } CHECK_SYMBOL (variable); + variable = indirect_variable (variable); valcontents = SYMBOL_VALUE (variable); @@ -1759,6 +1837,41 @@ BUFFER defaults to the current buffer. */) } return Qnil; } + +DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus, + 1, 1, 0, + doc: /* Return a value indicating where VARIABLE's current binding comes from. +If the current binding is buffer-local, the value is the current buffer. +If the current binding is frame-local, the value is the selected frame. +If the current binding is global (the default), the value is nil. */) + (variable) + register Lisp_Object variable; +{ + Lisp_Object valcontents; + + CHECK_SYMBOL (variable); + variable = indirect_variable (variable); + + /* Make sure the current binding is actually swapped in. */ + find_symbol_value (variable); + + valcontents = XSYMBOL (variable)->value; + + if (BUFFER_LOCAL_VALUEP (valcontents) + || SOME_BUFFER_LOCAL_VALUEP (valcontents) + || BUFFER_OBJFWDP (valcontents)) + { + /* For a local variable, record both the symbol and which + buffer's or frame's value we are saving. */ + if (!NILP (Flocal_variable_p (variable, Qnil))) + return Fcurrent_buffer (); + else if (!BUFFER_OBJFWDP (valcontents) + && XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame) + return XBUFFER_LOCAL_VALUE (valcontents)->frame; + } + + return Qnil; +} /* Find the function at the end of a chain of symbol function indirections. */ @@ -1850,8 +1963,8 @@ or a byte-code object. IDX starts at 0. */) if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size) args_out_of_range (array, idx); - val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR]; - return (val & (1 << (idxval % BITS_PER_CHAR)) ? Qt : Qnil); + val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR]; + return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil); } else if (CHAR_TABLE_P (array)) { @@ -1943,11 +2056,6 @@ 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, doc: /* Store into the element of ARRAY at index IDX the value NEWELT. Return NEWELT. ARRAY may be a vector, a string, a char-table or a @@ -1978,13 +2086,13 @@ bool-vector. IDX starts at 0. */) if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size) args_out_of_range (array, idx); - val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR]; + val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR]; if (! NILP (newelt)) - val |= 1 << (idxval % BITS_PER_CHAR); + val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR); else - val &= ~(1 << (idxval % BITS_PER_CHAR)); - XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR] = val; + val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)); + XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val; } else if (CHAR_TABLE_P (array)) { @@ -2029,13 +2137,15 @@ bool-vector. IDX starts at 0. */) } else if (STRING_MULTIBYTE (array)) { - int idxval_byte, prev_bytes, new_bytes; + int idxval_byte, prev_bytes, new_bytes, nbytes; unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); CHECK_NUMBER (newelt); + nbytes = SBYTES (array); + idxval_byte = string_char_to_byte (array, idxval); p1 = SDATA (array) + idxval_byte; PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes); @@ -2044,12 +2154,10 @@ bool-vector. IDX starts at 0. */) { /* We must relocate the string data. */ int nchars = SCHARS (array); - int nbytes = SBYTES (array); unsigned char *str; + USE_SAFE_ALLOCA; - str = (nbytes <= MAX_ALLOCA - ? (unsigned char *) alloca (nbytes) - : (unsigned char *) xmalloc (nbytes)); + SAFE_ALLOCA (str, unsigned char *, nbytes); bcopy (SDATA (array), str, nbytes); allocate_string_data (XSTRING (array), nchars, nbytes + new_bytes - prev_bytes); @@ -2057,8 +2165,7 @@ bool-vector. IDX starts at 0. */) p1 = SDATA (array) + idxval_byte; bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes, nbytes - (idxval_byte + prev_bytes)); - if (nbytes > MAX_ALLOCA) - xfree (str); + SAFE_FREE (); clear_string_char_byte_cache (); } while (new_bytes--) @@ -2080,14 +2187,13 @@ bool-vector. IDX starts at 0. */) unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; unsigned char *origstr = SDATA (array), *str; int nchars, nbytes; + USE_SAFE_ALLOCA; nchars = SCHARS (array); 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)); + SAFE_ALLOCA (str, unsigned char *, nbytes); copy_text (SDATA (array), str, nchars, 0, 1); PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte, prev_bytes); @@ -2100,8 +2206,7 @@ bool-vector. IDX starts at 0. */) *p1++ = *p0++; bcopy (str + idxval_byte + prev_bytes, p1, nbytes - (idxval_byte + prev_bytes)); - if (nbytes > MAX_ALLOCA) - xfree (str); + SAFE_FREE (); clear_string_char_byte_cache (); } } @@ -2588,6 +2693,10 @@ usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */) int nargs; Lisp_Object *args; { + int argnum; + for (argnum = 2; argnum < nargs; argnum++) + if (FLOATP (args[argnum])) + return float_arith_driver (0, 0, Adiv, nargs, args); return arith_driver (Adiv, nargs, args); } @@ -2804,6 +2913,20 @@ DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, XSETINT (number, ~XINT (number)); return number; } + +DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0, + doc: /* Return the byteorder for the machine. +Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII +lowercase l) for small endian machines. */) + () +{ + unsigned i = 0x04030201; + int order = *(char *)&i == 1 ? 108 : 66; + + return make_number (order); +} + + void syms_of_data () @@ -3120,7 +3243,7 @@ syms_of_data () staticpro (&Qhash_table); defsubr (&Sindirect_variable); - defsubr (&Ssubr_interactive_form); + defsubr (&Sinteractive_form); defsubr (&Seq); defsubr (&Snull); defsubr (&Stype_of); @@ -3178,6 +3301,7 @@ syms_of_data () defsubr (&Smake_variable_frame_local); defsubr (&Slocal_variable_p); defsubr (&Slocal_variable_if_set_p); + defsubr (&Svariable_binding_locus); defsubr (&Saref); defsubr (&Saset); defsubr (&Snumber_to_string); @@ -3205,7 +3329,9 @@ syms_of_data () defsubr (&Sadd1); defsubr (&Ssub1); defsubr (&Slognot); + defsubr (&Sbyteorder); defsubr (&Ssubr_arity); + defsubr (&Ssubr_name); XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function; @@ -3257,3 +3383,6 @@ init_data () signal (SIGEMT, arith_error); #endif /* uts */ } + +/* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7 + (do not change this comment) */