X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/1fd4c450e5273aed82a8d643ad8cdffd4b156280..74d70085965d7d63b4f69393d70926760296f78a:/src/fns.c diff --git a/src/fns.c b/src/fns.c index 51169efca7..51e3319f87 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1,5 +1,6 @@ /* Random utility Lisp functions. - Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000 Free Software Foundation, Inc. + Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001 + Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -18,7 +19,6 @@ along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - #include #ifdef HAVE_UNISTD_H @@ -37,9 +37,11 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" #include "keyboard.h" +#include "keymap.h" #include "intervals.h" #include "frame.h" #include "window.h" +#include "blockinput.h" #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS) #include "xterm.h" #endif @@ -48,11 +50,6 @@ Boston, MA 02111-1307, USA. */ #define NULL (void *)0 #endif -#ifndef min -#define min(a, b) ((a) < (b) ? (a) : (b)) -#define max(a, b) ((a) > (b) ? (a) : (b)) -#endif - /* Nonzero enables use of dialog boxes for questions asked by mouse commands. */ int use_dialog_box; @@ -77,20 +74,20 @@ extern long time (); #endif DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, - "Return the argument unchanged.") - (arg) + doc: /* Return the argument unchanged. */) + (arg) Lisp_Object arg; { return arg; } DEFUN ("random", Frandom, Srandom, 0, 1, 0, - "Return a pseudo-random number.\n\ -All integers representable in Lisp are equally likely.\n\ - On most systems, this is 28 bits' worth.\n\ -With positive integer argument N, return random number in interval [0,N).\n\ -With argument t, set the random number seed from the current time and pid.") - (n) + doc: /* Return a pseudo-random number. +All integers representable in Lisp are equally likely. + On most systems, this is 28 bits' worth. +With positive integer argument N, return random number in interval [0,N). +With argument t, set the random number seed from the current time and pid. */) + (n) Lisp_Object n; { EMACS_INT val; @@ -122,15 +119,15 @@ With argument t, set the random number seed from the current time and pid.") /* Random data-structure functions */ DEFUN ("length", Flength, Slength, 1, 1, 0, - "Return the length of vector, list or string SEQUENCE.\n\ -A byte-code function object is also allowed.\n\ -If the string contains multibyte characters, this is not the necessarily\n\ -the number of bytes in the string; it is the number of characters.\n\ -To get the number of bytes, use `string-bytes'") - (sequence) + doc: /* Return the length of vector, list or string SEQUENCE. +A byte-code function object is also allowed. +If the string contains multibyte characters, this is not the necessarily +the number of bytes in the string; it is the number of characters. +To get the number of bytes, use `string-bytes'. */) + (sequence) register Lisp_Object sequence; { - register Lisp_Object tail, val; + register Lisp_Object val; register int i; retry: @@ -179,11 +176,11 @@ To get the number of bytes, use `string-bytes'") since it must terminate. */ DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0, - "Return the length of a list, but avoid error or infinite loop.\n\ -This function never gets an error. If LIST is not really a list,\n\ -it returns 0. If LIST is circular, it returns a finite value\n\ -which is at least the number of distinct elements.") - (list) + doc: /* Return the length of a list, but avoid error or infinite loop. +This function never gets an error. If LIST is not really a list, +it returns 0. If LIST is circular, it returns a finite value +which is at least the number of distinct elements. */) + (list) Lisp_Object list; { Lisp_Object tail, halftail, length; @@ -204,29 +201,29 @@ which is at least the number of distinct elements.") return length; } -DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0, - "Return the number of bytes in STRING.\n\ -If STRING is a multibyte string, this is greater than the length of STRING.") - (string) +DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0, + doc: /* Return the number of bytes in STRING. +If STRING is a multibyte string, this is greater than the length of STRING. */) + (string) Lisp_Object string; { - CHECK_STRING (string, 1); + CHECK_STRING (string); return make_number (STRING_BYTES (XSTRING (string))); } DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0, - "Return t if two strings have identical contents.\n\ -Case is significant, but text properties are ignored.\n\ -Symbols are also allowed; their print names are used instead.") - (s1, s2) + doc: /* Return t if two strings have identical contents. +Case is significant, but text properties are ignored. +Symbols are also allowed; their print names are used instead. */) + (s1, s2) register Lisp_Object s1, s2; { if (SYMBOLP (s1)) - XSETSTRING (s1, XSYMBOL (s1)->name); + s1 = SYMBOL_NAME (s1); if (SYMBOLP (s2)) - XSETSTRING (s2, XSYMBOL (s2)->name); - CHECK_STRING (s1, 0); - CHECK_STRING (s2, 1); + s2 = SYMBOL_NAME (s2); + CHECK_STRING (s1); + CHECK_STRING (s2); if (XSTRING (s1)->size != XSTRING (s2)->size || STRING_BYTES (XSTRING (s1)) != STRING_BYTES (XSTRING (s2)) @@ -237,37 +234,37 @@ Symbols are also allowed; their print names are used instead.") DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0, - "Compare the contents of two strings, converting to multibyte if needed.\n\ -In string STR1, skip the first START1 characters and stop at END1.\n\ -In string STR2, skip the first START2 characters and stop at END2.\n\ -END1 and END2 default to the full lengths of the respective strings.\n\ -\n\ -Case is significant in this comparison if IGNORE-CASE is nil.\n\ -Unibyte strings are converted to multibyte for comparison.\n\ -\n\ -The value is t if the strings (or specified portions) match.\n\ -If string STR1 is less, the value is a negative number N;\n\ - - 1 - N is the number of characters that match at the beginning.\n\ -If string STR1 is greater, the value is a positive number N;\n\ - N - 1 is the number of characters that match at the beginning.") - (str1, start1, end1, str2, start2, end2, ignore_case) +doc: /* Compare the contents of two strings, converting to multibyte if needed. +In string STR1, skip the first START1 characters and stop at END1. +In string STR2, skip the first START2 characters and stop at END2. +END1 and END2 default to the full lengths of the respective strings. + +Case is significant in this comparison if IGNORE-CASE is nil. +Unibyte strings are converted to multibyte for comparison. + +The value is t if the strings (or specified portions) match. +If string STR1 is less, the value is a negative number N; + - 1 - N is the number of characters that match at the beginning. +If string STR1 is greater, the value is a positive number N; + N - 1 is the number of characters that match at the beginning. */) + (str1, start1, end1, str2, start2, end2, ignore_case) Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case; { register int end1_char, end2_char; register int i1, i1_byte, i2, i2_byte; - CHECK_STRING (str1, 0); - CHECK_STRING (str2, 1); + CHECK_STRING (str1); + CHECK_STRING (str2); if (NILP (start1)) start1 = make_number (0); if (NILP (start2)) start2 = make_number (0); - CHECK_NATNUM (start1, 2); - CHECK_NATNUM (start2, 3); + CHECK_NATNUM (start1); + CHECK_NATNUM (start2); if (! NILP (end1)) - CHECK_NATNUM (end1, 4); + CHECK_NATNUM (end1); if (! NILP (end2)) - CHECK_NATNUM (end2, 4); + CHECK_NATNUM (end2); i1 = XINT (start1); i2 = XINT (start2); @@ -325,9 +322,9 @@ If string STR1 is greater, the value is a positive number N;\n\ past the character that we are comparing; hence we don't add or subtract 1 here. */ if (c1 < c2) - return make_number (- i1); + return make_number (- i1 + XINT (start1)); else - return make_number (i1); + return make_number (i1 - XINT (start1)); } if (i1 < end1_char) @@ -339,21 +336,21 @@ If string STR1 is greater, the value is a positive number N;\n\ } DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0, - "Return t if first arg string is less than second in lexicographic order.\n\ -Case is significant.\n\ -Symbols are also allowed; their print names are used instead.") - (s1, s2) + doc: /* Return t if first arg string is less than second in lexicographic order. +Case is significant. +Symbols are also allowed; their print names are used instead. */) + (s1, s2) register Lisp_Object s1, s2; { register int end; register int i1, i1_byte, i2, i2_byte; if (SYMBOLP (s1)) - XSETSTRING (s1, XSYMBOL (s1)->name); + s1 = SYMBOL_NAME (s1); if (SYMBOLP (s2)) - XSETSTRING (s2, XSYMBOL (s2)->name); - CHECK_STRING (s1, 0); - CHECK_STRING (s2, 1); + s2 = SYMBOL_NAME (s2); + CHECK_STRING (s1); + CHECK_STRING (s2); i1 = i1_byte = i2 = i2_byte = 0; @@ -410,11 +407,12 @@ concat3 (s1, s2, s3) } DEFUN ("append", Fappend, Sappend, 0, MANY, 0, - "Concatenate all the arguments and make the result a list.\n\ -The result is a list whose elements are the elements of all the arguments.\n\ -Each argument may be a list, vector or string.\n\ -The last argument is not copied, just used as the tail of the new list.") - (nargs, args) + doc: /* Concatenate all the arguments and make the result a list. +The result is a list whose elements are the elements of all the arguments. +Each argument may be a list, vector or string. +The last argument is not copied, just used as the tail of the new list. +usage: (append &rest SEQUENCES) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -422,10 +420,11 @@ The last argument is not copied, just used as the tail of the new list.") } DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0, - "Concatenate all the arguments and make the result a string.\n\ -The result is a string whose elements are the elements of all the arguments.\n\ -Each argument may be a string or a list or vector of characters (integers).") - (nargs, args) + doc: /* Concatenate all the arguments and make the result a string. +The result is a string whose elements are the elements of all the arguments. +Each argument may be a string or a list or vector of characters (integers). +usage: (concat &rest SEQUENCES) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -433,10 +432,11 @@ Each argument may be a string or a list or vector of characters (integers).") } DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0, - "Concatenate all the arguments and make the result a vector.\n\ -The result is a vector whose elements are the elements of all the arguments.\n\ -Each argument may be a list, vector or string.") - (nargs, args) + doc: /* Concatenate all the arguments and make the result a vector. +The result is a vector whose elements are the elements of all the arguments. +Each argument may be a list, vector or string. +usage: (vconcat &rest SEQUENCES) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -466,10 +466,10 @@ copy_sub_char_table (arg) DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0, - "Return a copy of a list, vector or string.\n\ -The elements of a list or vector are not copied; they are shared\n\ -with the original.") - (arg) + doc: /* Return a copy of a list, vector or string. +The elements of a list or vector are not copied; they are shared +with the original. */) + (arg) Lisp_Object arg; { if (NILP (arg)) return arg; @@ -554,7 +554,7 @@ concat (nargs, args, target_type, last_special) register Lisp_Object tail; register Lisp_Object this; int toindex; - int toindex_byte; + int toindex_byte = 0; register int result_len; register int result_len_byte; register int argnum; @@ -566,10 +566,12 @@ concat (nargs, args, target_type, last_special) string can't be decided until we finish the whole concatination. So, we record strings that have text properties to be copied here, and copy the text properties after the concatination. */ - struct textprop_rec *textprops; + struct textprop_rec *textprops = NULL; /* Number of elments in textprops. */ int num_textprops = 0; + tail = Qnil; + /* In append, the last arg isn't treated like the others */ if (last_special && nargs > 0) { @@ -681,7 +683,7 @@ concat (nargs, args, target_type, last_special) for (argnum = 0; argnum < nargs; argnum++) { Lisp_Object thislen; - int thisleni; + int thisleni = 0; register unsigned int thisindex = 0; register unsigned int thisindex_byte = 0; @@ -781,7 +783,7 @@ concat (nargs, args, target_type, last_special) /* Store this element into the result. */ if (toindex < 0) { - XCAR (tail) = elt; + XSETCAR (tail, elt); prev = tail; tail = XCDR (tail); } @@ -789,7 +791,7 @@ concat (nargs, args, target_type, last_special) XVECTOR (val)->contents[toindex++] = elt; else { - CHECK_NUMBER (elt, 0); + CHECK_NUMBER (elt); if (SINGLE_BYTE_CHAR_P (XINT (elt))) { if (some_multibyte) @@ -822,11 +824,12 @@ concat (nargs, args, target_type, last_special) } } if (!NILP (prev)) - XCDR (prev) = last_tail; + XSETCDR (prev, last_tail); if (num_textprops > 0) { Lisp_Object props; + int last_to_end = -1; for (argnum = 0; argnum < num_textprops; argnum++) { @@ -837,11 +840,11 @@ concat (nargs, args, target_type, last_special) Qnil); /* If successive arguments have properites, be sure that the value of `composition' property be the copy. */ - if (argnum > 0 - && textprops[argnum - 1].argnum + 1 == textprops[argnum].argnum) + if (last_to_end == textprops[argnum].to) make_composition_value_copy (props); add_text_properties_from_list (val, props, make_number (textprops[argnum].to)); + last_to_end = textprops[argnum].to + XSTRING (this)->size; } } return val; @@ -1052,41 +1055,42 @@ string_make_unibyte (string) DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte, 1, 1, 0, - "Return the multibyte equivalent of STRING.\n\ -The function `unibyte-char-to-multibyte' is used to convert\n\ -each unibyte character to a multibyte character.") - (string) + doc: /* Return the multibyte equivalent of STRING. +The function `unibyte-char-to-multibyte' is used to convert +each unibyte character to a multibyte character. */) + (string) Lisp_Object string; { - CHECK_STRING (string, 0); + CHECK_STRING (string); return string_make_multibyte (string); } DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte, 1, 1, 0, - "Return the unibyte equivalent of STRING.\n\ -Multibyte character codes are converted to unibyte\n\ -by using just the low 8 bits.") - (string) + doc: /* Return the unibyte equivalent of STRING. +Multibyte character codes are converted to unibyte +by using just the low 8 bits. */) + (string) Lisp_Object string; { - CHECK_STRING (string, 0); + CHECK_STRING (string); return string_make_unibyte (string); } DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte, 1, 1, 0, - "Return a unibyte string with the same individual bytes as STRING.\n\ -If STRING is unibyte, the result is STRING itself.\n\ -Otherwise it is a newly created string, with no text properties.\n\ -If STRING is multibyte and contains a character of charset `binary',\n\ -it is converted to the corresponding single byte.") - (string) + doc: /* Return a unibyte string with the same individual bytes as STRING. +If STRING is unibyte, the result is STRING itself. +Otherwise it is a newly created string, with no text properties. +If STRING is multibyte and contains a character of charset +`eight-bit-control' or `eight-bit-graphic', it is converted to the +corresponding single byte. */) + (string) Lisp_Object string; { - CHECK_STRING (string, 0); + CHECK_STRING (string); if (STRING_MULTIBYTE (string)) { @@ -1103,16 +1107,16 @@ it is converted to the corresponding single byte.") DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte, 1, 1, 0, - "Return a multibyte string with the same individual bytes as STRING.\n\ -If STRING is multibyte, the result is STRING itself.\n\ -Otherwise it is a newly created string, with no text properties.\n\ -If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\ -part of multibyte form), it is converted to the corresponding\n\ -multibyte character of charset `binary'.") - (string) + doc: /* Return a multibyte string with the same individual bytes as STRING. +If STRING is multibyte, the result is STRING itself. +Otherwise it is a newly created string, with no text properties. +If STRING is unibyte and contains an individual 8-bit byte (i.e. not +part of a multibyte form), it is converted to the corresponding +multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */) + (string) Lisp_Object string; { - CHECK_STRING (string, 0); + CHECK_STRING (string); if (! STRING_MULTIBYTE (string)) { @@ -1135,18 +1139,18 @@ multibyte character of charset `binary'.") } DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0, - "Return a copy of ALIST.\n\ -This is an alist which represents the same mapping from objects to objects,\n\ -but does not share the alist structure with ALIST.\n\ -The objects mapped (cars and cdrs of elements of the alist)\n\ -are shared, however.\n\ -Elements of ALIST that are not conses are also shared.") - (alist) + doc: /* Return a copy of ALIST. +This is an alist which represents the same mapping from objects to objects, +but does not share the alist structure with ALIST. +The objects mapped (cars and cdrs of elements of the alist) +are shared, however. +Elements of ALIST that are not conses are also shared. */) + (alist) Lisp_Object alist; { register Lisp_Object tem; - CHECK_LIST (alist, 0); + CHECK_LIST (alist); if (NILP (alist)) return alist; alist = concat (1, &alist, Lisp_Cons, 0); @@ -1156,31 +1160,31 @@ Elements of ALIST that are not conses are also shared.") car = XCAR (tem); if (CONSP (car)) - XCAR (tem) = Fcons (XCAR (car), XCDR (car)); + XSETCAR (tem, Fcons (XCAR (car), XCDR (car))); } return alist; } DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0, - "Return a substring of STRING, starting at index FROM and ending before TO.\n\ -TO may be nil or omitted; then the substring runs to the end of STRING.\n\ -If FROM or TO is negative, it counts from the end.\n\ -\n\ -This function allows vectors as well as strings.") - (string, from, to) + doc: /* Return a substring of STRING, starting at index FROM and ending before TO. +TO may be nil or omitted; then the substring runs to the end of STRING. +If FROM or TO is negative, it counts from the end. + +This function allows vectors as well as strings. */) + (string, from, to) Lisp_Object string; register Lisp_Object from, to; { Lisp_Object res; int size; - int size_byte; + int size_byte = 0; int from_char, to_char; - int from_byte, to_byte; + int from_byte = 0, to_byte = 0; if (! (STRINGP (string) || VECTORP (string))) wrong_type_argument (Qarrayp, string); - CHECK_NUMBER (from, 1); + CHECK_NUMBER (from); if (STRINGP (string)) { @@ -1197,7 +1201,7 @@ This function allows vectors as well as strings.") } else { - CHECK_NUMBER (to, 2); + CHECK_NUMBER (to); to_char = XINT (to); if (to_char < 0) @@ -1232,6 +1236,65 @@ This function allows vectors as well as strings.") return res; } + +DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0, + doc: /* Return a substring of STRING, without text properties. +It starts at index FROM and ending before TO. +TO may be nil or omitted; then the substring runs to the end of STRING. +If FROM is nil or omitted, the substring starts at the beginning of STRING. +If FROM or TO is negative, it counts from the end. + +With one argument, just copy STRING without its properties. */) + (string, from, to) + Lisp_Object string; + register Lisp_Object from, to; +{ + int size, size_byte; + int from_char, to_char; + int from_byte, to_byte; + + CHECK_STRING (string); + + size = XSTRING (string)->size; + size_byte = STRING_BYTES (XSTRING (string)); + + if (NILP (from)) + from_char = from_byte = 0; + else + { + CHECK_NUMBER (from); + from_char = XINT (from); + if (from_char < 0) + from_char += size; + + from_byte = string_char_to_byte (string, from_char); + } + + if (NILP (to)) + { + to_char = size; + to_byte = size_byte; + } + else + { + CHECK_NUMBER (to); + + to_char = XINT (to); + if (to_char < 0) + to_char += size; + + to_byte = string_char_to_byte (string, to_char); + } + + if (!(0 <= from_char && from_char <= to_char && to_char <= size)) + args_out_of_range_3 (string, make_number (from_char), + make_number (to_char)); + + return make_specified_string (XSTRING (string)->data + from_byte, + to_char - from_char, to_byte - from_byte, + STRING_MULTIBYTE (string)); +} + /* Extract a substring of STRING, giving start and end positions both in characters and in bytes. */ @@ -1274,13 +1337,13 @@ substring_both (string, from, from_byte, to, to_byte) } DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0, - "Take cdr N times on LIST, returns the result.") - (n, list) + doc: /* Take cdr N times on LIST, returns the result. */) + (n, list) Lisp_Object n; register Lisp_Object list; { register int i, num; - CHECK_NUMBER (n, 0); + CHECK_NUMBER (n); num = XINT (n); for (i = 0; i < num && !NILP (list); i++) { @@ -1293,20 +1356,20 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0, } DEFUN ("nth", Fnth, Snth, 2, 2, 0, - "Return the Nth element of LIST.\n\ -N counts from zero. If LIST is not that long, nil is returned.") - (n, list) + doc: /* Return the Nth element of LIST. +N counts from zero. If LIST is not that long, nil is returned. */) + (n, list) Lisp_Object n, list; { return Fcar (Fnthcdr (n, list)); } DEFUN ("elt", Felt, Selt, 2, 2, 0, - "Return element of SEQUENCE at index N.") - (sequence, n) + doc: /* Return element of SEQUENCE at index N. */) + (sequence, n) register Lisp_Object sequence, n; { - CHECK_NUMBER (n, 0); + CHECK_NUMBER (n); while (1) { if (CONSP (sequence) || NILP (sequence)) @@ -1320,9 +1383,9 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, } DEFUN ("member", Fmember, Smember, 2, 2, 0, - "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\ -The value is actually the tail of LIST whose car is ELT.") - (elt, list) +doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. +The value is actually the tail of LIST whose car is ELT. */) + (elt, list) register Lisp_Object elt; Lisp_Object list; { @@ -1341,10 +1404,10 @@ The value is actually the tail of LIST whose car is ELT.") } DEFUN ("memq", Fmemq, Smemq, 2, 2, 0, - "Return non-nil if ELT is an element of LIST.\n\ -Comparison done with EQ. The value is actually the tail of LIST\n\ -whose car is ELT.") - (elt, list) + doc: /* Return non-nil if ELT is an element of LIST. +Comparison done with EQ. The value is actually the tail of LIST +whose car is ELT. */) + (elt, list) Lisp_Object elt, list; { while (1) @@ -1371,10 +1434,10 @@ whose car is ELT.") } DEFUN ("assq", Fassq, Sassq, 2, 2, 0, - "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\ -The value is actually the element of LIST whose car is KEY.\n\ -Elements of LIST that are not conses are ignored.") - (key, list) + doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST. +The value is actually the element of LIST whose car is KEY. +Elements of LIST that are not conses are ignored. */) + (key, list) Lisp_Object key, list; { Lisp_Object result; @@ -1428,9 +1491,9 @@ assq_no_quit (key, list) } DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0, - "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\ -The value is actually the element of LIST whose car equals KEY.") - (key, list) + doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST. +The value is actually the element of LIST whose car equals KEY. */) + (key, list) Lisp_Object key, list; { Lisp_Object result, car; @@ -1472,9 +1535,9 @@ The value is actually the element of LIST whose car equals KEY.") } DEFUN ("rassq", Frassq, Srassq, 2, 2, 0, - "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\ -The value is actually the element of LIST whose cdr is KEY.") - (key, list) + doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST. +The value is actually the element of LIST whose cdr is KEY. */) + (key, list) register Lisp_Object key; Lisp_Object list; { @@ -1514,9 +1577,9 @@ The value is actually the element of LIST whose cdr is KEY.") } DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, - "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\ -The value is actually the element of LIST whose cdr equals KEY.") - (key, list) + doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST. +The value is actually the element of LIST whose cdr equals KEY. */) + (key, list) Lisp_Object key, list; { Lisp_Object result, cdr; @@ -1558,12 +1621,12 @@ The value is actually the element of LIST whose cdr equals KEY.") } DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0, - "Delete by side effect any occurrences of ELT as a member of LIST.\n\ -The modified LIST is returned. Comparison is done with `eq'.\n\ -If the first member of LIST is ELT, there is no way to remove it by side effect;\n\ -therefore, write `(setq foo (delq element foo))'\n\ -to be sure of changing the value of `foo'.") - (elt, list) + doc: /* Delete by side effect any occurrences of ELT as a member of LIST. +The modified LIST is returned. Comparison is done with `eq'. +If the first member of LIST is ELT, there is no way to remove it by side effect; +therefore, write `(setq foo (delq element foo))' +to be sure of changing the value of `foo'. */) + (elt, list) register Lisp_Object elt; Lisp_Object list; { @@ -1593,19 +1656,19 @@ to be sure of changing the value of `foo'.") } DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0, - "Delete by side effect any occurrences of ELT as a member of SEQ.\n\ -SEQ must be a list, a vector, or a string.\n\ -The modified SEQ is returned. Comparison is done with `equal'.\n\ -If SEQ is not a list, or the first member of SEQ is ELT, deleting it\n\ -is not a side effect; it is simply using a different sequence.\n\ -Therefore, write `(setq foo (delete element foo))'\n\ -to be sure of changing the value of `foo'.") - (elt, seq) + doc: /* Delete by side effect any occurrences of ELT as a member of SEQ. +SEQ must be a list, a vector, or a string. +The modified SEQ is returned. Comparison is done with `equal'. +If SEQ is not a list, or the first member of SEQ is ELT, deleting it +is not a side effect; it is simply using a different sequence. +Therefore, write `(setq foo (delete element foo))' +to be sure of changing the value of `foo'. */) + (elt, seq) Lisp_Object elt, seq; { if (VECTORP (seq)) { - EMACS_INT i, n, size; + EMACS_INT i, n; for (i = n = 0; i < ASIZE (seq); ++i) if (NILP (Fequal (AREF (seq, i), elt))) @@ -1613,13 +1676,12 @@ to be sure of changing the value of `foo'.") if (n != ASIZE (seq)) { - struct Lisp_Vector *p = allocate_vectorlike (n); + struct Lisp_Vector *p = allocate_vector (n); for (i = n = 0; i < ASIZE (seq); ++i) if (NILP (Fequal (AREF (seq, i), elt))) p->contents[n++] = AREF (seq, i); - p->size = n; XSETVECTOR (seq, p); } } @@ -1718,9 +1780,9 @@ to be sure of changing the value of `foo'.") } DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0, - "Reverse LIST by modifying cdr pointers.\n\ -Returns the beginning of the reversed list.") - (list) + doc: /* Reverse LIST by modifying cdr pointers. +Returns the beginning of the reversed list. */) + (list) Lisp_Object list; { register Lisp_Object prev, tail, next; @@ -1742,9 +1804,9 @@ Returns the beginning of the reversed list.") } DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0, - "Reverse LIST, copying. Returns the beginning of the reversed list.\n\ -See also the function `nreverse', which is used more often.") - (list) + doc: /* Reverse LIST, copying. Returns the beginning of the reversed list. +See also the function `nreverse', which is used more often. */) + (list) Lisp_Object list; { Lisp_Object new; @@ -1759,11 +1821,11 @@ See also the function `nreverse', which is used more often.") Lisp_Object merge (); DEFUN ("sort", Fsort, Ssort, 2, 2, 0, - "Sort LIST, stably, comparing elements using PREDICATE.\n\ -Returns the sorted list. LIST is modified by side effects.\n\ -PREDICATE is called with two elements of LIST, and should return T\n\ -if the first element is \"less\" than the second.") - (list, predicate) + doc: /* Sort LIST, stably, comparing elements using PREDICATE. +Returns the sorted list. LIST is modified by side effects. +PREDICATE is called with two elements of LIST, and should return t +if the first element is "less" than the second. */) + (list, predicate) Lisp_Object list, predicate; { Lisp_Object front, back; @@ -1848,48 +1910,58 @@ merge (org_l1, org_l2, pred) tail = tem; } } - + DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0, - "Extract a value from a property list.\n\ -PLIST is a property list, which is a list of the form\n\ -\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\ -corresponding to the given PROP, or nil if PROP is not\n\ -one of the properties on the list.") - (plist, prop) + doc: /* Extract a value from a property list. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value +corresponding to the given PROP, or nil if PROP is not +one of the properties on the list. */) + (plist, prop) Lisp_Object plist; - register Lisp_Object prop; + Lisp_Object prop; { - register Lisp_Object tail; - for (tail = plist; !NILP (tail); tail = Fcdr (XCDR (tail))) + Lisp_Object tail; + + for (tail = plist; + CONSP (tail) && CONSP (XCDR (tail)); + tail = XCDR (XCDR (tail))) { - register Lisp_Object tem; - tem = Fcar (tail); - if (EQ (prop, tem)) - return Fcar (XCDR (tail)); + if (EQ (prop, XCAR (tail))) + return XCAR (XCDR (tail)); + + /* This function can be called asynchronously + (setup_coding_system). Don't QUIT in that case. */ + if (!interrupt_input_blocked) + QUIT; } + + if (!NILP (tail)) + wrong_type_argument (Qlistp, prop); + return Qnil; } DEFUN ("get", Fget, Sget, 2, 2, 0, - "Return the value of SYMBOL's PROPNAME property.\n\ -This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.") - (symbol, propname) + doc: /* Return the value of SYMBOL's PROPNAME property. +This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */) + (symbol, propname) Lisp_Object symbol, propname; { - CHECK_SYMBOL (symbol, 0); + CHECK_SYMBOL (symbol); return Fplist_get (XSYMBOL (symbol)->plist, propname); } DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0, - "Change value in PLIST of PROP to VAL.\n\ -PLIST is a property list, which is a list of the form\n\ -\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\ -If PROP is already a property on the list, its value is set to VAL,\n\ -otherwise the new PROP VAL pair is added. The new plist is returned;\n\ -use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\ -The PLIST is modified by side effects.") - (plist, prop, val) + doc: /* Change value in PLIST of PROP to VAL. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object. +If PROP is already a property on the list, its value is set to VAL, +otherwise the new PROP VAL pair is added. The new plist is returned; +use `(setq x (plist-put x prop val))' to be sure to use the new value. +The PLIST is modified by side effects. */) + (plist, prop, val) Lisp_Object plist; register Lisp_Object prop; Lisp_Object val; @@ -1905,7 +1977,9 @@ The PLIST is modified by side effects.") Fsetcar (XCDR (tail), val); return plist; } + prev = tail; + QUIT; } newcell = Fcons (prop, Fcons (val, Qnil)); if (NILP (prev)) @@ -1916,26 +1990,90 @@ The PLIST is modified by side effects.") } DEFUN ("put", Fput, Sput, 3, 3, 0, - "Store SYMBOL's PROPNAME property with value VALUE.\n\ -It can be retrieved with `(get SYMBOL PROPNAME)'.") - (symbol, propname, value) + doc: /* Store SYMBOL's PROPNAME property with value VALUE. +It can be retrieved with `(get SYMBOL PROPNAME)'. */) + (symbol, propname, value) Lisp_Object symbol, propname, value; { - CHECK_SYMBOL (symbol, 0); + CHECK_SYMBOL (symbol); XSYMBOL (symbol)->plist = Fplist_put (XSYMBOL (symbol)->plist, propname, value); return value; } + +DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0, + doc: /* Extract a value from a property list, comparing with `equal'. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value +corresponding to the given PROP, or nil if PROP is not +one of the properties on the list. */) + (plist, prop) + Lisp_Object plist; + Lisp_Object prop; +{ + Lisp_Object tail; + + for (tail = plist; + CONSP (tail) && CONSP (XCDR (tail)); + tail = XCDR (XCDR (tail))) + { + if (! NILP (Fequal (prop, XCAR (tail)))) + return XCAR (XCDR (tail)); + QUIT; + } + + if (!NILP (tail)) + wrong_type_argument (Qlistp, prop); + + return Qnil; +} + +DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0, + doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects. +If PROP is already a property on the list, its value is set to VAL, +otherwise the new PROP VAL pair is added. The new plist is returned; +use `(setq x (lax-plist-put x prop val))' to be sure to use the new value. +The PLIST is modified by side effects. */) + (plist, prop, val) + Lisp_Object plist; + register Lisp_Object prop; + Lisp_Object val; +{ + register Lisp_Object tail, prev; + Lisp_Object newcell; + prev = Qnil; + for (tail = plist; CONSP (tail) && CONSP (XCDR (tail)); + tail = XCDR (XCDR (tail))) + { + if (! NILP (Fequal (prop, XCAR (tail)))) + { + Fsetcar (XCDR (tail), val); + return plist; + } + + prev = tail; + QUIT; + } + newcell = Fcons (prop, Fcons (val, Qnil)); + if (NILP (prev)) + return newcell; + else + Fsetcdr (XCDR (prev), newcell); + return plist; +} + DEFUN ("equal", Fequal, Sequal, 2, 2, 0, - "Return t if two Lisp objects have similar structure and contents.\n\ -They must have the same data type.\n\ -Conses are compared by comparing the cars and the cdrs.\n\ -Vectors and strings are compared element by element.\n\ -Numbers are compared by value, but integers cannot equal floats.\n\ - (Use `=' if you want integers and floats to be able to be equal.)\n\ -Symbols must match exactly.") - (o1, o2) + doc: /* Return t if two Lisp objects have similar structure and contents. +They must have the same data type. +Conses are compared by comparing the cars and the cdrs. +Vectors and strings are compared element by element. +Numbers are compared by value, but integers cannot equal floats. + (Use `=' if you want integers and floats to be able to be equal.) +Symbols must match exactly. */) + (o1, o2) register Lisp_Object o1, o2; { return internal_equal (o1, o2, 0) ? Qt : Qnil; @@ -2044,16 +2182,22 @@ internal_equal (o1, o2, depth) STRING_BYTES (XSTRING (o1)))) return 0; return 1; + + case Lisp_Int: + case Lisp_Symbol: + case Lisp_Type_Limit: + break; } + return 0; } extern Lisp_Object Fmake_char_internal (); DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0, - "Store each element of ARRAY with ITEM.\n\ -ARRAY is a vector, string, char-table, or bool-vector.") - (array, item) + doc: /* Store each element of ARRAY with ITEM. +ARRAY is a vector, string, char-table, or bool-vector. */) + (array, item) Lisp_Object array, item; { register int size, index, charval; @@ -2076,7 +2220,7 @@ ARRAY is a vector, string, char-table, or bool-vector.") else if (STRINGP (array)) { register unsigned char *p = XSTRING (array)->data; - CHECK_NUMBER (item, 1); + CHECK_NUMBER (item); charval = XINT (item); size = XSTRING (array)->size; if (STRING_MULTIBYTE (array)) @@ -2122,44 +2266,44 @@ ARRAY is a vector, string, char-table, or bool-vector.") DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype, 1, 1, 0, - "Return the subtype of char-table CHAR-TABLE. The value is a symbol.") - (char_table) + doc: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */) + (char_table) Lisp_Object char_table; { - CHECK_CHAR_TABLE (char_table, 0); + CHECK_CHAR_TABLE (char_table); return XCHAR_TABLE (char_table)->purpose; } DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent, 1, 1, 0, - "Return the parent char-table of CHAR-TABLE.\n\ -The value is either nil or another char-table.\n\ -If CHAR-TABLE holds nil for a given character,\n\ -then the actual applicable value is inherited from the parent char-table\n\ -\(or from its parents, if necessary).") - (char_table) + doc: /* Return the parent char-table of CHAR-TABLE. +The value is either nil or another char-table. +If CHAR-TABLE holds nil for a given character, +then the actual applicable value is inherited from the parent char-table +\(or from its parents, if necessary). */) + (char_table) Lisp_Object char_table; { - CHECK_CHAR_TABLE (char_table, 0); + CHECK_CHAR_TABLE (char_table); return XCHAR_TABLE (char_table)->parent; } DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent, 2, 2, 0, - "Set the parent char-table of CHAR-TABLE to PARENT.\n\ -PARENT must be either nil or another char-table.") - (char_table, parent) + doc: /* Set the parent char-table of CHAR-TABLE to PARENT. +PARENT must be either nil or another char-table. */) + (char_table, parent) Lisp_Object char_table, parent; { Lisp_Object temp; - CHECK_CHAR_TABLE (char_table, 0); + CHECK_CHAR_TABLE (char_table); if (!NILP (parent)) { - CHECK_CHAR_TABLE (parent, 0); + CHECK_CHAR_TABLE (parent); for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent) if (EQ (temp, char_table)) @@ -2173,12 +2317,12 @@ PARENT must be either nil or another char-table.") DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot, 2, 2, 0, - "Return the value of CHAR-TABLE's extra-slot number N.") - (char_table, n) + doc: /* Return the value of CHAR-TABLE's extra-slot number N. */) + (char_table, n) Lisp_Object char_table, n; { - CHECK_CHAR_TABLE (char_table, 1); - CHECK_NUMBER (n, 2); + CHECK_CHAR_TABLE (char_table); + CHECK_NUMBER (n); if (XINT (n) < 0 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) args_out_of_range (char_table, n); @@ -2189,12 +2333,12 @@ DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot, DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot, Sset_char_table_extra_slot, 3, 3, 0, - "Set CHAR-TABLE's extra-slot number N to VALUE.") - (char_table, n, value) + doc: /* Set CHAR-TABLE's extra-slot number N to VALUE. */) + (char_table, n, value) Lisp_Object char_table, n, value; { - CHECK_CHAR_TABLE (char_table, 1); - CHECK_NUMBER (n, 2); + CHECK_CHAR_TABLE (char_table); + CHECK_NUMBER (n); if (XINT (n) < 0 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) args_out_of_range (char_table, n); @@ -2204,14 +2348,14 @@ DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot, DEFUN ("char-table-range", Fchar_table_range, Schar_table_range, 2, 2, 0, - "Return the value in CHAR-TABLE for a range of characters RANGE.\n\ -RANGE should be nil (for the default value)\n\ -a vector which identifies a character set or a row of a character set,\n\ -a character set name, or a character code.") - (char_table, range) + doc: /* Return the value in CHAR-TABLE for a range of characters RANGE. +RANGE should be nil (for the default value) +a vector which identifies a character set or a row of a character set, +a character set name, or a character code. */) + (char_table, range) Lisp_Object char_table, range; { - CHECK_CHAR_TABLE (char_table, 0); + CHECK_CHAR_TABLE (char_table); if (EQ (range, Qnil)) return XCHAR_TABLE (char_table)->defalt; @@ -2222,7 +2366,7 @@ a character set name, or a character code.") Lisp_Object charset_info; charset_info = Fget (range, Qcharset); - CHECK_VECTOR (charset_info, 0); + CHECK_VECTOR (charset_info); return Faref (char_table, make_number (XINT (XVECTOR (charset_info)->contents[0]) @@ -2250,16 +2394,16 @@ a character set name, or a character code.") DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range, 3, 3, 0, - "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\ -RANGE should be t (for all characters), nil (for the default value)\n\ -a vector which identifies a character set or a row of a character set,\n\ -a coding system, or a character code.") - (char_table, range, value) + doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE. +RANGE should be t (for all characters), nil (for the default value) +a vector which identifies a character set or a row of a character set, +a coding system, or a character code. */) + (char_table, range, value) Lisp_Object char_table, range, value; { int i; - CHECK_CHAR_TABLE (char_table, 0); + CHECK_CHAR_TABLE (char_table); if (EQ (range, Qt)) for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++) @@ -2271,7 +2415,7 @@ a coding system, or a character code.") Lisp_Object charset_info; charset_info = Fget (range, Qcharset); - CHECK_VECTOR (charset_info, 0); + CHECK_VECTOR (charset_info); return Faset (char_table, make_number (XINT (XVECTOR (charset_info)->contents[0]) @@ -2304,17 +2448,17 @@ a coding system, or a character code.") DEFUN ("set-char-table-default", Fset_char_table_default, Sset_char_table_default, 3, 3, 0, - "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\ -The generic character specifies the group of characters.\n\ -See also the documentation of make-char.") - (char_table, ch, value) + doc: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE. +The generic character specifies the group of characters. +See also the documentation of make-char. */) + (char_table, ch, value) Lisp_Object char_table, ch, value; { int c, charset, code1, code2; Lisp_Object temp; - CHECK_CHAR_TABLE (char_table, 0); - CHECK_NUMBER (ch, 1); + CHECK_CHAR_TABLE (char_table); + CHECK_NUMBER (ch); c = XINT (ch); SPLIT_CHAR (c, charset, code1, code2); @@ -2330,7 +2474,7 @@ See also the documentation of make-char.") /* Even if C is not a generic char, we had better behave as if a generic char is specified. */ - if (CHARSET_DIMENSION (charset) == 1) + if (!CHARSET_DEFINED_P (charset) || CHARSET_DIMENSION (charset) == 1) code1 = 0; temp = XCHAR_TABLE (char_table)->contents[charset + 128]; if (!code1) @@ -2341,10 +2485,11 @@ See also the documentation of make-char.") XCHAR_TABLE (char_table)->contents[charset + 128] = value; return value; } - char_table = temp; - if (! SUB_CHAR_TABLE_P (char_table)) + if (SUB_CHAR_TABLE_P (temp)) + char_table = temp; + else char_table = (XCHAR_TABLE (char_table)->contents[charset + 128] - = make_sub_char_table (temp)); + = make_sub_char_table (temp)); temp = XCHAR_TABLE (char_table)->contents[code1]; if (SUB_CHAR_TABLE_P (temp)) XCHAR_TABLE (temp)->defalt = value; @@ -2393,23 +2538,22 @@ optimize_sub_char_table (table, chars) } DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table, - 1, 1, 0, - "Optimize char table TABLE.") - (table) + 1, 1, 0, doc: /* Optimize char table TABLE. */) + (table) Lisp_Object table; { Lisp_Object elt; int dim; int i, j; - CHECK_CHAR_TABLE (table, 0); + CHECK_CHAR_TABLE (table); for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS; i < CHAR_TABLE_ORDINARY_SLOTS; i++) { elt = XCHAR_TABLE (table)->contents[i]; if (!SUB_CHAR_TABLE_P (elt)) continue; - dim = CHARSET_DIMENSION (i); + dim = CHARSET_DIMENSION (i - 128); if (dim == 2) for (j = 32; j < SUB_CHAR_TABLE_ORDINARY_SLOTS; j++) optimize_sub_char_table (XCHAR_TABLE (elt)->contents + j, dim); @@ -2501,17 +2645,17 @@ map_char_table (c_function, function, subtable, arg, depth, indices) } DEFUN ("map-char-table", Fmap_char_table, Smap_char_table, - 2, 2, 0, - "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\ -FUNCTION is called with two arguments--a key and a value.\n\ -The key is always a possible IDX argument to `aref'.") - (function, char_table) + 2, 2, 0, + doc: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE. +FUNCTION is called with two arguments--a key and a value. +The key is always a possible IDX argument to `aref'. */) + (function, char_table) Lisp_Object function, char_table; { /* The depth of char table is at most 3. */ Lisp_Object indices[3]; - CHECK_CHAR_TABLE (char_table, 1); + CHECK_CHAR_TABLE (char_table); map_char_table (NULL, function, char_table, char_table, 0, indices); return Qnil; @@ -2568,16 +2712,17 @@ nconc2 (s1, s2) } DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0, - "Concatenate any number of lists by altering them.\n\ -Only the last argument is not altered, and need not be a list.") - (nargs, args) + doc: /* Concatenate any number of lists by altering them. +Only the last argument is not altered, and need not be a list. +usage: (nconc &rest LISTS) */) + (nargs, args) int nargs; Lisp_Object *args; { register int argnum; register Lisp_Object tail, tem, val; - val = Qnil; + val = tail = Qnil; for (argnum = 0; argnum < nargs; argnum++) { @@ -2697,11 +2842,11 @@ mapcar1 (leni, vals, fn, seq) } DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0, - "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\ -In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\ -SEPARATOR results in spaces between the values returned by FUNCTION.\n\ -SEQUENCE may be a list, a vector, a bool-vector, or a string.") - (function, sequence, separator) + doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings. +In between each pair of results, stick in SEPARATOR. Thus, " " as +SEPARATOR results in spaces between the values returned by FUNCTION. +SEQUENCE may be a list, a vector, a bool-vector, or a string. */) + (function, sequence, separator) Lisp_Object function, sequence, separator; { Lisp_Object len; @@ -2732,10 +2877,10 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string.") } DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0, - "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\ -The result is a list just as long as SEQUENCE.\n\ -SEQUENCE may be a list, a vector, a bool-vector, or a string.") - (function, sequence) + doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results. +The result is a list just as long as SEQUENCE. +SEQUENCE may be a list, a vector, a bool-vector, or a string. */) + (function, sequence) Lisp_Object function, sequence; { register Lisp_Object len; @@ -2752,10 +2897,10 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string.") } DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0, - "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\ -Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\ -SEQUENCE may be a list, a vector, a bool-vector, or a string.") - (function, sequence) + doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only. +Unlike `mapcar', don't accumulate the results. Return SEQUENCE. +SEQUENCE may be a list, a vector, a bool-vector, or a string. */) + (function, sequence) Lisp_Object function, sequence; { register int leni; @@ -2769,18 +2914,18 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string.") /* Anything that calls this function must protect from GC! */ DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0, - "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\ -Takes one argument, which is the string to display to ask the question.\n\ -It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\ -No confirmation of the answer is requested; a single character is enough.\n\ -Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\ -the bindings in `query-replace-map'; see the documentation of that variable\n\ -for more information. In this case, the useful bindings are `act', `skip',\n\ -`recenter', and `quit'.\)\n\ -\n\ -Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\ -is nil.") - (prompt) + doc: /* Ask user a "y or n" question. Return t if answer is "y". +Takes one argument, which is the string to display to ask the question. +It should end in a space; `y-or-n-p' adds `(y or n) ' to it. +No confirmation of the answer is requested; a single character is enough. +Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses +the bindings in `query-replace-map'; see the documentation of that variable +for more information. In this case, the useful bindings are `act', `skip', +`recenter', and `quit'.\) + +Under a windowing system a dialog box will be used if `last-nonmenu-event' +is nil and `use-dialog-box' is non-nil. */) + (prompt) Lisp_Object prompt; { register Lisp_Object obj, key, def, map; @@ -2794,13 +2939,13 @@ is nil.") map = Fsymbol_value (intern ("query-replace-map")); - CHECK_STRING (prompt, 0); + CHECK_STRING (prompt); xprompt = prompt; GCPRO2 (prompt, xprompt); #ifdef HAVE_X_WINDOWS - if (display_busy_cursor_p) - cancel_busy_cursor (); + if (display_hourglass_p) + cancel_hourglass (); #endif while (1) @@ -2812,7 +2957,7 @@ is nil.") && have_menus_p ()) { Lisp_Object pane, menu; - redisplay_preserve_echo_area (); + redisplay_preserve_echo_area (3); pane = Fcons (Fcons (build_string ("Yes"), Qt), Fcons (Fcons (build_string ("No"), Qnil), Qnil)); @@ -2824,7 +2969,18 @@ is nil.") #endif /* HAVE_MENUS */ cursor_in_echo_area = 1; choose_minibuf_frame (); - message_with_string ("%s(y or n) ", xprompt, 0); + + { + Lisp_Object pargs[3]; + + /* Colorize prompt according to `minibuffer-prompt' face. */ + pargs[0] = build_string ("%s(y or n) "); + pargs[1] = intern ("face"); + pargs[2] = intern ("minibuffer-prompt"); + args[0] = Fpropertize (3, pargs); + args[1] = xprompt; + Fmessage (2, args); + } if (minibuffer_auto_raise) { @@ -2909,22 +3065,22 @@ do_yes_or_no_p (prompt) /* Anything that calls this function must protect from GC! */ DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0, - "Ask user a yes-or-no question. Return t if answer is yes.\n\ -Takes one argument, which is the string to display to ask the question.\n\ -It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\ -The user must confirm the answer with RET,\n\ -and can edit it until it has been confirmed.\n\ -\n\ -Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\ -is nil.") - (prompt) + doc: /* Ask user a yes-or-no question. Return t if answer is yes. +Takes one argument, which is the string to display to ask the question. +It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. +The user must confirm the answer with RET, +and can edit it until it has been confirmed. + +Under a windowing system a dialog box will be used if `last-nonmenu-event' +is nil, and `use-dialog-box' is non-nil. */) + (prompt) Lisp_Object prompt; { register Lisp_Object ans; Lisp_Object args[2]; struct gcpro gcpro1; - CHECK_STRING (prompt, 0); + CHECK_STRING (prompt); #ifdef HAVE_MENUS if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) @@ -2932,7 +3088,7 @@ is nil.") && have_menus_p ()) { Lisp_Object pane, menu, obj; - redisplay_preserve_echo_area (); + redisplay_preserve_echo_area (4); pane = Fcons (Fcons (build_string ("Yes"), Qt), Fcons (Fcons (build_string ("No"), Qnil), Qnil)); @@ -2974,14 +3130,17 @@ is nil.") } DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0, - "Return list of 1 minute, 5 minute and 15 minute load averages.\n\ -Each of the three load averages is multiplied by 100,\n\ -then converted to integer.\n\ -When USE-FLOATS is non-nil, floats will be used instead of integers.\n\ -These floats are not multiplied by 100.\n\n\ -If the 5-minute or 15-minute load averages are not available, return a\n\ -shortened list, containing only those averages which are available.") - (use_floats) + doc: /* Return list of 1 minute, 5 minute and 15 minute load averages. + +Each of the three load averages is multiplied by 100, then converted +to integer. + +When USE-FLOATS is non-nil, floats will be used instead of integers. +These floats are not multiplied by 100. + +If the 5-minute or 15-minute load averages are not available, return a +shortened list, containing only those averages which are available. */) + (use_floats) Lisp_Object use_floats; { double load_ave[3]; @@ -3002,78 +3161,144 @@ shortened list, containing only those averages which are available.") return ret; } -Lisp_Object Vfeatures; - -DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0, - "Returns t if FEATURE is present in this Emacs.\n\ -Use this to conditionalize execution of lisp code based on the presence or\n\ -absence of emacs or environment extensions.\n\ -Use `provide' to declare that a feature is available.\n\ -This function looks at the value of the variable `features'.") - (feature) - Lisp_Object feature; +Lisp_Object Vfeatures, Qsubfeatures; +extern Lisp_Object Vafter_load_alist; + +DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0, + doc: /* Returns t if FEATURE is present in this Emacs. + +Use this to conditionalize execution of lisp code based on the +presence or absence of emacs or environment extensions. +Use `provide' to declare that a feature is available. This function +looks at the value of the variable `features'. The optional argument +SUBFEATURE can be used to check a specific subfeature of FEATURE. */) + (feature, subfeature) + Lisp_Object feature, subfeature; { register Lisp_Object tem; - CHECK_SYMBOL (feature, 0); + CHECK_SYMBOL (feature); tem = Fmemq (feature, Vfeatures); + if (!NILP (tem) && !NILP (subfeature)) + tem = Fmember (subfeature, Fget (feature, Qsubfeatures)); return (NILP (tem)) ? Qnil : Qt; } -DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0, - "Announce that FEATURE is a feature of the current Emacs.") - (feature) - Lisp_Object feature; +DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0, + doc: /* Announce that FEATURE is a feature of the current Emacs. +The optional argument SUBFEATURES should be a list of symbols listing +particular subfeatures supported in this version of FEATURE. */) + (feature, subfeatures) + Lisp_Object feature, subfeatures; { register Lisp_Object tem; - CHECK_SYMBOL (feature, 0); + CHECK_SYMBOL (feature); + CHECK_LIST (subfeatures); if (!NILP (Vautoload_queue)) Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue); tem = Fmemq (feature, Vfeatures); if (NILP (tem)) Vfeatures = Fcons (feature, Vfeatures); + if (!NILP (subfeatures)) + Fput (feature, Qsubfeatures, subfeatures); LOADHIST_ATTACH (Fcons (Qprovide, feature)); + + /* Run any load-hooks for this file. */ + tem = Fassq (feature, Vafter_load_alist); + if (!NILP (tem)) + Fprogn (Fcdr (tem)); + return feature; } + +/* `require' and its subroutines. */ + +/* List of features currently being require'd, innermost first. */ + +Lisp_Object require_nesting_list; + +Lisp_Object +require_unwind (old_value) + Lisp_Object old_value; +{ + return require_nesting_list = old_value; +} DEFUN ("require", Frequire, Srequire, 1, 3, 0, - "If feature FEATURE is not loaded, load it from FILENAME.\n\ -If FEATURE is not a member of the list `features', then the feature\n\ -is not loaded; so load the file FILENAME.\n\ -If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\ -but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\ -If the optional third argument NOERROR is non-nil,\n\ -then return nil if the file is not found.\n\ -Normally the return value is FEATURE.") - (feature, file_name, noerror) - Lisp_Object feature, file_name, noerror; + doc: /* If feature FEATURE is not loaded, load it from FILENAME. +If FEATURE is not a member of the list `features', then the feature +is not loaded; so load the file FILENAME. +If FILENAME is omitted, the printname of FEATURE is used as the file name, +and `load' will try to load this name appended with the suffix `.elc', +`.el' or the unmodified name, in that order. +If the optional third argument NOERROR is non-nil, +then return nil if the file is not found instead of signaling an error. +Normally the return value is FEATURE. +The normal messages at start and end of loading FILENAME are suppressed. */) + (feature, filename, noerror) + Lisp_Object feature, filename, noerror; { register Lisp_Object tem; - CHECK_SYMBOL (feature, 0); + struct gcpro gcpro1, gcpro2; + + CHECK_SYMBOL (feature); + tem = Fmemq (feature, Vfeatures); + LOADHIST_ATTACH (Fcons (Qrequire, feature)); + if (NILP (tem)) { int count = specpdl_ptr - specpdl; + int nesting = 0; + + /* This is to make sure that loadup.el gives a clear picture + of what files are preloaded and when. */ + if (! NILP (Vpurify_flag)) + error ("(require %s) while preparing to dump", + XSTRING (SYMBOL_NAME (feature))->data); + + /* A certain amount of recursive `require' is legitimate, + but if we require the same feature recursively 3 times, + signal an error. */ + tem = require_nesting_list; + while (! NILP (tem)) + { + if (! NILP (Fequal (feature, XCAR (tem)))) + nesting++; + tem = XCDR (tem); + } + if (nesting > 2) + error ("Recursive `require' for feature `%s'", + XSTRING (SYMBOL_NAME (feature))->data); + + /* Update the list for any nested `require's that occur. */ + record_unwind_protect (require_unwind, require_nesting_list); + require_nesting_list = Fcons (feature, require_nesting_list); /* Value saved here is to be restored into Vautoload_queue */ record_unwind_protect (un_autoload, Vautoload_queue); Vautoload_queue = Qt; - tem = Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name, - noerror, Qt, Qnil, (NILP (file_name) ? Qt : Qnil)); + /* Load the file. */ + GCPRO2 (feature, filename); + tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename, + noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil)); + UNGCPRO; + /* If load failed entirely, return nil. */ if (NILP (tem)) return unbind_to (count, Qnil); tem = Fmemq (feature, Vfeatures); if (NILP (tem)) - error ("Required feature %s was not provided", - XSYMBOL (feature)->name->data); + error ("Required feature `%s' was not provided", + XSTRING (SYMBOL_NAME (feature))->data); /* Once loading finishes, don't undo it. */ Vautoload_queue = Qt; feature = unbind_to (count, feature); } + return feature; } @@ -3085,13 +3310,13 @@ Normally the return value is FEATURE.") for the sole reason of efficiency. */ DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0, - "Return non-nil if PLIST has the property PROP.\n\ -PLIST is a property list, which is a list of the form\n\ -\(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\ -Unlike `plist-get', this allows you to distinguish between a missing\n\ -property and a property with the value nil.\n\ -The value is actually the tail of PLIST whose car is PROP.") - (plist, prop) + doc: /* Return non-nil if PLIST has the property PROP. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol. +Unlike `plist-get', this allows you to distinguish between a missing +property and a property with the value nil. +The value is actually the tail of PLIST whose car is PROP. */) + (plist, prop) Lisp_Object plist, prop; { while (CONSP (plist) && !EQ (XCAR (plist), prop)) @@ -3104,21 +3329,21 @@ The value is actually the tail of PLIST whose car is PROP.") } DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0, - "In WIDGET, set PROPERTY to VALUE.\n\ -The value can later be retrieved with `widget-get'.") - (widget, property, value) + doc: /* In WIDGET, set PROPERTY to VALUE. +The value can later be retrieved with `widget-get'. */) + (widget, property, value) Lisp_Object widget, property, value; { - CHECK_CONS (widget, 1); - XCDR (widget) = Fplist_put (XCDR (widget), property, value); + CHECK_CONS (widget); + XSETCDR (widget, Fplist_put (XCDR (widget), property, value)); return value; } DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0, - "In WIDGET, get the value of PROPERTY.\n\ -The value could either be specified when the widget was created, or\n\ -later with `widget-put'.") - (widget, property) + doc: /* In WIDGET, get the value of PROPERTY. +The value could either be specified when the widget was created, or +later with `widget-put'. */) + (widget, property) Lisp_Object widget, property; { Lisp_Object tmp; @@ -3127,7 +3352,7 @@ later with `widget-put'.") { if (NILP (widget)) return Qnil; - CHECK_CONS (widget, 1); + CHECK_CONS (widget); tmp = Fplist_member (XCDR (widget), property); if (CONSP (tmp)) { @@ -3142,9 +3367,10 @@ later with `widget-put'.") } DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0, - "Apply the value of WIDGET's PROPERTY to the widget itself.\n\ -ARGS are passed as extra arguments to the function.") - (nargs, args) + doc: /* Apply the value of WIDGET's PROPERTY to the widget itself. +ARGS are passed as extra arguments to the function. +usage: (widget-apply WIDGET PROPERTY &rest ARGS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -3162,7 +3388,7 @@ ARGS are passed as extra arguments to the function.") return result; } -/* base64 encode/decode functions. +/* base64 encode/decode functions (RFC 2045). Based on code from GNU recode. */ #define MIME_LINE_LENGTH 76 @@ -3178,13 +3404,17 @@ ARGS are passed as extra arguments to the function.") /* Used by base64_decode_1 to retrieve a non-base64-ignorable character or return retval if there are no characters left to process. */ -#define READ_QUADRUPLET_BYTE(retval) \ - do \ - { \ - if (i == length) \ - return (retval); \ - c = from[i++]; \ - } \ +#define READ_QUADRUPLET_BYTE(retval) \ + do \ + { \ + if (i == length) \ + { \ + if (nchars_return) \ + *nchars_return = nchars; \ + return (retval); \ + } \ + c = from[i++]; \ + } \ while (IS_BASE64_IGNORABLE (c)) /* Don't use alloca for regions larger than this, lest we overflow @@ -3241,14 +3471,14 @@ static short base64_char_to_value[128] = static int base64_encode_1 P_ ((const char *, char *, int, int, int)); -static int base64_decode_1 P_ ((const char *, char *, int)); +static int base64_decode_1 P_ ((const char *, char *, int, int, int *)); DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region, 2, 3, "r", - "Base64-encode the region between BEG and END.\n\ -Return the length of the encoded text.\n\ -Optional third argument NO-LINE-BREAK means do not break long lines\n\ -into shorter lines.") + doc: /* Base64-encode the region between BEG and END. +Return the length of the encoded text. +Optional third argument NO-LINE-BREAK means do not break long lines +into shorter lines. */) (beg, end, no_line_break) Lisp_Object beg, end, no_line_break; { @@ -3285,7 +3515,7 @@ into shorter lines.") /* The encoding wasn't possible. */ if (length > MAX_ALLOCA) xfree (encoded); - error ("Base64 encoding failed"); + error ("Multibyte character in data for base64 encoding"); } /* Now we have encoded the region, so we insert the new contents @@ -3310,9 +3540,9 @@ into shorter lines.") DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string, 1, 2, 0, - "Base64-encode STRING and return the result.\n\ -Optional second argument NO-LINE-BREAK means do not break long lines\n\ -into shorter lines.") + doc: /* Base64-encode STRING and return the result. +Optional second argument NO-LINE-BREAK means do not break long lines +into shorter lines. */) (string, no_line_break) Lisp_Object string, no_line_break; { @@ -3320,7 +3550,7 @@ into shorter lines.") char *encoded; Lisp_Object encoded_string; - CHECK_STRING (string, 1); + CHECK_STRING (string); /* We need to allocate enough room for encoding the text. We need 33 1/3% more space, plus a newline every 76 @@ -3346,7 +3576,7 @@ into shorter lines.") /* The encoding wasn't possible. */ if (length > MAX_ALLOCA) xfree (encoded); - error ("Base64 encoding failed"); + error ("Multibyte character in data for base64 encoding"); } encoded_string = make_unibyte_string (encoded, encoded_length); @@ -3366,7 +3596,7 @@ base64_encode_1 (from, to, length, line_break, multibyte) { int counter = 0, i = 0; char *e = to; - unsigned char c; + int c; unsigned int value; int bytes; @@ -3375,7 +3605,7 @@ base64_encode_1 (from, to, length, line_break, multibyte) if (multibyte) { c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes); - if (!SINGLE_BYTE_CHAR_P (c)) + if (c >= 256) return -1; i += bytes; } @@ -3413,6 +3643,8 @@ base64_encode_1 (from, to, length, line_break, multibyte) if (multibyte) { c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes); + if (c >= 256) + return -1; i += bytes; } else @@ -3433,6 +3665,8 @@ base64_encode_1 (from, to, length, line_break, multibyte) if (multibyte) { c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes); + if (c >= 256) + return -1; i += bytes; } else @@ -3447,18 +3681,19 @@ base64_encode_1 (from, to, length, line_break, multibyte) DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region, - 2, 2, "r", - "Base64-decode the region between BEG and END.\n\ -Return the length of the decoded text.\n\ -If the region can't be decoded, signal an error and don't modify the buffer.") + 2, 2, "r", + doc: /* Base64-decode the region between BEG and END. +Return the length of the decoded text. +If the region can't be decoded, signal an error and don't modify the buffer. */) (beg, end) Lisp_Object beg, end; { - int ibeg, iend, length; + int ibeg, iend, length, allength; char *decoded; int old_pos = PT; int decoded_length; int inserted_chars; + int multibyte = !NILP (current_buffer->enable_multibyte_characters); validate_region (&beg, &end); @@ -3466,34 +3701,35 @@ If the region can't be decoded, signal an error and don't modify the buffer.") iend = CHAR_TO_BYTE (XFASTINT (end)); length = iend - ibeg; - /* We need to allocate enough room for decoding the text. */ - if (length <= MAX_ALLOCA) - decoded = (char *) alloca (length); + + /* We need to allocate enough room for decoding the text. If we are + working on a multibyte buffer, each decoded code may occupy at + most two bytes. */ + allength = multibyte ? length * 2 : length; + if (allength <= MAX_ALLOCA) + decoded = (char *) alloca (allength); else - decoded = (char *) xmalloc (length); + decoded = (char *) xmalloc (allength); move_gap_both (XFASTINT (beg), ibeg); - decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length); - if (decoded_length > length) + decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length, + multibyte, &inserted_chars); + if (decoded_length > allength) abort (); if (decoded_length < 0) { /* The decoding wasn't possible. */ - if (length > MAX_ALLOCA) + if (allength > MAX_ALLOCA) xfree (decoded); - error ("Base64 decoding failed"); + error ("Invalid base64 data"); } - inserted_chars = decoded_length; - if (!NILP (current_buffer->enable_multibyte_characters)) - decoded_length = str_to_multibyte (decoded, length, decoded_length); - /* Now we have decoded the region, so we insert the new contents and delete the old. (Insert first in order to preserve markers.) */ TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg); insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0); - if (length > MAX_ALLOCA) + if (allength > MAX_ALLOCA) xfree (decoded); /* Delete the original text. */ del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars, @@ -3512,15 +3748,15 @@ If the region can't be decoded, signal an error and don't modify the buffer.") DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string, 1, 1, 0, - "Base64-decode STRING and return the result.") - (string) + doc: /* Base64-decode STRING and return the result. */) + (string) Lisp_Object string; { char *decoded; int length, decoded_length; Lisp_Object decoded_string; - CHECK_STRING (string, 1); + CHECK_STRING (string); length = STRING_BYTES (XSTRING (string)); /* We need to allocate enough room for decoding the text. */ @@ -3529,7 +3765,9 @@ DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string, else decoded = (char *) xmalloc (length); - decoded_length = base64_decode_1 (XSTRING (string)->data, decoded, length); + /* The decoded result should be unibyte. */ + decoded_length = base64_decode_1 (XSTRING (string)->data, decoded, length, + 0, NULL); if (decoded_length > length) abort (); else if (decoded_length >= 0) @@ -3540,21 +3778,29 @@ DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string, if (length > MAX_ALLOCA) xfree (decoded); if (!STRINGP (decoded_string)) - error ("Base64 decoding failed"); + error ("Invalid base64 data"); return decoded_string; } +/* Base64-decode the data at FROM of LENGHT bytes into TO. If + MULTIBYTE is nonzero, the decoded result should be in multibyte + form. If NCHARS_RETRUN is not NULL, store the number of produced + characters in *NCHARS_RETURN. */ + static int -base64_decode_1 (from, to, length) +base64_decode_1 (from, to, length, multibyte, nchars_return) const char *from; char *to; int length; + int multibyte; + int *nchars_return; { int i = 0; char *e = to; unsigned char c; unsigned long value; + int nchars = 0; while (1) { @@ -3574,7 +3820,12 @@ base64_decode_1 (from, to, length) return -1; value |= base64_char_to_value[c] << 12; - *e++ = (unsigned char) (value >> 16); + c = (unsigned char) (value >> 16); + if (multibyte) + e += CHAR_STRING (c, e); + else + *e++ = c; + nchars++; /* Process third byte of a quadruplet. */ @@ -3593,7 +3844,12 @@ base64_decode_1 (from, to, length) return -1; value |= base64_char_to_value[c] << 6; - *e++ = (unsigned char) (0xff & value >> 8); + c = (unsigned char) (0xff & value >> 8); + if (multibyte) + e += CHAR_STRING (c, e); + else + *e++ = c; + nchars++; /* Process fourth byte of a quadruplet. */ @@ -3606,7 +3862,12 @@ base64_decode_1 (from, to, length) return -1; value |= base64_char_to_value[c]; - *e++ = (unsigned char) (0xff & value); + c = (unsigned char) (0xff & value); + if (multibyte) + e += CHAR_STRING (c, e); + else + *e++ = c; + nchars++; } } @@ -3704,7 +3965,7 @@ static struct Lisp_Hash_Table * check_hash_table (obj) Lisp_Object obj; { - CHECK_HASH_TABLE (obj, 0); + CHECK_HASH_TABLE (obj); return XHASH_TABLE (obj); } @@ -3774,8 +4035,7 @@ larger_vector (vec, new_size, init) old_size = XVECTOR (vec)->size; xassert (new_size >= old_size); - v = allocate_vectorlike (new_size); - v->size = new_size; + v = allocate_vector (new_size); bcopy (XVECTOR (vec)->contents, v->contents, old_size * sizeof *v->contents); for (i = old_size; i < new_size; ++i) @@ -3852,12 +4112,9 @@ hashfn_eq (h, key) struct Lisp_Hash_Table *h; Lisp_Object key; { - /* Lisp strings can change their address. Don't try to compute a - hash code for a string from its address. */ - if (STRINGP (key)) - return sxhash_string (XSTRING (key)->data, XSTRING (key)->size); - else - return XUINT (key) ^ XGCTYPE (key); + unsigned hash = XUINT (key) ^ XGCTYPE (key); + xassert ((hash & ~VALMASK) == 0); + return hash; } @@ -3870,14 +4127,13 @@ hashfn_eql (h, key) struct Lisp_Hash_Table *h; Lisp_Object key; { - /* Lisp strings can change their address. Don't try to compute a - hash code for a string from its address. */ - if (STRINGP (key)) - return sxhash_string (XSTRING (key)->data, XSTRING (key)->size); - else if (FLOATP (key)) - return sxhash (key, 0); + unsigned hash; + if (FLOATP (key)) + hash = sxhash (key, 0); else - return XUINT (key) ^ XGCTYPE (key); + hash = XUINT (key) ^ XGCTYPE (key); + xassert ((hash & ~VALMASK) == 0); + return hash; } @@ -3890,7 +4146,9 @@ hashfn_equal (h, key) struct Lisp_Hash_Table *h; Lisp_Object key; { - return sxhash (key, 0); + unsigned hash = sxhash (key, 0); + xassert ((hash & ~VALMASK) == 0); + return hash; } @@ -3946,9 +4204,8 @@ make_hash_table (test, size, rehash_size, rehash_threshold, weak, Lisp_Object user_test, user_hash; { struct Lisp_Hash_Table *h; - struct Lisp_Vector *v; Lisp_Object table; - int index_size, i, len, sz; + int index_size, i, sz; /* Preconditions. */ xassert (SYMBOLP (test)); @@ -3962,16 +4219,11 @@ make_hash_table (test, size, rehash_size, rehash_threshold, weak, if (XFASTINT (size) == 0) size = make_number (1); - /* Allocate a vector, and initialize it. */ - len = VECSIZE (struct Lisp_Hash_Table); - v = allocate_vectorlike (len); - v->size = len; - for (i = 0; i < len; ++i) - v->contents[i] = Qnil; + /* Allocate a table and initialize it. */ + h = allocate_hash_table (); /* Initialize hash table slots. */ sz = XFASTINT (size); - h = (struct Lisp_Hash_Table *) v; h->test = test; if (EQ (test, Qeql)) @@ -4039,12 +4291,9 @@ copy_hash_table (h1) { Lisp_Object table; struct Lisp_Hash_Table *h2; - struct Lisp_Vector *v, *next; - int len; + struct Lisp_Vector *next; - len = VECSIZE (struct Lisp_Hash_Table); - v = allocate_vectorlike (len); - h2 = (struct Lisp_Hash_Table *) v; + h2 = allocate_hash_table (); next = h2->vec_next; bcopy (h1, h2, sizeof *h2); h2->vec_next = next; @@ -4297,30 +4546,26 @@ sweep_weak_table (h, remove_entries_p) for (bucket = 0; bucket < n; ++bucket) { - Lisp_Object idx, prev; + Lisp_Object idx, next, prev; /* Follow collision chain, removing entries that don't survive this garbage collection. */ - idx = HASH_INDEX (h, bucket); prev = Qnil; - while (!GC_NILP (idx)) + for (idx = HASH_INDEX (h, bucket); !GC_NILP (idx); idx = next) { - int remove_p; int i = XFASTINT (idx); - Lisp_Object next; - int key_known_to_survive_p, value_known_to_survive_p; - - key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i)); - value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i)); + int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i)); + int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i)); + int remove_p; if (EQ (h->weak, Qkey)) remove_p = !key_known_to_survive_p; else if (EQ (h->weak, Qvalue)) remove_p = !value_known_to_survive_p; else if (EQ (h->weak, Qkey_or_value)) - remove_p = !key_known_to_survive_p || !value_known_to_survive_p; + remove_p = !(key_known_to_survive_p || value_known_to_survive_p); else if (EQ (h->weak, Qkey_and_value)) - remove_p = !key_known_to_survive_p && !value_known_to_survive_p; + remove_p = !(key_known_to_survive_p && value_known_to_survive_p); else abort (); @@ -4332,7 +4577,7 @@ sweep_weak_table (h, remove_entries_p) { /* Take out of collision chain. */ if (GC_NILP (prev)) - HASH_INDEX (h, i) = next; + HASH_INDEX (h, bucket) = next; else HASH_NEXT (h, XFASTINT (prev)) = next; @@ -4365,8 +4610,6 @@ sweep_weak_table (h, remove_entries_p) } } } - - idx = next; } } @@ -4380,8 +4623,8 @@ sweep_weak_table (h, remove_entries_p) void sweep_weak_hash_tables () { - Lisp_Object table; - struct Lisp_Hash_Table *h, *prev; + Lisp_Object table, used, next; + struct Lisp_Hash_Table *h; int marked; /* Mark all keys and values that are in use. Keep on marking until @@ -4403,27 +4646,24 @@ sweep_weak_hash_tables () while (marked); /* Remove tables and entries that aren't used. */ - prev = NULL; - for (table = Vweak_hash_tables; !GC_NILP (table); table = h->next_weak) + for (table = Vweak_hash_tables, used = Qnil; !GC_NILP (table); table = next) { - prev = h; h = XHASH_TABLE (table); - + next = h->next_weak; + if (h->size & ARRAY_MARK_FLAG) { + /* TABLE is marked as used. Sweep its contents. */ if (XFASTINT (h->count) > 0) sweep_weak_table (h, 1); - } - else - { - /* Table is not marked, and will thus be freed. - Take it out of the list of weak hash tables. */ - if (prev) - prev->next_weak = h->next_weak; - else - Vweak_hash_tables = h->next_weak; + + /* Add table to the list of used weak hash tables. */ + h->next_weak = used; + used = table; } } + + Vweak_hash_tables = used; } @@ -4448,7 +4688,8 @@ sweep_weak_hash_tables () + (unsigned)(Y)) -/* Return a hash for string PTR which has length LEN. */ +/* Return a hash for string PTR which has length LEN. The hash + code returned is guaranteed to fit in a Lisp integer. */ static unsigned sxhash_string (ptr, len) @@ -4468,7 +4709,7 @@ sxhash_string (ptr, len) hash = ((hash << 3) + (hash >> 28) + c); } - return hash & 07777777777; + return hash & VALMASK; } @@ -4555,8 +4796,8 @@ sxhash (obj, depth) break; case Lisp_Symbol: - hash = sxhash_string (XSYMBOL (obj)->name->data, - XSYMBOL (obj)->name->size); + hash = sxhash_string (XSTRING (SYMBOL_NAME (obj))->data, + XSTRING (SYMBOL_NAME (obj))->size); break; case Lisp_Misc: @@ -4611,8 +4852,8 @@ sxhash (obj, depth) DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0, - "Compute a hash code for OBJ and return it as integer.") - (obj) + doc: /* Compute a hash code for OBJ and return it as integer. */) + (obj) Lisp_Object obj; { unsigned hash = sxhash (obj, 0);; @@ -4621,34 +4862,38 @@ DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0, DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0, - "Create and return a new hash table.\n\ -Arguments are specified as keyword/argument pairs. The following\n\ -arguments are defined:\n\ -\n\ -:test TEST -- TEST must be a symbol that specifies how to compare keys.\n\ -Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\ -User-supplied test and hash functions can be specified via\n\ -`define-hash-table-test'.\n\ -\n\ -:size SIZE -- A hint as to how many elements will be put in the table.\n\ -Default is 65.\n\ -\n\ -:rehash-size REHASH-SIZE - Indicates how to expand the table when\n\ -it fills up. If REHASH-SIZE is an integer, add that many space.\n\ -If it is a float, it must be > 1.0, and the new size is computed by\n\ -multiplying the old size with that factor. Default is 1.5.\n\ -\n\ -:rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\ -Resize the hash table when ratio of the number of entries in the table.\n\ -Default is 0.8.\n\ -\n\ -:weakness WEAK -- WEAK must be one of nil, t, `key', `value',\n\ -`key-or-value', or `key-and-value'. If WEAK is not nil, the table returned\n\ -is a weak table. Key/value pairs are removed from a weak hash table when\n\ -there are no non-weak references pointing to their key, value, one of key\n\ -or value, or both key and value, depending on WEAK. WEAK t is equivalent\n\ -to `key-and-value'. Default value of WEAK is nil.") - (nargs, args) + doc: /* Create and return a new hash table. + +Arguments are specified as keyword/argument pairs. The following +arguments are defined: + +:test TEST -- TEST must be a symbol that specifies how to compare +keys. Default is `eql'. Predefined are the tests `eq', `eql', and +`equal'. User-supplied test and hash functions can be specified via +`define-hash-table-test'. + +:size SIZE -- A hint as to how many elements will be put in the table. +Default is 65. + +:rehash-size REHASH-SIZE - Indicates how to expand the table when it +fills up. If REHASH-SIZE is an integer, add that many space. If it +is a float, it must be > 1.0, and the new size is computed by +multiplying the old size with that factor. Default is 1.5. + +:rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0. +Resize the hash table when ratio of the number of entries in the +table. Default is 0.8. + +:weakness WEAK -- WEAK must be one of nil, t, `key', `value', +`key-or-value', or `key-and-value'. If WEAK is not nil, the table +returned is a weak table. Key/value pairs are removed from a weak +hash table when there are no non-weak references pointing to their +key, value, one of key or value, or both key and value, depending on +WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK +is nil. + +usage: (make-hash-table &rest KEYWORD-ARGS) */) + (nargs, args) int nargs; Lisp_Object *args; { @@ -4671,11 +4916,11 @@ to `key-and-value'. Default value of WEAK is nil.") Lisp_Object prop; prop = Fget (test, Qhash_table_test); - if (!CONSP (prop) || XFASTINT (Flength (prop)) < 2) + if (!CONSP (prop) || !CONSP (XCDR (prop))) Fsignal (Qerror, list2 (build_string ("Invalid hash table test"), test)); - user_test = Fnth (make_number (0), prop); - user_hash = Fnth (make_number (1), prop); + user_test = XCAR (prop); + user_hash = XCAR (XCDR (prop)); } else user_test = user_hash = Qnil; @@ -4733,8 +4978,8 @@ to `key-and-value'. Default value of WEAK is nil.") DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0, - "Return a copy of hash table TABLE.") - (table) + doc: /* Return a copy of hash table TABLE. */) + (table) Lisp_Object table; { return copy_hash_table (check_hash_table (table)); @@ -4742,11 +4987,12 @@ DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0, DEFUN ("makehash", Fmakehash, Smakehash, 0, 1, 0, - "Create a new hash table.\n\ -Optional first argument TEST specifies how to compare keys in\n\ -the table. Predefined tests are `eq', `eql', and `equal'. Default\n\ -is `eql'. New tests can be defined with `define-hash-table-test'.") - (test) + doc: /* Create a new hash table. + +Optional first argument TEST specifies how to compare keys in the +table. Predefined tests are `eq', `eql', and `equal'. Default is +`eql'. New tests can be defined with `define-hash-table-test'. */) + (test) Lisp_Object test; { Lisp_Object args[2]; @@ -4757,9 +5003,9 @@ is `eql'. New tests can be defined with `define-hash-table-test'.") DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0, - "Return the number of elements in TABLE.") - (table) - Lisp_Object table; + doc: /* Return the number of elements in TABLE. */) + (table) + Lisp_Object table; { return check_hash_table (table)->count; } @@ -4767,9 +5013,9 @@ DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0, DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, Shash_table_rehash_size, 1, 1, 0, - "Return the current rehash size of TABLE.") - (table) - Lisp_Object table; + doc: /* Return the current rehash size of TABLE. */) + (table) + Lisp_Object table; { return check_hash_table (table)->rehash_size; } @@ -4777,20 +5023,20 @@ DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, Shash_table_rehash_threshold, 1, 1, 0, - "Return the current rehash threshold of TABLE.") - (table) - Lisp_Object table; + doc: /* Return the current rehash threshold of TABLE. */) + (table) + Lisp_Object table; { return check_hash_table (table)->rehash_threshold; } DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0, - "Return the size of TABLE.\n\ -The size can be used as an argument to `make-hash-table' to create\n\ -a hash table than can hold as many elements of TABLE holds\n\ -without need for resizing.") - (table) + doc: /* Return the size of TABLE. +The size can be used as an argument to `make-hash-table' to create +a hash table than can hold as many elements of TABLE holds +without need for resizing. */) + (table) Lisp_Object table; { struct Lisp_Hash_Table *h = check_hash_table (table); @@ -4799,9 +5045,9 @@ without need for resizing.") DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0, - "Return the test TABLE uses.") - (table) - Lisp_Object table; + doc: /* Return the test TABLE uses. */) + (table) + Lisp_Object table; { return check_hash_table (table)->test; } @@ -4809,17 +5055,17 @@ DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0, DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness, 1, 1, 0, - "Return the weakness of TABLE.") - (table) - Lisp_Object table; + doc: /* Return the weakness of TABLE. */) + (table) + Lisp_Object table; { return check_hash_table (table)->weak; } DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0, - "Return t if OBJ is a Lisp hash table object.") - (obj) + doc: /* Return t if OBJ is a Lisp hash table object. */) + (obj) Lisp_Object obj; { return HASH_TABLE_P (obj) ? Qt : Qnil; @@ -4827,8 +5073,8 @@ DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0, DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0, - "Clear hash table TABLE.") - (table) + doc: /* Clear hash table TABLE. */) + (table) Lisp_Object table; { hash_clear (check_hash_table (table)); @@ -4837,9 +5083,9 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0, DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0, - "Look up KEY in TABLE and return its associated value.\n\ -If KEY is not found, return DFLT which defaults to nil.") - (key, table, dflt) + doc: /* Look up KEY in TABLE and return its associated value. +If KEY is not found, return DFLT which defaults to nil. */) + (key, table, dflt) Lisp_Object key, table, dflt; { struct Lisp_Hash_Table *h = check_hash_table (table); @@ -4849,10 +5095,10 @@ If KEY is not found, return DFLT which defaults to nil.") DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0, - "Associate KEY with VALUE in hash table TABLE.\n\ -If KEY is already present in table, replace its current value with\n\ -VALUE.") - (key, value, table) + doc: /* Associate KEY with VALUE in hash table TABLE. +If KEY is already present in table, replace its current value with +VALUE. */) + (key, value, table) Lisp_Object key, value, table; { struct Lisp_Hash_Table *h = check_hash_table (table); @@ -4870,8 +5116,8 @@ VALUE.") DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0, - "Remove KEY from TABLE.") - (key, table) + doc: /* Remove KEY from TABLE. */) + (key, table) Lisp_Object key, table; { struct Lisp_Hash_Table *h = check_hash_table (table); @@ -4881,9 +5127,9 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0, DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0, - "Call FUNCTION for all entries in hash table TABLE.\n\ -FUNCTION is called with 2 arguments KEY and VALUE.") - (function, table) + doc: /* Call FUNCTION for all entries in hash table TABLE. +FUNCTION is called with 2 arguments KEY and VALUE. */) + (function, table) Lisp_Object function, table; { struct Lisp_Hash_Table *h = check_hash_table (table); @@ -4905,22 +5151,242 @@ FUNCTION is called with 2 arguments KEY and VALUE.") DEFUN ("define-hash-table-test", Fdefine_hash_table_test, Sdefine_hash_table_test, 3, 3, 0, - "Define a new hash table test with name NAME, a symbol.\n\ -In hash tables create with NAME specified as test, use TEST to compare\n\ -keys, and HASH for computing hash codes of keys.\n\ -\n\ -TEST must be a function taking two arguments and returning non-nil\n\ -if both arguments are the same. HASH must be a function taking\n\ -one argument and return an integer that is the hash code of the\n\ -argument. Hash code computation should use the whole value range of\n\ -integers, including negative integers.") - (name, test, hash) + doc: /* Define a new hash table test with name NAME, a symbol. + +In hash tables created with NAME specified as test, use TEST to +compare keys, and HASH for computing hash codes of keys. + +TEST must be a function taking two arguments and returning non-nil if +both arguments are the same. HASH must be a function taking one +argument and return an integer that is the hash code of the argument. +Hash code computation should use the whole value range of integers, +including negative integers. */) + (name, test, hash) Lisp_Object name, test, hash; { return Fput (name, Qhash_table_test, list2 (test, hash)); } + +/************************************************************************ + MD5 + ************************************************************************/ + +#include "md5.h" +#include "coding.h" + +DEFUN ("md5", Fmd5, Smd5, 1, 5, 0, + doc: /* Return MD5 message digest of OBJECT, a buffer or string. + +A message digest is a cryptographic checksum of a document, and the +algorithm to calculate it is defined in RFC 1321. + +The two optional arguments START and END are character positions +specifying for which part of OBJECT the message digest should be +computed. If nil or omitted, the digest is computed for the whole +OBJECT. + +The MD5 message digest is computed from the result of encoding the +text in a coding system, not directly from the internal Emacs form of +the text. The optional fourth argument CODING-SYSTEM specifies which +coding system to encode the text with. It should be the same coding +system that you used or will use when actually writing the text into a +file. + +If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If +OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding +system would be chosen by default for writing this text into a file. + +If OBJECT is a string, the most preferred coding system (see the +command `prefer-coding-system') is used. + +If NOERROR is non-nil, silently assume the `raw-text' coding if the +guesswork fails. Normally, an error is signaled in such case. */) + (object, start, end, coding_system, noerror) + Lisp_Object object, start, end, coding_system, noerror; +{ + unsigned char digest[16]; + unsigned char value[33]; + int i; + int size; + int size_byte = 0; + int start_char = 0, end_char = 0; + int start_byte = 0, end_byte = 0; + register int b, e; + register struct buffer *bp; + int temp; + + if (STRINGP (object)) + { + if (NILP (coding_system)) + { + /* Decide the coding-system to encode the data with. */ + + if (STRING_MULTIBYTE (object)) + /* use default, we can't guess correct value */ + coding_system = SYMBOL_VALUE (XCAR (Vcoding_category_list)); + else + coding_system = Qraw_text; + } + + if (NILP (Fcoding_system_p (coding_system))) + { + /* Invalid coding system. */ + + if (!NILP (noerror)) + coding_system = Qraw_text; + else + while (1) + Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil)); + } + + if (STRING_MULTIBYTE (object)) + object = code_convert_string1 (object, coding_system, Qnil, 1); + + size = XSTRING (object)->size; + size_byte = STRING_BYTES (XSTRING (object)); + + if (!NILP (start)) + { + CHECK_NUMBER (start); + + start_char = XINT (start); + + if (start_char < 0) + start_char += size; + + start_byte = string_char_to_byte (object, start_char); + } + + if (NILP (end)) + { + end_char = size; + end_byte = size_byte; + } + else + { + CHECK_NUMBER (end); + + end_char = XINT (end); + + if (end_char < 0) + end_char += size; + + end_byte = string_char_to_byte (object, end_char); + } + + if (!(0 <= start_char && start_char <= end_char && end_char <= size)) + args_out_of_range_3 (object, make_number (start_char), + make_number (end_char)); + } + else + { + CHECK_BUFFER (object); + + bp = XBUFFER (object); + + if (NILP (start)) + b = BUF_BEGV (bp); + else + { + CHECK_NUMBER_COERCE_MARKER (start); + b = XINT (start); + } + + if (NILP (end)) + e = BUF_ZV (bp); + else + { + CHECK_NUMBER_COERCE_MARKER (end); + e = XINT (end); + } + + if (b > e) + temp = b, b = e, e = temp; + + if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp))) + args_out_of_range (start, end); + + if (NILP (coding_system)) + { + /* Decide the coding-system to encode the data with. + See fileio.c:Fwrite-region */ + + if (!NILP (Vcoding_system_for_write)) + coding_system = Vcoding_system_for_write; + else + { + int force_raw_text = 0; + + coding_system = XBUFFER (object)->buffer_file_coding_system; + if (NILP (coding_system) + || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil))) + { + coding_system = Qnil; + if (NILP (current_buffer->enable_multibyte_characters)) + force_raw_text = 1; + } + + if (NILP (coding_system) && !NILP (Fbuffer_file_name(object))) + { + /* Check file-coding-system-alist. */ + Lisp_Object args[4], val; + + args[0] = Qwrite_region; args[1] = start; args[2] = end; + args[3] = Fbuffer_file_name(object); + val = Ffind_operation_coding_system (4, args); + if (CONSP (val) && !NILP (XCDR (val))) + coding_system = XCDR (val); + } + + if (NILP (coding_system) + && !NILP (XBUFFER (object)->buffer_file_coding_system)) + { + /* If we still have not decided a coding system, use the + default value of buffer-file-coding-system. */ + coding_system = XBUFFER (object)->buffer_file_coding_system; + } + + if (!force_raw_text + && !NILP (Ffboundp (Vselect_safe_coding_system_function))) + /* Confirm that VAL can surely encode the current region. */ + coding_system = call3 (Vselect_safe_coding_system_function, + make_number (b), make_number (e), + coding_system); + + if (force_raw_text) + coding_system = Qraw_text; + } + + if (NILP (Fcoding_system_p (coding_system))) + { + /* Invalid coding system. */ + + if (!NILP (noerror)) + coding_system = Qraw_text; + else + while (1) + Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil)); + } + } + + object = make_buffer_string (b, e, 0); + + if (STRING_MULTIBYTE (object)) + object = code_convert_string1 (object, coding_system, Qnil, 1); + } + + md5_buffer (XSTRING (object)->data + start_byte, + STRING_BYTES(XSTRING (object)) - (size_byte - end_byte), + digest); + + for (i = 0; i < 16; i++) + sprintf (&value[2 * i], "%02x", digest[i]); + value[32] = '\0'; + + return make_string (value, 32); +} void @@ -4990,17 +5456,22 @@ syms_of_fns () staticpro (&string_char_byte_cache_string); string_char_byte_cache_string = Qnil; + require_nesting_list = Qnil; + staticpro (&require_nesting_list); + Fset (Qyes_or_no_p_history, Qnil); DEFVAR_LISP ("features", &Vfeatures, - "A list of symbols which are the features of the executing emacs.\n\ -Used by `featurep' and `require', and altered by `provide'."); + doc: /* A list of symbols which are the features of the executing emacs. +Used by `featurep' and `require', and altered by `provide'. */); Vfeatures = Qnil; + Qsubfeatures = intern ("subfeatures"); + staticpro (&Qsubfeatures); DEFVAR_BOOL ("use-dialog-box", &use_dialog_box, - "*Non-nil means mouse commands use dialog boxes to ask questions.\n\ -This applies to y-or-n and yes-or-no questions asked by commands\n\ -invoked by mouse clicks and mouse menu items."); + doc: /* *Non-nil means mouse commands use dialog boxes to ask questions. +This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands +invoked by mouse clicks and mouse menu items. */); use_dialog_box = 1; defsubr (&Sidentity); @@ -5021,6 +5492,7 @@ invoked by mouse clicks and mouse menu items."); defsubr (&Sstring_as_unibyte); defsubr (&Scopy_alist); defsubr (&Ssubstring); + defsubr (&Ssubstring_no_properties); defsubr (&Snthcdr); defsubr (&Snth); defsubr (&Selt); @@ -5039,6 +5511,8 @@ invoked by mouse clicks and mouse menu items."); defsubr (&Sget); defsubr (&Splist_put); defsubr (&Sput); + defsubr (&Slax_plist_get); + defsubr (&Slax_plist_put); defsubr (&Sequal); defsubr (&Sfillarray); defsubr (&Schar_table_subtype); @@ -5069,6 +5543,7 @@ invoked by mouse clicks and mouse menu items."); defsubr (&Sbase64_decode_region); defsubr (&Sbase64_encode_string); defsubr (&Sbase64_decode_string); + defsubr (&Smd5); }