X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0479a1b62ceeb9586168146e2c8f49f2a5ebaf2f..137868051e5ce4c4ba9cc92caa26fbf968e6f208:/src/fns.c?ds=sidebyside diff --git a/src/fns.c b/src/fns.c index 51f61d2388..ef6055c17d 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1,14 +1,14 @@ /* Random utility Lisp functions. -Copyright (C) 1985-1987, 1993-1995, 1997-2015 Free Software Foundation, +Copyright (C) 1985-1987, 1993-1995, 1997-2016 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or -(at your option) any later version. +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -21,28 +21,19 @@ along with GNU Emacs. If not, see . */ #include #include -#include - #include #include #include "lisp.h" -#include "commands.h" #include "character.h" #include "coding.h" +#include "composite.h" #include "buffer.h" -#include "keyboard.h" -#include "keymap.h" #include "intervals.h" -#include "frame.h" #include "window.h" -#include "blockinput.h" -#if defined (HAVE_X_WINDOWS) -#include "xterm.h" -#endif static void sort_vector_copy (Lisp_Object, ptrdiff_t, - Lisp_Object [restrict], Lisp_Object [restrict]); + Lisp_Object *restrict, Lisp_Object *restrict); static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object); DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, @@ -59,7 +50,8 @@ All integers representable in Lisp, i.e. between `most-negative-fixnum' and `most-positive-fixnum', inclusive, are equally likely. With positive integer LIMIT, return random number in interval [0,LIMIT). -With argument t, set the random number seed from the current time and pid. +With argument t, set the random number seed from the system's entropy +pool if available, otherwise from less-random volatile data such as the time. With a string argument, set the seed based on the string's contents. Other values of LIMIT are ignored. @@ -303,26 +295,26 @@ If string STR1 is greater, the value is a positive number N; } DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0, - doc: /* Return t if first arg string is less than second in lexicographic order. + doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order. Case is significant. Symbols are also allowed; their print names are used instead. */) - (register Lisp_Object s1, Lisp_Object s2) + (register Lisp_Object string1, Lisp_Object string2) { register ptrdiff_t end; register ptrdiff_t i1, i1_byte, i2, i2_byte; - if (SYMBOLP (s1)) - s1 = SYMBOL_NAME (s1); - if (SYMBOLP (s2)) - s2 = SYMBOL_NAME (s2); - CHECK_STRING (s1); - CHECK_STRING (s2); + if (SYMBOLP (string1)) + string1 = SYMBOL_NAME (string1); + if (SYMBOLP (string2)) + string2 = SYMBOL_NAME (string2); + CHECK_STRING (string1); + CHECK_STRING (string2); i1 = i1_byte = i2 = i2_byte = 0; - end = SCHARS (s1); - if (end > SCHARS (s2)) - end = SCHARS (s2); + end = SCHARS (string1); + if (end > SCHARS (string2)) + end = SCHARS (string2); while (i1 < end) { @@ -330,13 +322,13 @@ Symbols are also allowed; their print names are used instead. */) characters, not just the bytes. */ int c1, c2; - FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte); - FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte); + FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte); + FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte); if (c1 != c2) return c1 < c2 ? Qt : Qnil; } - return i1 < SCHARS (s2) ? Qt : Qnil; + return i1 < SCHARS (string2) ? Qt : Qnil; } DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0, @@ -347,8 +339,8 @@ This function obeys the conventions for collation order in your locale settings. For example, punctuation and whitespace characters might be considered less significant for sorting: -\(sort '\("11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp) - => \("11" "1 1" "1.1" "12" "1 2" "1.2") +\(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp) + => ("11" "1 1" "1.1" "12" "1 2" "1.2") The optional argument LOCALE, a string, overrides the setting of your current locale identifier for collation. The value is system @@ -393,7 +385,7 @@ settings. For example, characters with different coding points but the same meaning might be considered as equal, like different grave accent Unicode characters: -\(string-collate-equalp \(string ?\\uFF40) \(string ?\\u1FEF)) +\(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF)) => t The optional argument LOCALE, a string, overrides the setting of your @@ -1083,7 +1075,7 @@ multibyte character of charset `eight-bit'. See also `string-to-multibyte'. Beware, this often doesn't really do what you think it does. -It is similar to (decode-coding-string STRING 'utf-8-emacs). +It is similar to (decode-coding-string STRING \\='utf-8-emacs). If you're not sure, whether to use `string-as-multibyte' or `string-to-multibyte', use `string-to-multibyte'. */) (Lisp_Object string) @@ -1589,7 +1581,8 @@ sublist by modifying its list structure, then returns the resulting list. Write `(setq foo (delq element foo))' to be sure of correctly changing -the value of a list `foo'. */) +the value of a list `foo'. See also `remq', which does not modify the +argument. */) (register Lisp_Object elt, Lisp_Object list) { Lisp_Object tail, tortoise, prev = Qnil; @@ -1863,8 +1856,7 @@ static Lisp_Object sort_list (Lisp_Object list, Lisp_Object predicate) { Lisp_Object front, back; - register Lisp_Object len, tem; - struct gcpro gcpro1, gcpro2; + Lisp_Object len, tem; EMACS_INT length; front = list; @@ -1878,10 +1870,8 @@ sort_list (Lisp_Object list, Lisp_Object predicate) back = Fcdr (tem); Fsetcdr (tem, Qnil); - GCPRO2 (front, back); front = Fsort (front, predicate); back = Fsort (back, predicate); - UNGCPRO; return merge (front, back, predicate); } @@ -1977,15 +1967,12 @@ sort_vector (Lisp_Object vector, Lisp_Object predicate) return; ptrdiff_t halflen = len >> 1; Lisp_Object *tmp; - struct gcpro gcpro1, gcpro2; - GCPRO2 (vector, predicate); USE_SAFE_ALLOCA; SAFE_ALLOCA_LISP (tmp, halflen); for (ptrdiff_t i = 0; i < halflen; i++) tmp[i] = make_number (0); sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp); SAFE_FREE (); - UNGCPRO; } DEFUN ("sort", Fsort, Ssort, 2, 2, 0, @@ -2008,27 +1995,15 @@ the second. */) Lisp_Object merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred) { - Lisp_Object value; - register Lisp_Object tail; - Lisp_Object tem; - register Lisp_Object l1, l2; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - - l1 = org_l1; - l2 = org_l2; - tail = Qnil; - value = Qnil; - - /* It is sufficient to protect org_l1 and org_l2. - When l1 and l2 are updated, we copy the new values - back into the org_ vars. */ - GCPRO4 (org_l1, org_l2, pred, value); + Lisp_Object l1 = org_l1; + Lisp_Object l2 = org_l2; + Lisp_Object tail = Qnil; + Lisp_Object value = Qnil; while (1) { if (NILP (l1)) { - UNGCPRO; if (NILP (tail)) return l2; Fsetcdr (tail, l2); @@ -2036,12 +2011,13 @@ merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred) } if (NILP (l2)) { - UNGCPRO; if (NILP (tail)) return l1; Fsetcdr (tail, l1); return value; } + + Lisp_Object tem; if (inorder (pred, Fcar (l1), Fcar (l2))) { tem = l1; @@ -2415,9 +2391,9 @@ ARRAY is a vector, string, char-table, or bool-vector. */) unsigned char str[MAX_MULTIBYTE_LENGTH]; int len = CHAR_STRING (charval, str); ptrdiff_t size_byte = SBYTES (array); + ptrdiff_t product; - if (INT_MULTIPLY_OVERFLOW (SCHARS (array), len) - || SCHARS (array) * len != size_byte) + if (INT_MULTIPLY_WRAPV (size, len, &product) || product != size_byte) error ("Attempt to change byte length of a string"); for (idx = 0; idx < size_byte; idx++) *p++ = str[idx % len]; @@ -2504,22 +2480,6 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) { Lisp_Object tail, dummy; EMACS_INT i; - struct gcpro gcpro1, gcpro2, gcpro3; - - if (vals) - { - /* Don't let vals contain any garbage when GC happens. */ - memclear (vals, leni * word_size); - - GCPRO3 (dummy, fn, seq); - gcpro1.var = vals; - gcpro1.nvars = leni; - } - else - GCPRO2 (fn, seq); - /* We need not explicitly protect `tail' because it is used only on lists, and - 1) lists are not relocated and 2) the list is marked via `seq' so will not - be freed */ if (VECTORP (seq) || COMPILEDP (seq)) { @@ -2566,8 +2526,6 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) tail = XCDR (tail); } } - - UNGCPRO; } DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0, @@ -2578,11 +2536,10 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */) (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator) { Lisp_Object len; - register EMACS_INT leni; + EMACS_INT leni; EMACS_INT nargs; ptrdiff_t i; - register Lisp_Object *args; - struct gcpro gcpro1; + Lisp_Object *args; Lisp_Object ret; USE_SAFE_ALLOCA; @@ -2595,9 +2552,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */) SAFE_ALLOCA_LISP (args, nargs); - GCPRO1 (separator); mapcar1 (leni, args, function, sequence); - UNGCPRO; for (i = leni - 1; i > 0; i--) args[i + i] = args[i]; @@ -2655,9 +2610,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */) } /* This is how C code calls `yes-or-no-p' and allows the user - to redefined it. - - Anything that calls this function must protect from GC! */ + to redefine it. */ Lisp_Object do_yes_or_no_p (Lisp_Object prompt) @@ -2665,8 +2618,6 @@ do_yes_or_no_p (Lisp_Object prompt) return call1 (intern ("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, doc: /* Ask user a yes-or-no question. Return t if answer is yes, and nil if the answer is no. @@ -2681,27 +2632,23 @@ if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */) (Lisp_Object prompt) { Lisp_Object ans; - struct gcpro gcpro1; CHECK_STRING (prompt); if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) - && use_dialog_box) + && use_dialog_box && ! NILP (last_input_event)) { Lisp_Object pane, menu, obj; redisplay_preserve_echo_area (4); pane = list2 (Fcons (build_string ("Yes"), Qt), Fcons (build_string ("No"), Qnil)); - GCPRO1 (pane); menu = Fcons (prompt, pane); obj = Fx_popup_dialog (Qt, menu, Qnil); - UNGCPRO; return obj; } AUTO_STRING (yes_or_no, "(yes or no) "); prompt = CALLN (Fconcat, prompt, yes_or_no); - GCPRO1 (prompt); while (1) { @@ -2709,15 +2656,9 @@ if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */) Qyes_or_no_p_history, Qnil, Qnil)); if (SCHARS (ans) == 3 && !strcmp (SSDATA (ans), "yes")) - { - UNGCPRO; - return Qt; - } + return Qt; if (SCHARS (ans) == 2 && !strcmp (SSDATA (ans), "no")) - { - UNGCPRO; - return Qnil; - } + return Qnil; Fding (Qnil); Fdiscard_input (); @@ -2821,20 +2762,27 @@ require_unwind (Lisp_Object old_value) DEFUN ("require", Frequire, Srequire, 1, 3, 0, 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' or -`.el', in that order. The name without appended suffix will not be used. -See `get-load-suffixes' for the complete list of suffixes. -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. */) +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 system-dependent suffix for dynamic module +files, in that order. The name without appended suffix will not be +used. See `get-load-suffixes' for the complete list of suffixes. + +The directories in `load-path' are searched when trying to find the +file name. + +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. */) (Lisp_Object feature, Lisp_Object filename, Lisp_Object noerror) { Lisp_Object tem; - struct gcpro gcpro1, gcpro2; bool from_file = load_in_progress; CHECK_SYMBOL (feature); @@ -2890,10 +2838,8 @@ The normal messages at start and end of loading FILENAME are suppressed. */) Vautoload_queue = Qt; /* 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)) @@ -2922,7 +2868,7 @@ The normal messages at start and end of loading FILENAME are suppressed. */) DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0, 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. +\(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. */) @@ -2930,9 +2876,9 @@ The value is actually the tail of PLIST whose car is PROP. */) { while (CONSP (plist) && !EQ (XCAR (plist), prop)) { - QUIT; plist = XCDR (plist); plist = CDR (plist); + QUIT; } return plist; } @@ -2979,15 +2925,11 @@ ARGS are passed as extra arguments to the function. usage: (widget-apply WIDGET PROPERTY &rest ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) { - /* This function can GC. */ - struct gcpro gcpro1, gcpro2; Lisp_Object widget = args[0]; Lisp_Object property = args[1]; Lisp_Object propval = Fwidget_get (widget, property); Lisp_Object trailing_args = Flist (nargs - 2, args + 2); - GCPRO2 (propval, trailing_args); Lisp_Object result = CALLN (Fapply, propval, widget, trailing_args); - UNGCPRO; return result; } @@ -3030,8 +2972,6 @@ The data read from the system are decoded using `locale-coding-system'. */) Lisp_Object v = Fmake_vector (make_number (7), Qnil); const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7}; int i; - struct gcpro gcpro1; - GCPRO1 (v); synchronize_system_time_locale (); for (i = 0; i < 7; i++) { @@ -3042,7 +2982,6 @@ The data read from the system are decoded using `locale-coding-system'. */) ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system, 0)); } - UNGCPRO; return v; } #endif /* DAY_1 */ @@ -3053,8 +2992,6 @@ The data read from the system are decoded using `locale-coding-system'. */) const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7, MON_8, MON_9, MON_10, MON_11, MON_12}; int i; - struct gcpro gcpro1; - GCPRO1 (v); synchronize_system_time_locale (); for (i = 0; i < 12; i++) { @@ -3063,7 +3000,6 @@ The data read from the system are decoded using `locale-coding-system'. */) ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system, 0)); } - UNGCPRO; return v; } #endif /* MON_1 */ @@ -3693,8 +3629,7 @@ larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max) Low-level Functions ***********************************************************************/ -static struct hash_table_test hashtest_eq; -struct hash_table_test hashtest_eql, hashtest_equal; +struct hash_table_test hashtest_eq, hashtest_eql, hashtest_equal; /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code HASH2 in hash table H using `eql'. Value is true if KEY1 and @@ -3954,8 +3889,7 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h) #ifdef ENABLE_CHECKING if (HASH_TABLE_P (Vpurify_flag) && XHASH_TABLE (Vpurify_flag) == h) - CALLN (Fmessage, build_string ("Growing hash table to: %d"), - make_number (new_size)); + message ("Growing hash table to: %"pI"d", new_size); #endif set_hash_key_and_value (h, larger_vector (h->key_and_value, @@ -4016,7 +3950,6 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash) start_of_bucket = hash_code % ASIZE (h->index); idx = HASH_INDEX (h, start_of_bucket); - /* We need not gcpro idx since it's either an integer or nil. */ while (!NILP (idx)) { ptrdiff_t i = XFASTINT (idx); @@ -4067,7 +4000,7 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value, /* Remove the entry matching KEY from hash table H, if there is one. */ -static void +void hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key) { EMACS_UINT hash_code; @@ -4080,7 +4013,6 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key) idx = HASH_INDEX (h, start_of_bucket); prev = Qnil; - /* We need not gcpro idx, prev since they're either integers or nil. */ while (!NILP (idx)) { ptrdiff_t i = XFASTINT (idx); @@ -4155,13 +4087,10 @@ hash_clear (struct Lisp_Hash_Table *h) static bool sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p) { - ptrdiff_t bucket, n; - bool marked; - - n = ASIZE (h->index) & ~ARRAY_MARK_FLAG; - marked = 0; + ptrdiff_t n = gc_asize (h->index); + bool marked = false; - for (bucket = 0; bucket < n; ++bucket) + for (ptrdiff_t bucket = 0; bucket < n; ++bucket) { Lisp_Object idx, next, prev; @@ -5074,8 +5003,6 @@ syms_of_fns (void) defsubr (&Sdefine_hash_table_test); DEFSYM (Qstring_lessp, "string-lessp"); - DEFSYM (Qstring_collate_lessp, "string-collate-lessp"); - DEFSYM (Qstring_collate_equalp, "string-collate-equalp"); DEFSYM (Qprovide, "provide"); DEFSYM (Qrequire, "require"); DEFSYM (Qyes_or_no_p_history, "yes-or-no-p-history");