From cca47ae555bfddf87b4871988555738c335f8457 Mon Sep 17 00:00:00 2001 From: Kaushal Modi Date: Sun, 10 Apr 2022 13:52:15 +0200 Subject: Update docstrings for shortdoc.el FUNC lisp form API * lisp/emacs-lisp/shortdoc.el (define-short-documentation-group): Updated docstrings. --- lisp/emacs-lisp/shortdoc.el | 70 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 55 insertions(+), 15 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 658edd67527..ebf3c6b1fe9 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -47,30 +47,67 @@ "Add GROUP to the list of defined documentation groups. FUNCTIONS is a list of elements on the form: - (fun + (FUNC :no-manual BOOL :args ARGS - :eval EXAMPLE-FORM + :eval EVAL :no-eval EXAMPLE-FORM - :no-eval* EXAMPLE-FORM :no-value EXAMPLE-FORM + :no-eval* EXAMPLE-FORM :result RESULT-FORM - :result-string RESULT-FORM + :result-string RESULT-STRING :eg-result RESULT-FORM - :eg-result-string RESULT-FORM) + :eg-result-string RESULT-STRING) -BOOL should be non-nil if the function isn't documented in the +FUNC is the function being documented. + +NO-MANUAL should be non-nil if FUNC isn't documented in the manual. -ARGS is optional; the function's signature is displayed if ARGS -is not present. +ARGS is optional list of function FUNC's arguments. FUNC's +signature is displayed automatically if ARGS is not present. +Specifying ARGS might be useful where you don't want to document +some of the uncommon arguments a function might have. + +While the `:no-manual' and `:args' property can be used for +any (FUNC ..) form, all of the other properties shown above +cannot be used simultaneously in such a form. -If EVAL isn't a string, it will be printed with `prin1', and then -evaluated to give a result, which is also printed. If it's a -string, it'll be inserted as is, then the string will be `read', -and then evaluated. +Here are some common forms with examples of properties that go +together: -There can be any number of :example/:result elements." +1. Document a form or string, and its evaluated return value. + (FUNC + :eval EVAL) + +If EVAL is a string, it will be inserted as is, and then that +string will be `read' and evaluated. + +2. Document a form or string, but manually document its evalation + result. The provided form will not be evaluated. + + (FUNC + :no-eval EXAMPLE-FORM + :result RESULT-FORM ;Use `:result-string' if value is in string form + ) + +Using `:no-value' is the same as using `:no-eval'. + +Use `:no-eval*' instead of `:no-eval' where the successful +execution of the documented form depends on some conditions. + +3. Document a form or string EXAMPLE-FORM. Also manually + document an example result. This result could be unrelated to + the documented form. + + (FUNC + :no-eval EXAMPLE-FORM + :eg-result RESULT-FORM ;Use `:eg-result-string' if value is in string form + ) + +A FUNC form can have any number of `:no-eval' (or `:no-value'), +`:no-eval*', `:result', `:result-string', `:eg-result' and +`:eg-result-string' properties." (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) @@ -1408,11 +1445,14 @@ function's documentation in the Info manual"))) If GROUP doesn't exist, it will be created. If SECTION doesn't exist, it will be added. +ELEM is a Lisp form. See `define-short-documentation-group' for +details. + Example: (shortdoc-add-function - 'file \"Predicates\" - '(file-locked-p :no-eval (file-locked-p \"/tmp\")))" + \\='file \"Predicates\" + \\='(file-locked-p :no-eval (file-locked-p \"/tmp\")))" (let ((glist (assq group shortdoc--groups))) (unless glist (setq glist (list group)) -- cgit v1.2.3 From 1cda7cfb390c9612caf73e977d64d9e0eff5735c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 6 May 2022 16:21:07 +0200 Subject: Respect help-window-keep-selected in shortdoc buttons * lisp/help-fns.el (help-fns--mention-shortdoc-groups): Respect help-window-keep-selected. * lisp/emacs-lisp/shortdoc.el (shortdoc-display-group): Allow reusing the window. --- lisp/emacs-lisp/shortdoc.el | 10 +++++++--- lisp/help-fns.el | 3 ++- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index ebf3c6b1fe9..340fe766c1e 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1298,16 +1298,20 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (keymap-lookup (current-global-map) "C-x x g"))) ;;;###autoload -(defun shortdoc-display-group (group &optional function) +(defun shortdoc-display-group (group &optional function same-window) "Pop to a buffer with short documentation summary for functions in GROUP. -If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." +If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). +If SAME-WINDOW, don't pop to a new window." (interactive (list (completing-read "Show summary for functions in: " (mapcar #'car shortdoc--groups)))) (when (stringp group) (setq group (intern group))) (unless (assq group shortdoc--groups) (error "No such documentation group %s" group)) - (pop-to-buffer (format "*Shortdoc %s*" group)) + (funcall (if same-window + #'pop-to-buffer-same-window + #'pop-to-buffer) + (format "*Shortdoc %s*" group)) (let ((inhibit-read-only t) (prev nil)) (erase-buffer) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0cb2c6d5d77..927a4f0d2c4 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -837,7 +837,8 @@ the C sources, too." (insert-text-button (symbol-name group) 'action (lambda (_) - (shortdoc-display-group group object)) + (shortdoc-display-group group object + help-window-keep-selected)) 'follow-link t 'help-echo (purecopy "mouse-1, RET: show documentation group"))) groups) -- cgit v1.2.3 From 09674074b57bee74ff1039f8ef08c2dea321c0da Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sun, 15 May 2022 11:15:06 +0200 Subject: ; Fix typos --- config.bat | 2 +- lisp/emacs-lisp/shortdoc.el | 2 +- lisp/eshell/esh-opt.el | 2 +- lisp/image/image-converter.el | 2 +- lisp/international/mule.el | 2 +- lisp/net/eww.el | 2 +- lisp/progmodes/cc-engine.el | 2 +- lisp/progmodes/erts-mode.el | 6 +++--- lisp/progmodes/sql.el | 2 +- lisp/replace.el | 2 +- lisp/x-dnd.el | 2 +- lisp/xwidget.el | 2 +- src/haiku_support.cc | 2 +- src/haikuterm.c | 2 +- src/image.c | 2 +- src/lread.c | 2 +- src/pgtkfns.c | 4 ++-- src/pgtkterm.c | 2 +- src/pgtkterm.h | 2 +- src/sort.c | 2 +- src/w32term.c | 2 +- src/xterm.c | 8 ++++---- test/lisp/ansi-color-tests.el | 2 +- test/lisp/files-tests.el | 2 +- test/lisp/net/tramp-tests.el | 4 ++-- 25 files changed, 32 insertions(+), 32 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/config.bat b/config.bat index 758e4621386..e9a180c8eed 100644 --- a/config.bat +++ b/config.bat @@ -310,7 +310,7 @@ rm -f makefile.tmp sed -f ../msdos/sedlibcf.inp < gnulib.mk-in > gnulib.tmp sed -f ../msdos/sedlibmk.inp < gnulib.tmp > gnulib.mk rm -f gnulib.tmp -Rem Create directorys in lib/ that MKDIR_P is supposed to create +Rem Create directories in lib/ that MKDIR_P is supposed to create Rem but I have no idea how to do that on MS-DOS. mkdir sys Rem Create .d files for new files in lib/ and lib/malloc/ diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 340fe766c1e..4c8ca967f12 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -83,7 +83,7 @@ together: If EVAL is a string, it will be inserted as is, and then that string will be `read' and evaluated. -2. Document a form or string, but manually document its evalation +2. Document a form or string, but manually document its evaluation result. The provided form will not be evaluated. (FUNC diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index 0961e214f4f..f52b70fe7a6 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -205,7 +205,7 @@ a long option." VALUE is the potential value of the OPT, coming from args like \"-fVALUE\" or \"--foo=VALUE\", or nil if no value was supplied. If OPT doesn't consume a value, return VALUE unchanged so that it can be -processed later; otherwsie, return nil. +processed later; otherwise, return nil. If the OPT consumes an argument for its value and VALUE is nil, the argument list will be modified." diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index 7914d28c293..9440c623f90 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -49,7 +49,7 @@ formats that are to be supported: Only the suffixes that map to (defcustom image-convert-to-format "png" "The image format to convert to. This should be a string like \"png\" or \"ppm\" or some -other (preferrably lossless) format that Emacs understands +other (preferably lossless) format that Emacs understands natively. The converter chosen has to support the format, and if not, conversion will fail." :group 'image diff --git a/lisp/international/mule.el b/lisp/international/mule.el index 1596cdb4817..ab74c2cffd9 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -310,7 +310,7 @@ Print messages at start and end of loading unless optional fourth arg NOMESSAGE is non-nil. If EVAL-FUNCTION, call that instead of calling `eval-buffer' -directly. It is called with two paramameters: The buffer object +directly. It is called with two parameters: The buffer object and the file name. Return t if file exists." diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 57cb566c95d..21f6e33b0d2 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1855,7 +1855,7 @@ The browser to used is specified by the (replace-regexp-in-string ".utm_.*" "" url)) (defun eww--transform-url (url) - "Appy `eww-url-transformers'." + "Apply `eww-url-transformers'." (when url (dolist (func eww-url-transformers) (setq url (funcall func url))) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index ae68bf989a7..2a9a7a8bf5e 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -6848,7 +6848,7 @@ comment at the start of cc-engine.el for more info." ;; checking `c-new-id-start' and `c-new-id-end'. That's done to avoid ;; adding all prefixes of a type as it's being entered and font locked. ;; This is a bit rough and ready, but now covers adding characters into the - ;; middle of an identifer. + ;; middle of an identifier. ;; ;; This function might do hidden buffer changes. (if (and c-new-id-start c-new-id-end diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el index 31a8bded8ad..1b88540ff38 100644 --- a/lisp/progmodes/erts-mode.el +++ b/lisp/progmodes/erts-mode.el @@ -51,17 +51,17 @@ :foreground "blue") (t :bold t)) - "Face used for displaying specificaton values." + "Face used for displaying specification values." :group 'erts-mode) (defface erts-mode-start-test '((t :inherit font-lock-keyword-face)) - "Face used for displaying specificaton test start markers." + "Face used for displaying specification test start markers." :group 'erts-mode) (defface erts-mode-end-test '((t :inherit font-lock-comment-face)) - "Face used for displaying specificaton test start markers." + "Face used for displaying specification test start markers." :group 'erts-mode) (defvar erts-mode-map diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 979b743a65d..7bb4fef0c09 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -4179,7 +4179,7 @@ must tell Emacs. Here's how to do that in your init file: ;; start a comment. (string-to-syntax ".") ;; Inside a comment, ignore it to avoid -*/ not - ;; being intepreted as a comment end. + ;; being interpreted as a comment end. (forward-char -1) nil))))) ;; Set syntax and font-face highlighting diff --git a/lisp/replace.el b/lisp/replace.el index 81282deb140..3d0877a9a64 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2684,7 +2684,7 @@ It is called with three arguments, as if it were "Function to convert the FROM string of query-replace commands to a regexp. This is used by `query-replace', `query-replace-regexp', etc. as the value of `isearch-regexp-function' when they search for the -occurences of the string/regexp to be replaced. This is intended +occurrences of the string/regexp to be replaced. This is intended to be used when the string to be replaced, as typed by the user, is not to be interpreted literally, but instead should be converted to a regexp that is actually used for the search.") diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 13a73aa7fb3..f3abb9d5e6d 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -784,7 +784,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." ;;; Handling drops. (defun x-dnd-handle-unsupported-drop (targets _x _y action _window-id _frame _time) - "Return non-nil if the drop described by TARGETS and ACTION should not proceeed." + "Return non-nil if the drop described by TARGETS and ACTION should not proceed." (not (and (or (eq action 'XdndActionCopy) (eq action 'XdndActionMove)) (or (member "STRING" targets) diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 62da16d486a..88bc8ff6c5e 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -451,7 +451,7 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." xwidget-webkit--progress-update-timer (run-at-time 0.5 0.5 #'xwidget-webkit--update-progress-timer-function xwidget))))) - ;; This funciton will be called multi times, so only + ;; This function will be called multi times, so only ;; change buffer name when the load actually completes ;; this can limit buffer-name flicker in mode-line. (when (or (string-equal (nth 3 last-input-event) diff --git a/src/haiku_support.cc b/src/haiku_support.cc index ac2f4f39ea0..2143f14dc97 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -143,7 +143,7 @@ struct font_selection_dialog_message /* Whether or not font selection was cancelled. */ bool_bf cancel : 1; - /* Whether or not a size was explictly specified. */ + /* Whether or not a size was explicitly specified. */ bool_bf size_specified : 1; /* The index of the selected font family. */ diff --git a/src/haikuterm.c b/src/haikuterm.c index 57f5b052f6d..df0cd82a39e 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3036,7 +3036,7 @@ haiku_flush_dirty_back_buffer_on (struct frame *f) haiku_flip_buffers (f); } -/* N.B. that support for TYPE must be explictly added to +/* N.B. that support for TYPE must be explicitly added to haiku_read_socket. */ void haiku_wait_for_event (struct frame *f, int type) diff --git a/src/image.c b/src/image.c index dfa53279927..18e9e72d83c 100644 --- a/src/image.c +++ b/src/image.c @@ -9108,7 +9108,7 @@ gif_load (struct frame *f, struct image *img) goto gif_error; } - /* It's an animated image, so initalize the cache. */ + /* It's an animated image, so initialize the cache. */ if (cache && !cache->handle) { cache->handle = gif; diff --git a/src/lread.c b/src/lread.c index 2538851bac6..409e97cdfa6 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3497,7 +3497,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) /* Optimisation: since the placeholder is already a cons, repurpose it as the actual value. - This allows us to skip the substition below, + This allows us to skip the substitution below, since the placeholder is already referenced inside TEM at the appropriate places. */ Fsetcar (placeholder, XCAR (tem)); diff --git a/src/pgtkfns.c b/src/pgtkfns.c index a0fcf70f31b..1feb3fe250d 100644 --- a/src/pgtkfns.c +++ b/src/pgtkfns.c @@ -848,7 +848,7 @@ pgtk_set_scroll_bar_background (struct frame *f, Lisp_Object new_value, error ("Unknown color."); /* On pgtk, this frame parameter should be ignored, and honor - gtk theme. (It honors the GTK theme if not explictly set, so + gtk theme. (It honors the GTK theme if not explicitly set, so I see no harm in letting users tinker a bit more.) */ char css[64]; sprintf (css, "scrollbar trough { background-color: #%06x; }", @@ -2853,7 +2853,7 @@ x_create_tip_frame (struct pgtk_display_info *dpyinfo, Lisp_Object parms, struct Frame parameters may be changed if .Xdefaults contains specifications for the default font. For example, if there is an `Emacs.default.attributeBackground: pink', the `background-color' - attribute of the frame get's set, which let's the internal border + attribute of the frame gets set, which lets the internal border of the tooltip frame appear in pink. Prevent this. */ { Lisp_Object bg = Fframe_parameter (frame, Qbackground_color); diff --git a/src/pgtkterm.c b/src/pgtkterm.c index 11ab40a0d39..b9d0b7b512e 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -2551,7 +2551,7 @@ pgtk_draw_glyph_string (struct glyph_string *s) } /* Ignore minimum_offset if the amount of pixels was - explictly specified. */ + explicitly specified. */ if (!s->face->underline_pixels_above_descent_line) position = max (position, underline_minimum_offset); } diff --git a/src/pgtkterm.h b/src/pgtkterm.h index 20c161e63b9..e31e62ae193 100644 --- a/src/pgtkterm.h +++ b/src/pgtkterm.h @@ -96,7 +96,7 @@ struct scroll_bar editing large files, we establish a minimum height by always drawing handle bottoms VERTICAL_SCROLL_BAR_MIN_HANDLE pixels below where they would be normally; the bottom and top are in a - different co-ordinate system. */ + different coordinate system. */ int start, end; /* If the scroll bar handle is currently being dragged by the user, diff --git a/src/sort.c b/src/sort.c index c7ccfc23055..d10ae692d33 100644 --- a/src/sort.c +++ b/src/sort.c @@ -783,7 +783,7 @@ merge_at (merge_state *ms, const ptrdiff_t i) } -/* Compute the "power" of the first of two adjacent runs begining at +/* Compute the "power" of the first of two adjacent runs beginning at index S1, with the first having length N1 and the second (starting at index S1+N1) having length N2. The run has total length N. */ diff --git a/src/w32term.c b/src/w32term.c index 19786da3a6d..da7ac379723 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -2720,7 +2720,7 @@ w32_draw_glyph_string (struct glyph_string *s) if (!(s->face->underline_at_descent_line_p /* Ignore minimum_offset if the amount of pixels - was explictly specified. */ + was explicitly specified. */ && s->face->underline_pixels_above_descent_line)) position = max (position, minimum_offset); } diff --git a/src/xterm.c b/src/xterm.c index bb92e1bbe66..21c31271ca5 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -78,7 +78,7 @@ along with GNU Emacs. If not, see . */ INPUT FOCUS Under X, the window where keyboard input is sent is not always - explictly defined. When there is a focus window, it receives what + explicitly defined. When there is a focus window, it receives what is referred to as "explicit focus", but when there is none, it receives "implicit focus" whenever the pointer enters it, and loses that focus when the pointer leaves. When the toplevel window of a @@ -2515,7 +2515,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) } /* And the common case where there is no input rect and the - bouding rect equals the window dimensions. */ + bounding rect equals the window dimensions. */ if (tem->n_input_rects == -1 && tem->n_bounding_rects == 1 @@ -8781,7 +8781,7 @@ x_draw_glyph_string (struct glyph_string *s) } /* Ignore minimum_offset if the amount of pixels was - explictly specified. */ + explicitly specified. */ if (!s->face->underline_pixels_above_descent_line) position = max (position, minimum_offset); } @@ -19973,7 +19973,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } /* And the common case where there is no input rect and the - bouding rect equals the window dimensions. */ + bounding rect equals the window dimensions. */ if (tem->n_input_rects == -1 && tem->n_bounding_rects == 1 diff --git a/test/lisp/ansi-color-tests.el b/test/lisp/ansi-color-tests.el index 2ff7fc6aaf6..1b04e8e9def 100644 --- a/test/lisp/ansi-color-tests.el +++ b/test/lisp/ansi-color-tests.el @@ -173,7 +173,7 @@ strings with `eq', this function compares them with `equal'." (should (ansi-color-tests-equal-props propertized-str (buffer-string)))) - ;; \e not followed by '[' and invalid ANSI escape seqences + ;; \e not followed by '[' and invalid ANSI escape sequences (dolist (fun (list ansi-filt ansi-app)) (with-temp-buffer (should (equal (funcall fun "\e") "")) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 7d17fbde672..978f96912fb 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -1691,7 +1691,7 @@ FN-TEST is the function to test: either `save-some-buffers' or specified inside ARGS-RESULTS. During the call to FN-TEST,`read-event' is overridden with a function that -just returns `n' and `kill-emacs' is overriden to do nothing. +just returns `n' and `kill-emacs' is overridden to do nothing. ARGS-RESULTS is a list of elements (FN-ARGS CALLERS-DIR EXPECTED), where FN-ARGS are the arguments for FN-TEST; diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index fa5a614fbf4..d9c5df17908 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -6461,7 +6461,7 @@ This requires restrictions of file name syntax." (defun tramp--test-asynchronous-processes-p () "Whether asynchronous processes tests are run. -This is used in tests which we dont't want to tag +This is used in tests which we don't want to tag `:tramp-asynchronous-processes' completely." (and (ert-select-tests @@ -6484,7 +6484,7 @@ This does not support some special file names." (defun tramp--test-expensive-test-p () "Whether expensive tests are run. -This is used in tests which we dont't want to tag `:expensive' +This is used in tests which we don't want to tag `:expensive' completely." (ert-select-tests (ert--stats-selector ert--current-run-stats) -- cgit v1.2.3 From acf27496cbf10e3ac2d36f6be1f1413691925eef Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 4 Jun 2022 11:23:53 +0200 Subject: * lisp/emacs-lisp/shortdoc.el (string): Add `string-collate-lessp'. --- lisp/emacs-lisp/shortdoc.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 4c8ca967f12..5c94b06e767 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -264,7 +264,12 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (string-greaterp :eval (string-greaterp "foo" "bar")) (string-version-lessp - :eval (string-version-lessp "pic4.png" "pic32.png")) + :eval (string-version-lessp "pic4.png" "pic32.png") + :eval (string-lessp "pic4.png" "pic32.png")) + (string-collate-lessp + :eval (string-collate-lessp "1.1" "1 2") + :eval (string-version-lessp "1.1" "1 2") + :eval (string-lessp "1.1" "1 2")) (string-prefix-p :eval (string-prefix-p "foo" "foobar")) (string-suffix-p -- cgit v1.2.3 From d37d099ad7968ed9217599faa168571699fa03e4 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 4 Jun 2022 14:04:41 +0200 Subject: Fix failing shortdoc test * lisp/emacs-lisp/shortdoc.el (string): Each example section is supposed to contain only examples of using the function in question (as policed by the FAILED shortdoc-examples test). --- lisp/emacs-lisp/shortdoc.el | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 5c94b06e767..92b9c1dd32e 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -260,16 +260,16 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :no-manual t :eval (string-blank-p " \n")) (string-lessp - :eval (string-lessp "foo" "bar")) + :eval (string-lessp "foo" "bar") + :eval (string-lessp "pic4.png" "pic32.png") + :eval (string-lessp "1.1" "1 2")) (string-greaterp :eval (string-greaterp "foo" "bar")) (string-version-lessp :eval (string-version-lessp "pic4.png" "pic32.png") - :eval (string-lessp "pic4.png" "pic32.png")) + :eval (string-version-lessp "1.1" "1 2")) (string-collate-lessp - :eval (string-collate-lessp "1.1" "1 2") - :eval (string-version-lessp "1.1" "1 2") - :eval (string-lessp "1.1" "1 2")) + :eval (string-collate-lessp "1.1" "1 2")) (string-prefix-p :eval (string-prefix-p "foo" "foobar")) (string-suffix-p -- cgit v1.2.3 From d8924e179e2e53bf9abffa987f428890b4edcf57 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 5 Jun 2022 14:08:31 +0200 Subject: Extend file-expand-wildcards to allow regexps * doc/lispref/files.texi (Contents of Directories): Document it. * lisp/files.el (file-expand-wildcards): Extend to allow regexps. * lisp/emacs-lisp/shortdoc.el (file): Expand the file-expand-wildcards example. --- doc/lispref/files.texi | 8 +++++++- etc/NEWS | 3 +++ lisp/emacs-lisp/shortdoc.el | 4 +++- lisp/files.el | 23 +++++++++++++++++------ 4 files changed, 30 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 75905658e64..d4732610262 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -3112,10 +3112,16 @@ except those two. It is useful as the @var{match-regexp} argument to returns @code{nil}, if directory @samp{/foo} is empty. @end defvr -@defun file-expand-wildcards pattern &optional full +@defun file-expand-wildcards pattern &optional full regexp This function expands the wildcard pattern @var{pattern}, returning a list of file names that match it. +@var{pattern} is, by default, a ``glob''/wildcard string, e.g., +@samp{"/tmp/*.png"} or @samp{"/*/*/foo.png"}, but can also be a +regular expression if the optional @var{regexp} parameter is non-nil. +In any case, the matches are applied per sub-directory, so a match +can't span a parent/sub directory. + If @var{pattern} is written as an absolute file name, the values are absolute also. diff --git a/etc/NEWS b/etc/NEWS index 551aea411ea..a46bf850b10 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1936,6 +1936,9 @@ Previously it produced a nonsense value, -1, that was never intended. * Lisp Changes in Emacs 29.1 ++++ +** 'file-expand-wildcards' can now also take a regexp match. + --- ** vc-mtn (the backend for Monotone) has been made obsolete. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 92b9c1dd32e..a1256ce1b8b 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -468,7 +468,9 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :no-eval* (directory-files-and-attributes "/tmp/foo")) (file-expand-wildcards :no-eval (file-expand-wildcards "/tmp/*.png") - :eg-result ("/tmp/foo.png" "/tmp/zot.png")) + :eg-result ("/tmp/foo.png" "/tmp/zot.png") + :no-eval (file-expand-wildcards "/*/foo.png") + :eg-result ("/tmp/foo.png" "/var/foo.png")) (locate-dominating-file :no-eval (locate-dominating-file "foo.png" "/tmp/foo/bar/zot") :eg-result "/tmp/foo.png") diff --git a/lisp/files.el b/lisp/files.el index b5da0ea5c52..95f5b2c5358 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -7198,13 +7198,21 @@ by `sh' are supported." :type 'string :group 'dired) -(defun file-expand-wildcards (pattern &optional full) +(defun file-expand-wildcards (pattern &optional full regexp) "Expand wildcard pattern PATTERN. This returns a list of file names that match the pattern. -Files are sorted in `string<' order. -If PATTERN is written as an absolute file name, -the values are absolute also. +PATTERN is, by default, a \"glob\"/wildcard string, e.g., +\"/tmp/*.png\" or \"/*/*/foo.png\", but can also be a regular +expression if the optional REGEXP parameter is non-nil. In any +case, the matches are applied per sub-directory, so a match can't +span a parent/sub directory, which means that a regexp bit can't +contain the \"/\" character. + +The list of files returned are sorted in `string<' order. + +If PATTERN is written as an absolute file name, the values are +absolute also. If PATTERN is written as a relative file name, it is interpreted relative to the current default directory, `default-directory'. @@ -7219,7 +7227,8 @@ default directory. However, if FULL is non-nil, they are absolute." (dirs (if (and dirpart (string-match "[[*?]" (file-local-name dirpart))) (mapcar 'file-name-as-directory - (file-expand-wildcards (directory-file-name dirpart))) + (file-expand-wildcards + (directory-file-name dirpart) nil regexp)) (list dirpart))) contents) (dolist (dir dirs) @@ -7233,7 +7242,9 @@ default directory. However, if FULL is non-nil, they are absolute." (file-name-nondirectory name)) name)) (directory-files (or dir ".") full - (wildcard-to-regexp nondir)))))) + (if regexp + nondir + (wildcard-to-regexp nondir))))))) (setq contents (nconc (if (and dir (not full)) -- cgit v1.2.3 From 513acdc9b4495c5273c55447c47d21534deffc7f Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 27 Jun 2022 12:22:05 +0200 Subject: Allow plist-get/plist-put/plist-member to take a comparison function * doc/lispref/lists.texi (Plist Access): Document it. * lisp/filesets.el (filesets-reset-fileset) (filesets-ingroup-cache-get): (filesets-ingroup-cache-put): (filesets-build-menu-now): Don't use lax-plist functions. * lisp/simple.el (lax-plist-put, lax-plist-get): Moved here from fns.c and make obsolete. * lisp/emacs-lisp/byte-opt.el (side-effect-free-fns): Don't mark plist functions as side-effect-free or pure. * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Adjust type. * lisp/emacs-lisp/shortdoc.el (list): Don't document deprecated functions. * src/xdisp.c (build_desired_tool_bar_string): (display_mode_element): (store_mode_line_string): (display_string): (produce_stretch_glyph): (note_mode_line_or_margin_highlight): (note_mouse_highlight): * src/w32.c (serial_configure): * src/sysdep.c (serial_configure): * src/sound.c (parse_sound): * src/process.c (Fset_process_buffer): (Fset_process_sentinel): (Fprocess_contact): (Fmake_process): (Fmake_pipe_process): (Fset_network_process_option): (Fserial_process_configure): (Fmake_serial_process): (set_network_socket_coding_system): (finish_after_tls_connection): (connect_network_socket): (Fmake_network_process): (server_accept_connection): * src/lread.c (ADDPARAM): (hash_table_from_plist): * src/keyboard.c (make_lispy_position): * src/indent.c (check_display_width): * src/image.c (postprocess_image): * src/gnutls.c (gnutls_verify_boot): (Fgnutls_boot): (gnutls_symmetric): (Fgnutls_hash_mac): (Fgnutls_hash_digest): * src/dired.c (filter): * src/data.c (add_to_function_history): * src/coding.c (Fcoding_system_put): Adjust callers from Fplist_put (etc) to plist_put. * src/fns.c (plist_get): (plist_put): (plist_member): New functions (without optional third parameter) to be used in C code. * src/fns.c (Fplist_get, Fplist_put, Fplist_member): Take an optional predicate parameter (bug#47425). * src/lisp.h: Declare new plist_put, plist_get and plist_member functions. * test/lisp/json-tests.el (test-json-add-to-plist): Use plist-get. * test/src/fns-tests.el (test-cycle-lax-plist-get): (test-cycle-lax-plist-put): (lax-plist-get/odd-number-of-elements): (test-plist): Remove lax-plist tests, since semantics have changed (they no longer error out on cycles). --- doc/lispref/lists.texi | 29 ++++---- etc/NEWS | 4 ++ lisp/emacs-lisp/byte-opt.el | 4 +- lisp/emacs-lisp/comp.el | 4 +- lisp/emacs-lisp/shortdoc.el | 5 -- lisp/filesets.el | 10 +-- lisp/simple.el | 9 +++ src/coding.c | 2 +- src/data.c | 2 +- src/dired.c | 4 +- src/fns.c | 131 ++++++++++++++++++----------------- src/gnutls.c | 32 ++++----- src/image.c | 4 +- src/indent.c | 8 +-- src/intervals.c | 4 +- src/keyboard.c | 2 +- src/lisp.h | 4 ++ src/lread.c | 4 +- src/process.c | 164 ++++++++++++++++++++++---------------------- src/sound.c | 8 +-- src/sysdep.c | 42 ++++++------ src/textprop.c | 8 +-- src/w32.c | 30 ++++---- src/w32fns.c | 10 +-- src/w32image.c | 4 +- src/xdisp.c | 60 ++++++++-------- test/lisp/json-tests.el | 4 +- test/src/fns-tests.el | 65 +++++------------- 28 files changed, 323 insertions(+), 334 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 4a862ab0de2..a4f0ba815b1 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -1925,9 +1925,10 @@ and later discarded; this is not possible with a property list. The following functions can be used to manipulate property lists. They all compare property names using @code{eq}. -@defun plist-get plist property +@defun plist-get plist property &optional predicate This returns the value of the @var{property} property stored in the -property list @var{plist}. It accepts a malformed @var{plist} +property list @var{plist}. Comparisons are done with @var{predicate}, +and defaults to @code{eq}. It accepts a malformed @var{plist} argument. If @var{property} is not found in the @var{plist}, it returns @code{nil}. For example, @@ -1943,9 +1944,10 @@ returns @code{nil}. For example, @end example @end defun -@defun plist-put plist property value +@defun plist-put plist property value &optional predicate This stores @var{value} as the value of the @var{property} property in -the property list @var{plist}. It may modify @var{plist} destructively, +the property list @var{plist}. Comparisons are done with @var{predicate}, +and defaults to @code{eq}. It may modify @var{plist} destructively, or it may construct a new list structure without altering the old. The function returns the modified property list, so you can store that back in the place where you got @var{plist}. For example, @@ -1961,19 +1963,20 @@ in the place where you got @var{plist}. For example, @end defun @defun lax-plist-get plist property -Like @code{plist-get} except that it compares properties -using @code{equal} instead of @code{eq}. +This obsolete function is like @code{plist-get} except that it +compares properties using @code{equal} instead of @code{eq}. @end defun @defun lax-plist-put plist property value -Like @code{plist-put} except that it compares properties -using @code{equal} instead of @code{eq}. +This obsolete function is like @code{plist-put} except that it +compares properties using @code{equal} instead of @code{eq}. @end defun -@defun plist-member plist property +@defun plist-member plist property &optional predicate This returns non-@code{nil} if @var{plist} contains the given -@var{property}. Unlike @code{plist-get}, this allows you to distinguish -between a missing property and a property with the value @code{nil}. -The value is actually the tail of @var{plist} whose @code{car} is -@var{property}. +@var{property}. Comparisons are done with @var{predicate}, and +defaults to @code{eq}. Unlike @code{plist-get}, this allows you to +distinguish between a missing property and a property with the value +@code{nil}. The value is actually the tail of @var{plist} whose +@code{car} is @var{property}. @end defun diff --git a/etc/NEWS b/etc/NEWS index 57b72dc8468..831486bb79e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2150,6 +2150,10 @@ patcomp.el, pc-mode.el, pc-select.el, s-region.el, and sregex.el. * Lisp Changes in Emacs 29.1 ++++ +** 'plist-get', 'plist-put' and 'plist-member' are no longer limited to 'eq'. +These function now take an optional comparison predicate argument. + +++ ** 'read-multiple-choice' can now use long-form answers. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index a8741c53bbf..352ac40663c 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1361,7 +1361,7 @@ See Info node `(elisp) Integer Basics'." match-beginning match-end member memq memql min minibuffer-selected-window minibuffer-window mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string - parse-colon-path plist-get plist-member + parse-colon-path prefix-numeric-value previous-window prin1-to-string propertize degrees-to-radians radians-to-degrees rassq rassoc read-from-string regexp-opt @@ -1483,7 +1483,7 @@ See Info node `(elisp) Integer Basics'." ;; `assoc' and `assoc-default' are excluded since they are ;; impure if the test function is (consider `string-match'). assq rassq rassoc - plist-get lax-plist-get plist-member + lax-plist-get aref elt base64-decode-string base64-encode-string base64url-encode-string bool-vector-subsetp diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 53803b38184..4ce2ce75e10 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -475,8 +475,8 @@ Useful to hook into pass checkers.") (one-window-p (function (&optional t t) boolean)) (overlayp (function (t) boolean)) (parse-colon-path (function (string) cons)) - (plist-get (function (list t) t)) - (plist-member (function (list t) list)) + (plist-get (function (list t &optional t) t)) + (plist-member (function (list t &optional t) list)) (point (function () integer)) (point-marker (function () marker)) (point-max (function () integer)) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index a1256ce1b8b..d0f06358872 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -691,11 +691,6 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (plist-put :no-eval (setq plist (plist-put plist 'd 4)) :eq-result (a 1 b 2 c 3 d 4)) - (lax-plist-get - :eval (lax-plist-get '("a" 1 "b" 2 "c" 3) "b")) - (lax-plist-put - :no-eval (setq plist (lax-plist-put plist "d" 4)) - :eq-result '("a" 1 "b" 2 "c" 3 "d" 4)) (plist-member :eval (plist-member '(a 1 b 2 c 3) 'b)) "Data About Lists" diff --git a/lisp/filesets.el b/lisp/filesets.el index 83a914d58cc..b97dda3cd61 100644 --- a/lisp/filesets.el +++ b/lisp/filesets.el @@ -208,7 +208,7 @@ COND-FN takes one argument: the current element." (defun filesets-reset-fileset (&optional fileset no-cache) "Reset the cached values for one or all filesets." (setq filesets-submenus (if fileset - (lax-plist-put filesets-submenus fileset nil) + (plist-put filesets-submenus fileset nil #'equal) nil)) (setq filesets-has-changed-flag t) (setq filesets-update-cache-file-flag (or filesets-update-cache-file-flag @@ -1999,7 +1999,7 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings." (defun filesets-ingroup-cache-get (master) "Access to `filesets-ingroup-cache'." - (lax-plist-get filesets-ingroup-cache master)) + (plist-get filesets-ingroup-cache master #'equal)) (defun filesets-ingroup-cache-put (master file) "Access to `filesets-ingroup-cache'." @@ -2008,7 +2008,7 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings." (cons file (filesets-ingroup-cache-get emaster)) nil))) (setq filesets-ingroup-cache - (lax-plist-put filesets-ingroup-cache emaster this)))) + (plist-put filesets-ingroup-cache emaster this #'equal)))) (defun filesets-ingroup-collect-files (fs &optional remdupl-flag master depth) "Helper function for `filesets-ingroup-collect'. Collect file names." @@ -2305,12 +2305,12 @@ bottom up, set `filesets-submenus' to nil, first.)" ((null data)) (let* ((this (car data)) (name (filesets-data-get-name this)) - (cached (lax-plist-get filesets-submenus name)) + (cached (plist-get filesets-submenus name #'equal)) (submenu (or cached (filesets-build-submenu count name this)))) (unless cached (setq filesets-submenus - (lax-plist-put filesets-submenus name submenu))) + (plist-put filesets-submenus name submenu #'equal))) (unless (filesets-entry-get-dormant-flag this) (setq filesets-menu-cache (append filesets-menu-cache (list submenu)))))) diff --git a/lisp/simple.el b/lisp/simple.el index 6d62c028657..83185c4e1a8 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -10640,6 +10640,15 @@ If the buffer doesn't exist, create it first." (string-to-number value) (intern (concat "sig" (downcase value)))))) +(defun lax-plist-get (plist prop) + "Extract a value from a property list, comparing with `equal'." + (declare (obsolete plist-get "29.1")) + (plist-get plist prop #'equal)) + +(defun lax-plist-put (plist prop val) + "Change value in PLIST of PROP to VAL, comparing with `equal'." + (declare (obsolete plist-put "29.1")) + (plist-put plist prop val #'equal)) (provide 'simple) diff --git a/src/coding.c b/src/coding.c index 68f3201de80..3fb4f148b1c 100644 --- a/src/coding.c +++ b/src/coding.c @@ -11499,7 +11499,7 @@ DEFUN ("coding-system-put", Fcoding_system_put, Scoding_system_put, } ASET (attrs, coding_attr_plist, - Fplist_put (CODING_ATTR_PLIST (attrs), prop, val)); + plist_put (CODING_ATTR_PLIST (attrs), prop, val)); return val; } diff --git a/src/data.c b/src/data.c index d665da04da6..1dbec4687b8 100644 --- a/src/data.c +++ b/src/data.c @@ -874,7 +874,7 @@ add_to_function_history (Lisp_Object symbol, Lisp_Object olddef) if (NILP (XCDR (tail)) && STRINGP (XCAR (tail))) file = XCAR (tail); - Lisp_Object tem = Fplist_member (past, file); + Lisp_Object tem = plist_member (past, file); if (!NILP (tem)) { /* New def from a file used before. Overwrite the previous record associated with this file. */ diff --git a/src/dired.c b/src/dired.c index e31ad9121c9..6bb8c2fcb9f 100644 --- a/src/dired.c +++ b/src/dired.c @@ -482,8 +482,8 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, decoded names in order to filter false positives, such as "a" falsely matching "a-ring". */ if (!NILP (file_encoding) - && !NILP (Fplist_get (Fcoding_system_plist (file_encoding), - Qdecomposed_characters))) + && !NILP (plist_get (Fcoding_system_plist (file_encoding), + Qdecomposed_characters))) { check_decoded = true; if (STRING_MULTIBYTE (file)) diff --git a/src/fns.c b/src/fns.c index 5ee8482d003..6be6b6d6167 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2276,24 +2276,27 @@ merge_c (Lisp_Object org_l1, Lisp_Object org_l2, bool (*less) (Lisp_Object, Lisp /* This does not check for quits. That is safe since it must terminate. */ -DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0, +DEFUN ("plist-get", Fplist_get, Splist_get, 2, 3, 0, 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. The comparison -with PROP is done using `eq'. +with PROP is done using PREDICATE, which defaults to `eq'. -This function never signals an error. */) - (Lisp_Object plist, Lisp_Object prop) +This function doesn't signal an error if PLIST is invalid. */) + (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate) { Lisp_Object tail = plist; + if (NILP (predicate)) + return plist_get (plist, prop); + FOR_EACH_TAIL_SAFE (tail) { if (! CONSP (XCDR (tail))) break; - if (EQ (prop, XCAR (tail))) + if (!NILP (call2 (predicate, prop, XCAR (tail)))) return XCAR (XCDR (tail)); tail = XCDR (tail); } @@ -2301,39 +2304,58 @@ This function never signals an error. */) return Qnil; } +/* Faster version of the above that works with EQ only */ +Lisp_Object +plist_get (Lisp_Object plist, Lisp_Object prop) +{ + Lisp_Object tail = plist; + FOR_EACH_TAIL_SAFE (tail) + { + if (! CONSP (XCDR (tail))) + break; + if (EQ (prop, XCAR (tail))) + return XCAR (XCDR (tail)); + tail = XCDR (tail); + } + return Qnil; +} + DEFUN ("get", Fget, Sget, 2, 2, 0, doc: /* Return the value of SYMBOL's PROPNAME property. This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */) (Lisp_Object symbol, Lisp_Object propname) { CHECK_SYMBOL (symbol); - Lisp_Object propval = Fplist_get (CDR (Fassq (symbol, Voverriding_plist_environment)), - propname); + Lisp_Object propval = plist_get (CDR (Fassq (symbol, + Voverriding_plist_environment)), + propname); if (!NILP (propval)) return propval; - return Fplist_get (XSYMBOL (symbol)->u.s.plist, propname); + return plist_get (XSYMBOL (symbol)->u.s.plist, propname); } -DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0, +DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0, 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 ...). -The comparison with PROP is done using `eq'. +The comparison with PROP is done using PREDICATE, which defaults to `eq'. 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. */) - (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) + (Lisp_Object plist, Lisp_Object prop, Lisp_Object val, Lisp_Object predicate) { Lisp_Object prev = Qnil, tail = plist; + if (NILP (predicate)) + return plist_put (plist, prop, val); FOR_EACH_TAIL (tail) { if (! CONSP (XCDR (tail))) break; - if (EQ (prop, XCAR (tail))) + if (!NILP (call2 (predicate, prop, XCAR (tail)))) { Fsetcar (XCDR (tail), val); return plist; @@ -2351,47 +2373,8 @@ The PLIST is modified by side effects. */) return plist; } -DEFUN ("put", Fput, Sput, 3, 3, 0, - doc: /* Store SYMBOL's PROPNAME property with value VALUE. -It can be retrieved with `(get SYMBOL PROPNAME)'. */) - (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value) -{ - CHECK_SYMBOL (symbol); - set_symbol_plist - (symbol, Fplist_put (XSYMBOL (symbol)->u.s.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'. -This function is otherwise like `plist-get', but may signal an error -if PLIST isn't a valid plist. */) - (Lisp_Object plist, Lisp_Object prop) -{ - Lisp_Object tail = plist; - FOR_EACH_TAIL (tail) - { - if (! CONSP (XCDR (tail))) - break; - if (! NILP (Fequal (prop, XCAR (tail)))) - return XCAR (XCDR (tail)); - tail = XCDR (tail); - } - - CHECK_TYPE (NILP (tail), Qplistp, plist); - - 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. */) - (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) +Lisp_Object +plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) { Lisp_Object prev = Qnil, tail = plist; FOR_EACH_TAIL (tail) @@ -2399,7 +2382,7 @@ The PLIST is modified by side effects. */) if (! CONSP (XCDR (tail))) break; - if (! NILP (Fequal (prop, XCAR (tail)))) + if (EQ (prop, XCAR (tail))) { Fsetcar (XCDR (tail), val); return plist; @@ -2409,12 +2392,24 @@ The PLIST is modified by side effects. */) tail = XCDR (tail); } CHECK_TYPE (NILP (tail), Qplistp, plist); - Lisp_Object newcell = list2 (prop, val); + Lisp_Object newcell + = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev)))); if (NILP (prev)) return newcell; Fsetcdr (XCDR (prev), newcell); return plist; } + +DEFUN ("put", Fput, Sput, 3, 3, 0, + doc: /* Store SYMBOL's PROPNAME property with value VALUE. +It can be retrieved with `(get SYMBOL PROPNAME)'. */) + (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value) +{ + CHECK_SYMBOL (symbol); + set_symbol_plist + (symbol, plist_put (XSYMBOL (symbol)->u.s.plist, propname, value)); + return value; +} DEFUN ("eql", Feql, Seql, 2, 2, 0, doc: /* Return t if the two args are `eq' or are indistinguishable numbers. @@ -3183,22 +3178,25 @@ FILENAME are suppressed. */) bottleneck of Widget operation. Here is their translation to C, for the sole reason of efficiency. */ -DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0, +DEFUN ("plist-member", Fplist_member, Splist_member, 2, 3, 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 ...). -The comparison with PROP is done using `eq'. +The comparison with PROP is done using PREDICATE, which defaults to +`eq'. 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. */) - (Lisp_Object plist, Lisp_Object prop) + (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate) { Lisp_Object tail = plist; + if (NILP (predicate)) + predicate = Qeq; FOR_EACH_TAIL (tail) { - if (EQ (XCAR (tail), prop)) + if (!NILP (call2 (predicate, XCAR (tail), prop))) return tail; tail = XCDR (tail); if (! CONSP (tail)) @@ -3208,13 +3206,22 @@ The value is actually the tail of PLIST whose car is PROP. */) return Qnil; } +/* plist_member isn't used much in the Emacs sources, so just provide + a shim so that the function name follows the same pattern as + plist_get/plist_put. */ +Lisp_Object +plist_member (Lisp_Object plist, Lisp_Object prop) +{ + return Fplist_member (plist, prop, Qnil); +} + DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0, doc: /* In WIDGET, set PROPERTY to VALUE. The value can later be retrieved with `widget-get'. */) (Lisp_Object widget, Lisp_Object property, Lisp_Object value) { CHECK_CONS (widget); - XSETCDR (widget, Fplist_put (XCDR (widget), property, value)); + XSETCDR (widget, plist_put (XCDR (widget), property, value)); return value; } @@ -3231,7 +3238,7 @@ later with `widget-put'. */) if (NILP (widget)) return Qnil; CHECK_CONS (widget); - tmp = Fplist_member (XCDR (widget), property); + tmp = plist_member (XCDR (widget), property); if (CONSP (tmp)) { tmp = XCDR (tmp); @@ -6064,8 +6071,6 @@ The same variable also affects the function `read-answer'. */); defsubr (&Sget); defsubr (&Splist_put); defsubr (&Sput); - defsubr (&Slax_plist_get); - defsubr (&Slax_plist_put); defsubr (&Seql); defsubr (&Sequal); defsubr (&Sequal_including_properties); diff --git a/src/gnutls.c b/src/gnutls.c index 0e1e63e157a..a0de0238c47 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1635,10 +1635,10 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) char *c_hostname; if (NILP (proplist)) - proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters)); + proplist = Fcdr (plist_get (p->childp, QCtls_parameters)); - verify_error = Fplist_get (proplist, QCverify_error); - hostname = Fplist_get (proplist, QChostname); + verify_error = plist_get (proplist, QCverify_error); + hostname = plist_get (proplist, QChostname); if (EQ (verify_error, Qt)) verify_error_all = true; @@ -1668,7 +1668,7 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) p->gnutls_peer_verification = peer_verification; - warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings")); + warnings = plist_get (Fgnutls_peer_status (proc), intern (":warnings")); if (!NILP (warnings)) { for (Lisp_Object tail = warnings; CONSP (tail); tail = XCDR (tail)) @@ -1870,13 +1870,13 @@ one trustfile (usually a CA bundle). */) return Qnil; } - hostname = Fplist_get (proplist, QChostname); - priority_string = Fplist_get (proplist, QCpriority); - trustfiles = Fplist_get (proplist, QCtrustfiles); - keylist = Fplist_get (proplist, QCkeylist); - crlfiles = Fplist_get (proplist, QCcrlfiles); - loglevel = Fplist_get (proplist, QCloglevel); - prime_bits = Fplist_get (proplist, QCmin_prime_bits); + hostname = plist_get (proplist, QChostname); + priority_string = plist_get (proplist, QCpriority); + trustfiles = plist_get (proplist, QCtrustfiles); + keylist = plist_get (proplist, QCkeylist); + crlfiles = plist_get (proplist, QCcrlfiles); + loglevel = plist_get (proplist, QCloglevel); + prime_bits = plist_get (proplist, QCmin_prime_bits); if (!STRINGP (hostname)) { @@ -1929,7 +1929,7 @@ one trustfile (usually a CA bundle). */) check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred)); XPROCESS (proc)->gnutls_x509_cred = x509_cred; - verify_flags = Fplist_get (proplist, QCverify_flags); + verify_flags = plist_get (proplist, QCverify_flags); if (TYPE_RANGED_FIXNUMP (unsigned int, verify_flags)) { gnutls_verify_flags = XFIXNAT (verify_flags); @@ -2109,7 +2109,7 @@ one trustfile (usually a CA bundle). */) } XPROCESS (proc)->gnutls_complete_negotiation_p = - !NILP (Fplist_get (proplist, QCcomplete_negotiation)); + !NILP (plist_get (proplist, QCcomplete_negotiation)); GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET; ret = emacs_gnutls_handshake (XPROCESS (proc)); if (ret < GNUTLS_E_SUCCESS) @@ -2348,7 +2348,7 @@ gnutls_symmetric (bool encrypting, Lisp_Object cipher, if (!NILP (info) && CONSP (info)) { - Lisp_Object v = Fplist_get (info, QCcipher_id); + Lisp_Object v = plist_get (info, QCcipher_id); if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, v)) gca = XFIXNUM (v); } @@ -2625,7 +2625,7 @@ itself. */) if (!NILP (info) && CONSP (info)) { - Lisp_Object v = Fplist_get (info, QCmac_algorithm_id); + Lisp_Object v = plist_get (info, QCmac_algorithm_id); if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, v)) gma = XFIXNUM (v); } @@ -2715,7 +2715,7 @@ the number itself. */) if (!NILP (info) && CONSP (info)) { - Lisp_Object v = Fplist_get (info, QCdigest_algorithm_id); + Lisp_Object v = plist_get (info, QCdigest_algorithm_id); if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, v)) gda = XFIXNUM (v); } diff --git a/src/image.c b/src/image.c index fcf5e97b0b1..c0a7b85cb3b 100644 --- a/src/image.c +++ b/src/image.c @@ -2309,8 +2309,8 @@ postprocess_image (struct frame *f, struct image *img) tem = XCDR (conversion); if (CONSP (tem)) image_edge_detection (f, img, - Fplist_get (tem, QCmatrix), - Fplist_get (tem, QCcolor_adjustment)); + plist_get (tem, QCmatrix), + plist_get (tem, QCcolor_adjustment)); } } } diff --git a/src/indent.c b/src/indent.c index c3d78518c43..d4ef075f001 100644 --- a/src/indent.c +++ b/src/indent.c @@ -484,15 +484,15 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos) : MOST_POSITIVE_FIXNUM); plist = XCDR (val); - if ((prop = Fplist_get (plist, QCwidth), + if ((prop = plist_get (plist, QCwidth), RANGED_FIXNUMP (0, prop, INT_MAX)) - || (prop = Fplist_get (plist, QCrelative_width), + || (prop = plist_get (plist, QCrelative_width), RANGED_FIXNUMP (0, prop, INT_MAX))) width = XFIXNUM (prop); else if (FLOATP (prop) && 0 <= XFLOAT_DATA (prop) && XFLOAT_DATA (prop) <= INT_MAX) width = (int)(XFLOAT_DATA (prop) + 0.5); - else if ((prop = Fplist_get (plist, QCalign_to), + else if ((prop = plist_get (plist, QCalign_to), RANGED_FIXNUMP (col, prop, align_to_max))) width = XFIXNUM (prop) - col; else if (FLOATP (prop) && col <= XFLOAT_DATA (prop) @@ -514,7 +514,7 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos) /* For :relative-width, we need to multiply by the column width of the character at POS, if it is greater than 1. */ if (!NILP (plist) - && !NILP (Fplist_get (plist, QCrelative_width)) + && !NILP (plist_get (plist, QCrelative_width)) && !NILP (BVAR (current_buffer, enable_multibyte_characters))) { int b, wd; diff --git a/src/intervals.c b/src/intervals.c index 9e28637d6bc..85152c58a5d 100644 --- a/src/intervals.c +++ b/src/intervals.c @@ -1737,11 +1737,11 @@ lookup_char_property (Lisp_Object plist, Lisp_Object prop, bool textprop) { tail = XCDR (tail); for (; NILP (fallback) && CONSP (tail); tail = XCDR (tail)) - fallback = Fplist_get (plist, XCAR (tail)); + fallback = plist_get (plist, XCAR (tail)); } if (textprop && NILP (fallback) && CONSP (Vdefault_text_properties)) - fallback = Fplist_get (Vdefault_text_properties, prop); + fallback = plist_get (Vdefault_text_properties, prop); return fallback; } diff --git a/src/keyboard.c b/src/keyboard.c index 5b5972ceee4..e5708c06d93 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -5601,7 +5601,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, if (IMAGEP (object)) { Lisp_Object image_map, hotspot; - if ((image_map = Fplist_get (XCDR (object), QCmap), + if ((image_map = plist_get (XCDR (object), QCmap), !NILP (image_map)) && (hotspot = find_hot_spot (image_map, dx, dy), CONSP (hotspot)) diff --git a/src/lisp.h b/src/lisp.h index 05b0754ff65..7a7d2e79979 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4034,6 +4034,10 @@ extern ptrdiff_t string_char_to_byte (Lisp_Object, ptrdiff_t); extern ptrdiff_t string_byte_to_char (Lisp_Object, ptrdiff_t); extern Lisp_Object string_to_multibyte (Lisp_Object); extern Lisp_Object string_make_unibyte (Lisp_Object); +extern Lisp_Object plist_get (Lisp_Object plist, Lisp_Object prop); +extern Lisp_Object plist_put (Lisp_Object plist, Lisp_Object prop, + Lisp_Object val); +extern Lisp_Object plist_member (Lisp_Object plist, Lisp_Object prop); extern void syms_of_fns (void); /* Defined in sort.c */ diff --git a/src/lread.c b/src/lread.c index a00590e466a..66b13916465 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3175,7 +3175,7 @@ hash_table_from_plist (Lisp_Object plist) /* This is repetitive but fast and simple. */ #define ADDPARAM(name) \ do { \ - Lisp_Object val = Fplist_get (plist, Q ## name); \ + Lisp_Object val = plist_get (plist, Q ## name); \ if (!NILP (val)) \ { \ *par++ = QC ## name; \ @@ -3190,7 +3190,7 @@ hash_table_from_plist (Lisp_Object plist) ADDPARAM (rehash_threshold); ADDPARAM (purecopy); - Lisp_Object data = Fplist_get (plist, Qdata); + Lisp_Object data = plist_get (plist, Qdata); /* Now use params to make a new hash table and fill it. */ Lisp_Object ht = Fmake_hash_table (par - params, params); diff --git a/src/process.c b/src/process.c index f9a32e0d6a0..af402c8edb3 100644 --- a/src/process.c +++ b/src/process.c @@ -1281,7 +1281,7 @@ Return BUFFER. */) update_process_mark (p); } if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) - pset_childp (p, Fplist_put (p->childp, QCbuffer, buffer)); + pset_childp (p, plist_put (p->childp, QCbuffer, buffer)); setup_process_coding_systems (process); return buffer; } @@ -1360,7 +1360,7 @@ The string argument is normally a multibyte string, except: pset_filter (p, filter); if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) - pset_childp (p, Fplist_put (p->childp, QCfilter, filter)); + pset_childp (p, plist_put (p->childp, QCfilter, filter)); setup_process_coding_systems (process); return filter; } @@ -1392,7 +1392,7 @@ It gets two arguments: the process, and a string describing the change. */) pset_sentinel (p, sentinel); if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) - pset_childp (p, Fplist_put (p->childp, QCsentinel, sentinel)); + pset_childp (p, plist_put (p->childp, QCsentinel, sentinel)); return sentinel; } @@ -1553,25 +1553,25 @@ waiting for the process to be fully set up.*/) if (DATAGRAM_CONN_P (process) && (EQ (key, Qt) || EQ (key, QCremote))) - contact = Fplist_put (contact, QCremote, - Fprocess_datagram_address (process)); + contact = plist_put (contact, QCremote, + Fprocess_datagram_address (process)); #endif if ((!NETCONN_P (process) && !SERIALCONN_P (process) && !PIPECONN_P (process)) || EQ (key, Qt)) return contact; if (NILP (key) && NETCONN_P (process)) - return list2 (Fplist_get (contact, QChost), - Fplist_get (contact, QCservice)); + return list2 (plist_get (contact, QChost), + plist_get (contact, QCservice)); if (NILP (key) && SERIALCONN_P (process)) - return list2 (Fplist_get (contact, QCport), - Fplist_get (contact, QCspeed)); + return list2 (plist_get (contact, QCport), + plist_get (contact, QCspeed)); /* FIXME: Return a meaningful value (e.g., the child end of the pipe) if the pipe process is useful for purposes other than receiving stderr. */ if (NILP (key) && PIPECONN_P (process)) return Qt; - return Fplist_get (contact, key); + return plist_get (contact, key); } DEFUN ("process-plist", Fprocess_plist, Sprocess_plist, @@ -1773,7 +1773,7 @@ usage: (make-process &rest ARGS) */) /* Save arguments for process-contact and clone-process. */ contact = Flist (nargs, args); - if (!NILP (Fplist_get (contact, QCfile_handler))) + if (!NILP (plist_get (contact, QCfile_handler))) { Lisp_Object file_handler = Ffind_file_name_handler (BVAR (current_buffer, directory), @@ -1782,7 +1782,7 @@ usage: (make-process &rest ARGS) */) return CALLN (Fapply, file_handler, Qmake_process, contact); } - buffer = Fplist_get (contact, QCbuffer); + buffer = plist_get (contact, QCbuffer); if (!NILP (buffer)) buffer = Fget_buffer_create (buffer, Qnil); @@ -1792,10 +1792,10 @@ usage: (make-process &rest ARGS) */) chdir, since it's in a vfork. */ current_dir = get_current_directory (true); - name = Fplist_get (contact, QCname); + name = plist_get (contact, QCname); CHECK_STRING (name); - command = Fplist_get (contact, QCcommand); + command = plist_get (contact, QCcommand); if (CONSP (command)) program = XCAR (command); else @@ -1804,10 +1804,10 @@ usage: (make-process &rest ARGS) */) if (!NILP (program)) CHECK_STRING (program); - bool query_on_exit = NILP (Fplist_get (contact, QCnoquery)); + bool query_on_exit = NILP (plist_get (contact, QCnoquery)); stderrproc = Qnil; - xstderr = Fplist_get (contact, QCstderr); + xstderr = plist_get (contact, QCstderr); if (PROCESSP (xstderr)) { if (!PIPECONN_P (xstderr)) @@ -1833,18 +1833,18 @@ usage: (make-process &rest ARGS) */) eassert (NILP (XPROCESS (proc)->plist)); pset_type (XPROCESS (proc), Qreal); pset_buffer (XPROCESS (proc), buffer); - pset_sentinel (XPROCESS (proc), Fplist_get (contact, QCsentinel)); - pset_filter (XPROCESS (proc), Fplist_get (contact, QCfilter)); + pset_sentinel (XPROCESS (proc), plist_get (contact, QCsentinel)); + pset_filter (XPROCESS (proc), plist_get (contact, QCfilter)); pset_command (XPROCESS (proc), Fcopy_sequence (command)); if (!query_on_exit) XPROCESS (proc)->kill_without_query = 1; - tem = Fplist_get (contact, QCstop); + tem = plist_get (contact, QCstop); /* Normal processes can't be started in a stopped state, see Bug#30460. */ CHECK_TYPE (NILP (tem), Qnull, tem); - tem = Fplist_get (contact, QCconnection_type); + tem = plist_get (contact, QCconnection_type); if (EQ (tem, Qpty)) XPROCESS (proc)->pty_flag = true; else if (EQ (tem, Qpipe)) @@ -1886,7 +1886,7 @@ usage: (make-process &rest ARGS) */) Lisp_Object coding_systems = Qt; Lisp_Object val, *args2; - tem = Fplist_get (contact, QCcoding); + tem = plist_get (contact, QCcoding); if (!NILP (tem)) { val = tem; @@ -2364,7 +2364,7 @@ usage: (make-pipe-process &rest ARGS) */) contact = Flist (nargs, args); - name = Fplist_get (contact, QCname); + name = plist_get (contact, QCname); CHECK_STRING (name); proc = make_process (name); specpdl_ref specpdl_count = SPECPDL_INDEX (); @@ -2396,21 +2396,21 @@ usage: (make-pipe-process &rest ARGS) */) if (inchannel > max_desc) max_desc = inchannel; - buffer = Fplist_get (contact, QCbuffer); + buffer = plist_get (contact, QCbuffer); if (NILP (buffer)) buffer = name; buffer = Fget_buffer_create (buffer, Qnil); pset_buffer (p, buffer); pset_childp (p, contact); - pset_plist (p, Fcopy_sequence (Fplist_get (contact, QCplist))); + pset_plist (p, Fcopy_sequence (plist_get (contact, QCplist))); pset_type (p, Qpipe); - pset_sentinel (p, Fplist_get (contact, QCsentinel)); - pset_filter (p, Fplist_get (contact, QCfilter)); + pset_sentinel (p, plist_get (contact, QCsentinel)); + pset_filter (p, plist_get (contact, QCfilter)); eassert (NILP (p->log)); - if (tem = Fplist_get (contact, QCnoquery), !NILP (tem)) + if (tem = plist_get (contact, QCnoquery), !NILP (tem)) p->kill_without_query = 1; - if (tem = Fplist_get (contact, QCstop), !NILP (tem)) + if (tem = plist_get (contact, QCstop), !NILP (tem)) pset_command (p, Qt); eassert (! p->pty_flag); @@ -2431,7 +2431,7 @@ usage: (make-pipe-process &rest ARGS) */) Lisp_Object coding_systems = Qt; Lisp_Object val; - tem = Fplist_get (contact, QCcoding); + tem = plist_get (contact, QCcoding); val = Qnil; if (!NILP (tem)) { @@ -2918,7 +2918,7 @@ set up yet, this function will block until socket setup has completed. */) if (set_socket_option (s, option, value)) { - pset_childp (p, Fplist_put (p->childp, option, value)); + pset_childp (p, plist_put (p->childp, option, value)); return Qt; } @@ -2996,19 +2996,19 @@ usage: (serial-process-configure &rest ARGS) */) contact = Flist (nargs, args); - proc = Fplist_get (contact, QCprocess); + proc = plist_get (contact, QCprocess); if (NILP (proc)) - proc = Fplist_get (contact, QCname); + proc = plist_get (contact, QCname); if (NILP (proc)) - proc = Fplist_get (contact, QCbuffer); + proc = plist_get (contact, QCbuffer); if (NILP (proc)) - proc = Fplist_get (contact, QCport); + proc = plist_get (contact, QCport); proc = get_process (proc); p = XPROCESS (proc); if (!EQ (p->type, Qserial)) error ("Not a serial process"); - if (NILP (Fplist_get (p->childp, QCspeed))) + if (NILP (plist_get (p->childp, QCspeed))) return Qnil; serial_configure (p, contact); @@ -3101,17 +3101,17 @@ usage: (make-serial-process &rest ARGS) */) contact = Flist (nargs, args); - port = Fplist_get (contact, QCport); + port = plist_get (contact, QCport); if (NILP (port)) error ("No port specified"); CHECK_STRING (port); - if (NILP (Fplist_member (contact, QCspeed))) + if (NILP (plist_member (contact, QCspeed))) error (":speed not specified"); - if (!NILP (Fplist_get (contact, QCspeed))) - CHECK_FIXNUM (Fplist_get (contact, QCspeed)); + if (!NILP (plist_get (contact, QCspeed))) + CHECK_FIXNUM (plist_get (contact, QCspeed)); - name = Fplist_get (contact, QCname); + name = plist_get (contact, QCname); if (NILP (name)) name = port; CHECK_STRING (name); @@ -3131,21 +3131,21 @@ usage: (make-serial-process &rest ARGS) */) eassert (0 <= fd && fd < FD_SETSIZE); chan_process[fd] = proc; - buffer = Fplist_get (contact, QCbuffer); + buffer = plist_get (contact, QCbuffer); if (NILP (buffer)) buffer = name; buffer = Fget_buffer_create (buffer, Qnil); pset_buffer (p, buffer); pset_childp (p, contact); - pset_plist (p, Fcopy_sequence (Fplist_get (contact, QCplist))); + pset_plist (p, Fcopy_sequence (plist_get (contact, QCplist))); pset_type (p, Qserial); - pset_sentinel (p, Fplist_get (contact, QCsentinel)); - pset_filter (p, Fplist_get (contact, QCfilter)); + pset_sentinel (p, plist_get (contact, QCsentinel)); + pset_filter (p, plist_get (contact, QCfilter)); eassert (NILP (p->log)); - if (tem = Fplist_get (contact, QCnoquery), !NILP (tem)) + if (tem = plist_get (contact, QCnoquery), !NILP (tem)) p->kill_without_query = 1; - if (tem = Fplist_get (contact, QCstop), !NILP (tem)) + if (tem = plist_get (contact, QCstop), !NILP (tem)) pset_command (p, Qt); eassert (! p->pty_flag); @@ -3155,7 +3155,7 @@ usage: (make-serial-process &rest ARGS) */) update_process_mark (p); - tem = Fplist_get (contact, QCcoding); + tem = plist_get (contact, QCcoding); val = Qnil; if (!NILP (tem)) @@ -3209,7 +3209,7 @@ set_network_socket_coding_system (Lisp_Object proc, Lisp_Object host, Lisp_Object coding_systems = Qt; Lisp_Object val; - tem = Fplist_get (contact, QCcoding); + tem = plist_get (contact, QCcoding); /* Setup coding systems for communicating with the network stream. */ /* Qt denotes we have not yet called Ffind_operation_coding_system. */ @@ -3297,8 +3297,8 @@ finish_after_tls_connection (Lisp_Object proc) if (!NILP (Ffboundp (Qnsm_verify_connection))) result = call3 (Qnsm_verify_connection, proc, - Fplist_get (contact, QChost), - Fplist_get (contact, QCservice)); + plist_get (contact, QChost), + plist_get (contact, QCservice)); eassert (p->outfd < FD_SETSIZE); if (NILP (result)) @@ -3479,7 +3479,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, if (getsockname (s, psa1, &len1) == 0) { Lisp_Object service = make_fixnum (ntohs (sa1.sin_port)); - contact = Fplist_put (contact, QCservice, service); + contact = plist_put (contact, QCservice, service); /* Save the port number so that we can stash it in the process object later. */ DECLARE_POINTER_ALIAS (psa, struct sockaddr_in, sa); @@ -3570,7 +3570,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, { Lisp_Object remote; memset (datagram_address[s].sa, 0, addrlen); - if (remote = Fplist_get (contact, QCremote), !NILP (remote)) + if (remote = plist_get (contact, QCremote), !NILP (remote)) { int rfamily; ptrdiff_t rlen = get_lisp_to_sockaddr_size (remote, &rfamily); @@ -3585,8 +3585,8 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, } #endif - contact = Fplist_put (contact, p->is_server? QClocal: QCremote, - conv_sockaddr_to_lisp (sa, addrlen)); + contact = plist_put (contact, p->is_server? QClocal: QCremote, + conv_sockaddr_to_lisp (sa, addrlen)); #ifdef HAVE_GETSOCKNAME if (!p->is_server) { @@ -3594,8 +3594,8 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, socklen_t len1 = sizeof (sa1); DECLARE_POINTER_ALIAS (psa1, struct sockaddr, &sa1); if (getsockname (s, psa1, &len1) == 0) - contact = Fplist_put (contact, QClocal, - conv_sockaddr_to_lisp (psa1, len1)); + contact = plist_put (contact, QClocal, + conv_sockaddr_to_lisp (psa1, len1)); } #endif } @@ -3908,7 +3908,7 @@ usage: (make-network-process &rest ARGS) */) #endif /* :type TYPE (nil: stream, datagram */ - tem = Fplist_get (contact, QCtype); + tem = plist_get (contact, QCtype); if (NILP (tem)) socktype = SOCK_STREAM; #ifdef DATAGRAM_SOCKETS @@ -3922,13 +3922,13 @@ usage: (make-network-process &rest ARGS) */) else error ("Unsupported connection type"); - name = Fplist_get (contact, QCname); - buffer = Fplist_get (contact, QCbuffer); - filter = Fplist_get (contact, QCfilter); - sentinel = Fplist_get (contact, QCsentinel); - use_external_socket_p = Fplist_get (contact, QCuse_external_socket); - Lisp_Object server = Fplist_get (contact, QCserver); - bool nowait = !NILP (Fplist_get (contact, QCnowait)); + name = plist_get (contact, QCname); + buffer = plist_get (contact, QCbuffer); + filter = plist_get (contact, QCfilter); + sentinel = plist_get (contact, QCsentinel); + use_external_socket_p = plist_get (contact, QCuse_external_socket); + Lisp_Object server = plist_get (contact, QCserver); + bool nowait = !NILP (plist_get (contact, QCnowait)); if (!NILP (server) && nowait) error ("`:server' is incompatible with `:nowait'"); @@ -3936,9 +3936,9 @@ usage: (make-network-process &rest ARGS) */) /* :local ADDRESS or :remote ADDRESS */ if (NILP (server)) - address = Fplist_get (contact, QCremote); + address = plist_get (contact, QCremote); else - address = Fplist_get (contact, QClocal); + address = plist_get (contact, QClocal); if (!NILP (address)) { host = service = Qnil; @@ -3951,7 +3951,7 @@ usage: (make-network-process &rest ARGS) */) } /* :family FAMILY -- nil (for Inet), local, or integer. */ - tem = Fplist_get (contact, QCfamily); + tem = plist_get (contact, QCfamily); if (NILP (tem)) { #ifdef AF_INET6 @@ -3976,10 +3976,10 @@ usage: (make-network-process &rest ARGS) */) error ("Unknown address family"); /* :service SERVICE -- string, integer (port number), or t (random port). */ - service = Fplist_get (contact, QCservice); + service = plist_get (contact, QCservice); /* :host HOST -- hostname, ip address, or 'local for localhost. */ - host = Fplist_get (contact, QChost); + host = plist_get (contact, QChost); if (NILP (host)) { /* The "connection" function gets it bind info from the address we're @@ -4018,7 +4018,7 @@ usage: (make-network-process &rest ARGS) */) if (!NILP (host)) { message (":family local ignores the :host property"); - contact = Fplist_put (contact, QChost, Qnil); + contact = plist_put (contact, QChost, Qnil); host = Qnil; } CHECK_STRING (service); @@ -4172,16 +4172,16 @@ usage: (make-network-process &rest ARGS) */) record_unwind_protect (remove_process, proc); p = XPROCESS (proc); pset_childp (p, contact); - pset_plist (p, Fcopy_sequence (Fplist_get (contact, QCplist))); + pset_plist (p, Fcopy_sequence (plist_get (contact, QCplist))); pset_type (p, Qnetwork); pset_buffer (p, buffer); pset_sentinel (p, sentinel); pset_filter (p, filter); - pset_log (p, Fplist_get (contact, QClog)); - if (tem = Fplist_get (contact, QCnoquery), !NILP (tem)) + pset_log (p, plist_get (contact, QClog)); + if (tem = plist_get (contact, QCnoquery), !NILP (tem)) p->kill_without_query = 1; - if ((tem = Fplist_get (contact, QCstop), !NILP (tem))) + if ((tem = plist_get (contact, QCstop), !NILP (tem))) pset_command (p, Qt); eassert (p->pid == 0); p->backlog = 5; @@ -4193,7 +4193,7 @@ usage: (make-network-process &rest ARGS) */) eassert (! p->dns_request); #endif #ifdef HAVE_GNUTLS - tem = Fplist_get (contact, QCtls_parameters); + tem = plist_get (contact, QCtls_parameters); CHECK_LIST (tem); p->gnutls_boot_parameters = tem; #endif @@ -4969,17 +4969,17 @@ server_accept_connection (Lisp_Object server, int channel) /* Build new contact information for this setup. */ contact = Fcopy_sequence (ps->childp); - contact = Fplist_put (contact, QCserver, Qnil); - contact = Fplist_put (contact, QChost, host); + contact = plist_put (contact, QCserver, Qnil); + contact = plist_put (contact, QChost, host); if (!NILP (service)) - contact = Fplist_put (contact, QCservice, service); - contact = Fplist_put (contact, QCremote, - conv_sockaddr_to_lisp (&saddr.sa, len)); + contact = plist_put (contact, QCservice, service); + contact = plist_put (contact, QCremote, + conv_sockaddr_to_lisp (&saddr.sa, len)); #ifdef HAVE_GETSOCKNAME len = sizeof saddr; if (getsockname (s, &saddr.sa, &len) == 0) - contact = Fplist_put (contact, QClocal, - conv_sockaddr_to_lisp (&saddr.sa, len)); + contact = plist_put (contact, QClocal, + conv_sockaddr_to_lisp (&saddr.sa, len)); #endif pset_childp (p, contact); diff --git a/src/sound.c b/src/sound.c index 93c84a03b1f..0a307828008 100644 --- a/src/sound.c +++ b/src/sound.c @@ -361,10 +361,10 @@ parse_sound (Lisp_Object sound, Lisp_Object *attrs) return 0; sound = XCDR (sound); - attrs[SOUND_FILE] = Fplist_get (sound, QCfile); - attrs[SOUND_DATA] = Fplist_get (sound, QCdata); - attrs[SOUND_DEVICE] = Fplist_get (sound, QCdevice); - attrs[SOUND_VOLUME] = Fplist_get (sound, QCvolume); + attrs[SOUND_FILE] = plist_get (sound, QCfile); + attrs[SOUND_DATA] = plist_get (sound, QCdata); + attrs[SOUND_DEVICE] = plist_get (sound, QCdevice); + attrs[SOUND_VOLUME] = plist_get (sound, QCvolume); #ifndef WINDOWSNT /* File name or data must be specified. */ diff --git a/src/sysdep.c b/src/sysdep.c index 28ab8189c36..c1545622dfc 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -2939,21 +2939,21 @@ serial_configure (struct Lisp_Process *p, #endif /* Configure speed. */ - if (!NILP (Fplist_member (contact, QCspeed))) - tem = Fplist_get (contact, QCspeed); + if (!NILP (plist_member (contact, QCspeed))) + tem = plist_get (contact, QCspeed); else - tem = Fplist_get (p->childp, QCspeed); + tem = plist_get (p->childp, QCspeed); CHECK_FIXNUM (tem); err = cfsetspeed (&attr, convert_speed (XFIXNUM (tem))); if (err != 0) report_file_error ("Failed cfsetspeed", tem); - childp2 = Fplist_put (childp2, QCspeed, tem); + childp2 = plist_put (childp2, QCspeed, tem); /* Configure bytesize. */ - if (!NILP (Fplist_member (contact, QCbytesize))) - tem = Fplist_get (contact, QCbytesize); + if (!NILP (plist_member (contact, QCbytesize))) + tem = plist_get (contact, QCbytesize); else - tem = Fplist_get (p->childp, QCbytesize); + tem = plist_get (p->childp, QCbytesize); if (NILP (tem)) tem = make_fixnum (8); CHECK_FIXNUM (tem); @@ -2968,13 +2968,13 @@ serial_configure (struct Lisp_Process *p, if (XFIXNUM (tem) != 8) error ("Bytesize cannot be changed"); #endif - childp2 = Fplist_put (childp2, QCbytesize, tem); + childp2 = plist_put (childp2, QCbytesize, tem); /* Configure parity. */ - if (!NILP (Fplist_member (contact, QCparity))) - tem = Fplist_get (contact, QCparity); + if (!NILP (plist_member (contact, QCparity))) + tem = plist_get (contact, QCparity); else - tem = Fplist_get (p->childp, QCparity); + tem = plist_get (p->childp, QCparity); if (!NILP (tem) && !EQ (tem, Qeven) && !EQ (tem, Qodd)) error (":parity must be nil (no parity), `even', or `odd'"); #if defined (PARENB) && defined (PARODD) && defined (IGNPAR) && defined (INPCK) @@ -3001,13 +3001,13 @@ serial_configure (struct Lisp_Process *p, if (!NILP (tem)) error ("Parity cannot be configured"); #endif - childp2 = Fplist_put (childp2, QCparity, tem); + childp2 = plist_put (childp2, QCparity, tem); /* Configure stopbits. */ - if (!NILP (Fplist_member (contact, QCstopbits))) - tem = Fplist_get (contact, QCstopbits); + if (!NILP (plist_member (contact, QCstopbits))) + tem = plist_get (contact, QCstopbits); else - tem = Fplist_get (p->childp, QCstopbits); + tem = plist_get (p->childp, QCstopbits); if (NILP (tem)) tem = make_fixnum (1); CHECK_FIXNUM (tem); @@ -3023,13 +3023,13 @@ serial_configure (struct Lisp_Process *p, if (XFIXNUM (tem) != 1) error ("Stopbits cannot be configured"); #endif - childp2 = Fplist_put (childp2, QCstopbits, tem); + childp2 = plist_put (childp2, QCstopbits, tem); /* Configure flowcontrol. */ - if (!NILP (Fplist_member (contact, QCflowcontrol))) - tem = Fplist_get (contact, QCflowcontrol); + if (!NILP (plist_member (contact, QCflowcontrol))) + tem = plist_get (contact, QCflowcontrol); else - tem = Fplist_get (p->childp, QCflowcontrol); + tem = plist_get (p->childp, QCflowcontrol); if (!NILP (tem) && !EQ (tem, Qhw) && !EQ (tem, Qsw)) error (":flowcontrol must be nil (no flowcontrol), `hw', or `sw'"); #if defined (CRTSCTS) @@ -3063,14 +3063,14 @@ serial_configure (struct Lisp_Process *p, error ("Software flowcontrol (XON/XOFF) not supported"); #endif } - childp2 = Fplist_put (childp2, QCflowcontrol, tem); + childp2 = plist_put (childp2, QCflowcontrol, tem); /* Activate configuration. */ err = tcsetattr (p->outfd, TCSANOW, &attr); if (err != 0) report_file_error ("Failed tcsetattr", Qnil); - childp2 = Fplist_put (childp2, QCsummary, build_string (summary)); + childp2 = plist_put (childp2, QCsummary, build_string (summary)); pset_childp (p, childp2); } #endif /* not DOS_NT */ diff --git a/src/textprop.c b/src/textprop.c index d69682d3ea3..96d07b44be8 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -2249,7 +2249,7 @@ verify_interval_modification (struct buffer *buf, tem = textget (i->plist, Qfront_sticky); if (TMEM (Qread_only, tem) - || (NILP (Fplist_get (i->plist, Qread_only)) + || (NILP (plist_get (i->plist, Qread_only)) && TMEM (Qcategory, tem))) text_read_only (after); } @@ -2269,7 +2269,7 @@ verify_interval_modification (struct buffer *buf, tem = textget (prev->plist, Qrear_nonsticky); if (! TMEM (Qread_only, tem) - && (! NILP (Fplist_get (prev->plist,Qread_only)) + && (! NILP (plist_get (prev->plist,Qread_only)) || ! TMEM (Qcategory, tem))) text_read_only (before); } @@ -2288,13 +2288,13 @@ verify_interval_modification (struct buffer *buf, tem = textget (i->plist, Qfront_sticky); if (TMEM (Qread_only, tem) - || (NILP (Fplist_get (i->plist, Qread_only)) + || (NILP (plist_get (i->plist, Qread_only)) && TMEM (Qcategory, tem))) text_read_only (after); tem = textget (prev->plist, Qrear_nonsticky); if (! TMEM (Qread_only, tem) - && (! NILP (Fplist_get (prev->plist, Qread_only)) + && (! NILP (plist_get (prev->plist, Qread_only)) || ! TMEM (Qcategory, tem))) text_read_only (after); } diff --git a/src/w32.c b/src/w32.c index 590d9e85d93..c1e4118e9b9 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10953,19 +10953,19 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact) dcb.EvtChar = 0; /* Configure speed. */ - if (!NILP (Fplist_member (contact, QCspeed))) - tem = Fplist_get (contact, QCspeed); + if (!NILP (plist_member (contact, QCspeed))) + tem = plist_get (contact, QCspeed); else - tem = Fplist_get (p->childp, QCspeed); + tem = plist_get (p->childp, QCspeed); CHECK_FIXNUM (tem); dcb.BaudRate = XFIXNUM (tem); childp2 = Fplist_put (childp2, QCspeed, tem); /* Configure bytesize. */ - if (!NILP (Fplist_member (contact, QCbytesize))) - tem = Fplist_get (contact, QCbytesize); + if (!NILP (plist_member (contact, QCbytesize))) + tem = plist_get (contact, QCbytesize); else - tem = Fplist_get (p->childp, QCbytesize); + tem = plist_get (p->childp, QCbytesize); if (NILP (tem)) tem = make_fixnum (8); CHECK_FIXNUM (tem); @@ -10976,10 +10976,10 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact) childp2 = Fplist_put (childp2, QCbytesize, tem); /* Configure parity. */ - if (!NILP (Fplist_member (contact, QCparity))) - tem = Fplist_get (contact, QCparity); + if (!NILP (plist_member (contact, QCparity))) + tem = plist_get (contact, QCparity); else - tem = Fplist_get (p->childp, QCparity); + tem = plist_get (p->childp, QCparity); if (!NILP (tem) && !EQ (tem, Qeven) && !EQ (tem, Qodd)) error (":parity must be nil (no parity), `even', or `odd'"); dcb.fParity = FALSE; @@ -11006,10 +11006,10 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact) childp2 = Fplist_put (childp2, QCparity, tem); /* Configure stopbits. */ - if (!NILP (Fplist_member (contact, QCstopbits))) - tem = Fplist_get (contact, QCstopbits); + if (!NILP (plist_member (contact, QCstopbits))) + tem = plist_get (contact, QCstopbits); else - tem = Fplist_get (p->childp, QCstopbits); + tem = plist_get (p->childp, QCstopbits); if (NILP (tem)) tem = make_fixnum (1); CHECK_FIXNUM (tem); @@ -11023,10 +11023,10 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact) childp2 = Fplist_put (childp2, QCstopbits, tem); /* Configure flowcontrol. */ - if (!NILP (Fplist_member (contact, QCflowcontrol))) - tem = Fplist_get (contact, QCflowcontrol); + if (!NILP (plist_member (contact, QCflowcontrol))) + tem = plist_get (contact, QCflowcontrol); else - tem = Fplist_get (p->childp, QCflowcontrol); + tem = plist_get (p->childp, QCflowcontrol); if (!NILP (tem) && !EQ (tem, Qhw) && !EQ (tem, Qsw)) error (":flowcontrol must be nil (no flowcontrol), `hw', or `sw'"); dcb.fOutxCtsFlow = FALSE; diff --git a/src/w32fns.c b/src/w32fns.c index b093d3c32ee..468073c9170 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10212,21 +10212,21 @@ usage: (w32-notification-notify &rest PARAMS) */) arg_plist = Flist (nargs, args); /* Icon. */ - lres = Fplist_get (arg_plist, QCicon); + lres = plist_get (arg_plist, QCicon); if (STRINGP (lres)) icon = SSDATA (ENCODE_FILE (Fexpand_file_name (lres, Qnil))); else icon = (char *)""; /* Tip. */ - lres = Fplist_get (arg_plist, QCtip); + lres = plist_get (arg_plist, QCtip); if (STRINGP (lres)) tip = SSDATA (code_convert_string_norecord (lres, Qutf_8, 1)); else tip = (char *)"Emacs notification"; /* Severity. */ - lres = Fplist_get (arg_plist, QClevel); + lres = plist_get (arg_plist, QClevel); if (NILP (lres)) severity = Ni_None; else if (EQ (lres, Qinfo)) @@ -10239,14 +10239,14 @@ usage: (w32-notification-notify &rest PARAMS) */) severity = Ni_Info; /* Title. */ - lres = Fplist_get (arg_plist, QCtitle); + lres = plist_get (arg_plist, QCtitle); if (STRINGP (lres)) title = SSDATA (code_convert_string_norecord (lres, Qutf_8, 1)); else title = (char *)""; /* Notification body text. */ - lres = Fplist_get (arg_plist, QCbody); + lres = plist_get (arg_plist, QCbody); if (STRINGP (lres)) msg = SSDATA (code_convert_string_norecord (lres, Qutf_8, 1)); else diff --git a/src/w32image.c b/src/w32image.c index 1f7c4921b31..da748b8dab4 100644 --- a/src/w32image.c +++ b/src/w32image.c @@ -382,7 +382,7 @@ w32_select_active_frame (GpBitmap *pBitmap, int frame, int *nframes, static ARGB w32_image_bg_color (struct frame *f, struct image *img) { - Lisp_Object specified_bg = Fplist_get (XCDR (img->spec), QCbackground); + Lisp_Object specified_bg = plist_get (XCDR (img->spec), QCbackground); Emacs_Color color; /* If the user specified a color, try to use it; if not, use the @@ -435,7 +435,7 @@ w32_load_image (struct frame *f, struct image *img, if (status == Ok) { /* In multiframe pictures, select the first frame. */ - Lisp_Object lisp_index = Fplist_get (XCDR (img->spec), QCindex); + Lisp_Object lisp_index = plist_get (XCDR (img->spec), QCindex); int index = FIXNATP (lisp_index) ? XFIXNAT (lisp_index) : 0; int nframes; double delay; diff --git a/src/xdisp.c b/src/xdisp.c index dec31760476..a46fe99830a 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -14694,7 +14694,7 @@ build_desired_tool_bar_string (struct frame *f) selected. */ if (selected_p) { - plist = Fplist_put (plist, QCrelief, make_fixnum (-relief)); + plist = plist_put (plist, QCrelief, make_fixnum (-relief)); hmargin -= relief; vmargin -= relief; } @@ -14704,10 +14704,10 @@ build_desired_tool_bar_string (struct frame *f) /* If image is selected, display it pressed, i.e. with a negative relief. If it's not selected, display it with a raised relief. */ - plist = Fplist_put (plist, QCrelief, - (selected_p - ? make_fixnum (-relief) - : make_fixnum (relief))); + plist = plist_put (plist, QCrelief, + (selected_p + ? make_fixnum (-relief) + : make_fixnum (relief))); hmargin -= relief; vmargin -= relief; } @@ -14716,18 +14716,18 @@ build_desired_tool_bar_string (struct frame *f) if (hmargin || vmargin) { if (hmargin == vmargin) - plist = Fplist_put (plist, QCmargin, make_fixnum (hmargin)); + plist = plist_put (plist, QCmargin, make_fixnum (hmargin)); else - plist = Fplist_put (plist, QCmargin, - Fcons (make_fixnum (hmargin), - make_fixnum (vmargin))); + plist = plist_put (plist, QCmargin, + Fcons (make_fixnum (hmargin), + make_fixnum (vmargin))); } /* If button is not enabled, and we don't have special images for the disabled state, make the image appear disabled by applying an appropriate algorithm to it. */ if (!enabled_p && idx < 0) - plist = Fplist_put (plist, QCconversion, Qdisabled); + plist = plist_put (plist, QCconversion, Qdisabled); /* Put a `display' text property on the string for the image to display. Put a `menu-item' property on the string that gives @@ -26510,8 +26510,8 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, tem = props; while (CONSP (tem)) { - oprops = Fplist_put (oprops, XCAR (tem), - XCAR (XCDR (tem))); + oprops = plist_put (oprops, XCAR (tem), + XCAR (XCDR (tem))); tem = XCDR (XCDR (tem)); } props = oprops; @@ -26962,13 +26962,13 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string, props = mode_line_string_face_prop; else if (!NILP (mode_line_string_face)) { - Lisp_Object face = Fplist_get (props, Qface); + Lisp_Object face = plist_get (props, Qface); props = Fcopy_sequence (props); if (NILP (face)) face = mode_line_string_face; else face = list2 (face, mode_line_string_face); - props = Fplist_put (props, Qface, face); + props = plist_put (props, Qface, face); } Fadd_text_properties (make_fixnum (0), make_fixnum (len), props, lisp_string); @@ -26987,7 +26987,7 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string, Lisp_Object face; if (NILP (props)) props = Ftext_properties_at (make_fixnum (0), lisp_string); - face = Fplist_get (props, Qface); + face = plist_get (props, Qface); if (NILP (face)) face = mode_line_string_face; else @@ -28037,7 +28037,7 @@ display_string (const char *string, Lisp_Object lisp_string, Lisp_Object face_st face_string); if (!NILP (display)) { - Lisp_Object min_width = Fplist_get (display, Qmin_width); + Lisp_Object min_width = plist_get (display, Qmin_width); if (!NILP (min_width)) display_min_width (it, 0, face_string, min_width); } @@ -30730,14 +30730,14 @@ produce_stretch_glyph (struct it *it) plist = XCDR (it->object); /* Compute the width of the stretch. */ - if ((prop = Fplist_get (plist, QCwidth), !NILP (prop)) + if ((prop = plist_get (plist, QCwidth), !NILP (prop)) && calc_pixel_width_or_height (&tem, it, prop, font, true, NULL)) { /* Absolute width `:width WIDTH' specified and valid. */ zero_width_ok_p = true; width = (int)tem; } - else if (prop = Fplist_get (plist, QCrelative_width), NUMVAL (prop) > 0) + else if (prop = plist_get (plist, QCrelative_width), NUMVAL (prop) > 0) { /* Relative width `:relative-width FACTOR' specified and valid. Compute the width of the characters having this `display' @@ -30774,7 +30774,7 @@ produce_stretch_glyph (struct it *it) PRODUCE_GLYPHS (&it2); width = NUMVAL (prop) * it2.pixel_width; } - else if ((prop = Fplist_get (plist, QCalign_to), !NILP (prop)) + else if ((prop = plist_get (plist, QCalign_to), !NILP (prop)) && calc_pixel_width_or_height (&tem, it, prop, font, true, &align_to)) { @@ -30800,13 +30800,13 @@ produce_stretch_glyph (struct it *it) { int default_height = normal_char_height (font, ' '); - if ((prop = Fplist_get (plist, QCheight), !NILP (prop)) + if ((prop = plist_get (plist, QCheight), !NILP (prop)) && calc_pixel_width_or_height (&tem, it, prop, font, false, NULL)) { height = (int)tem; zero_height_ok_p = true; } - else if (prop = Fplist_get (plist, QCrelative_height), + else if (prop = plist_get (plist, QCrelative_height), NUMVAL (prop) > 0) height = default_height * NUMVAL (prop); else @@ -30818,7 +30818,7 @@ produce_stretch_glyph (struct it *it) /* Compute percentage of height used for ascent. If `:ascent ASCENT' is present and valid, use that. Otherwise, derive the ascent from the font in use. */ - if (prop = Fplist_get (plist, QCascent), + if (prop = plist_get (plist, QCascent), NUMVAL (prop) > 0 && NUMVAL (prop) <= 100) ascent = height * NUMVAL (prop) / 100.0; else if (!NILP (prop) @@ -34165,7 +34165,7 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, if (IMAGEP (object)) { Lisp_Object image_map, hotspot; - if ((image_map = Fplist_get (XCDR (object), QCmap), + if ((image_map = plist_get (XCDR (object), QCmap), !NILP (image_map)) && (hotspot = find_hot_spot (image_map, dx, dy), CONSP (hotspot)) @@ -34180,10 +34180,10 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, if (CONSP (hotspot) && (plist = XCAR (hotspot), CONSP (plist))) { - pointer = Fplist_get (plist, Qpointer); + pointer = plist_get (plist, Qpointer); if (NILP (pointer)) pointer = Qhand; - help = Fplist_get (plist, Qhelp_echo); + help = plist_get (plist, Qhelp_echo); if (!NILP (help)) { help_echo_string = help; @@ -34194,7 +34194,7 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, } } if (NILP (pointer)) - pointer = Fplist_get (XCDR (object), QCpointer); + pointer = plist_get (XCDR (object), QCpointer); } #endif /* HAVE_WINDOW_SYSTEM */ @@ -34680,7 +34680,7 @@ note_mouse_highlight (struct frame *f, int x, int y) if (img != NULL && IMAGEP (img->spec)) { Lisp_Object image_map, hotspot; - if ((image_map = Fplist_get (XCDR (img->spec), QCmap), + if ((image_map = plist_get (XCDR (img->spec), QCmap), !NILP (image_map)) && (hotspot = find_hot_spot (image_map, glyph->slice.img.x + dx, @@ -34698,10 +34698,10 @@ note_mouse_highlight (struct frame *f, int x, int y) if (CONSP (hotspot) && (plist = XCAR (hotspot), CONSP (plist))) { - pointer = Fplist_get (plist, Qpointer); + pointer = plist_get (plist, Qpointer); if (NILP (pointer)) pointer = Qhand; - help_echo_string = Fplist_get (plist, Qhelp_echo); + help_echo_string = plist_get (plist, Qhelp_echo); if (!NILP (help_echo_string)) { help_echo_window = window; @@ -34711,7 +34711,7 @@ note_mouse_highlight (struct frame *f, int x, int y) } } if (NILP (pointer)) - pointer = Fplist_get (XCDR (img->spec), QCpointer); + pointer = plist_get (XCDR (img->spec), QCpointer); } } #endif /* HAVE_WINDOW_SYSTEM */ diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el index ef7805a3416..ab1f19fb6e7 100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@ -510,8 +510,8 @@ Point is moved to beginning of the buffer." (let ((json-key-type 'string)) (setq obj (json-add-to-object obj "g" 7)) (setq obj (json-add-to-object obj "h" 8)) - (should (= (lax-plist-get obj "g") 7)) - (should (= (lax-plist-get obj "h") 8))))) + (should (= (plist-get obj "g" #'equal) 7)) + (should (= (plist-get obj "h" #'equal) 8))))) (ert-deftest test-json-add-to-hash-table () (let* ((json-object-type 'hash-table) diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 39bcc5ee38b..ba56019d4cd 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -852,24 +852,6 @@ (should-not (plist-get d1 3)) (should-not (plist-get d2 3)))) -(ert-deftest test-cycle-lax-plist-get () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (lax-plist-get c1 1)) - (should (lax-plist-get c2 1)) - (should (lax-plist-get d1 1)) - (should (lax-plist-get d2 1)) - (should-error (lax-plist-get c1 2) :type 'circular-list) - (should (lax-plist-get c2 2)) - (should-error (lax-plist-get d1 2) :type 'wrong-type-argument) - (should (lax-plist-get d2 2)) - (should-error (lax-plist-get c1 3) :type 'circular-list) - (should-error (lax-plist-get c2 3) :type 'circular-list) - (should-error (lax-plist-get d1 3) :type 'wrong-type-argument) - (should-error (lax-plist-get d2 3) :type 'wrong-type-argument))) - (ert-deftest test-cycle-plist-member () (let ((c1 (cyc1 1)) (c2 (cyc2 1 2)) @@ -906,24 +888,6 @@ (should-error (plist-put d1 3 3) :type 'wrong-type-argument) (should-error (plist-put d2 3 3) :type 'wrong-type-argument))) -(ert-deftest test-cycle-lax-plist-put () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (lax-plist-put c1 1 1)) - (should (lax-plist-put c2 1 1)) - (should (lax-plist-put d1 1 1)) - (should (lax-plist-put d2 1 1)) - (should-error (lax-plist-put c1 2 2) :type 'circular-list) - (should (lax-plist-put c2 2 2)) - (should-error (lax-plist-put d1 2 2) :type 'wrong-type-argument) - (should (lax-plist-put d2 2 2)) - (should-error (lax-plist-put c1 3 3) :type 'circular-list) - (should-error (lax-plist-put c2 3 3) :type 'circular-list) - (should-error (lax-plist-put d1 3 3) :type 'wrong-type-argument) - (should-error (lax-plist-put d2 3 3) :type 'wrong-type-argument))) - (ert-deftest test-cycle-equal () (should-error (equal (cyc1 1) (cyc1 1))) (should-error (equal (cyc2 1 2) (cyc2 1 2)))) @@ -936,24 +900,12 @@ "Test that `plist-get' doesn't signal an error on degenerate plists." (should-not (plist-get '(:foo 1 :bar) :bar))) -(ert-deftest lax-plist-get/odd-number-of-elements () - "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." - (should (equal (should-error (lax-plist-get '(:foo 1 :bar) :bar) - :type 'wrong-type-argument) - '(wrong-type-argument plistp (:foo 1 :bar))))) - (ert-deftest plist-put/odd-number-of-elements () "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." (should (equal (should-error (plist-put '(:foo 1 :bar) :zot 2) :type 'wrong-type-argument) '(wrong-type-argument plistp (:foo 1 :bar))))) -(ert-deftest lax-plist-put/odd-number-of-elements () - "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." - (should (equal (should-error (lax-plist-put '(:foo 1 :bar) :zot 2) - :type 'wrong-type-argument) - '(wrong-type-argument plistp (:foo 1 :bar))))) - (ert-deftest plist-member/improper-list () "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." (should (equal (should-error (plist-member '(:foo 1 . :bar) :qux) @@ -1375,4 +1327,21 @@ (should-error (append loop '(end)) :type 'circular-list))) +(ert-deftest test-plist () + (let ((plist '(:a "b"))) + (setq plist (plist-put plist :b "c")) + (should (equal (plist-get plist :b) "c")) + (should (equal (plist-member plist :b) '(:b "c")))) + + (let ((plist '("1" "2" "a" "b"))) + (setq plist (plist-put plist (copy-sequence "a") "c")) + (should-not (equal (plist-get plist (copy-sequence "a")) "c")) + (should-not (equal (plist-member plist (copy-sequence "a")) '("a" "c")))) + + (let ((plist '("1" "2" "a" "b"))) + (setq plist (plist-put plist (copy-sequence "a") "c" #'equal)) + (should (equal (plist-get plist (copy-sequence "a") #'equal) "c")) + (should (equal (plist-member plist (copy-sequence "a") #'equal) + '("a" "c"))))) + ;;; fns-tests.el ends here -- cgit v1.2.3 From 98c9105f059085da8ebbbf4d50fc43abcb7a2d32 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 28 Jun 2022 14:41:32 +0200 Subject: Allow using define-short-documentation-group without loading shortdoc * lisp/emacs-lisp/shortdoc.el (define-short-documentation-group): Allow using without loading shortdoc.el (bug#56260). --- lisp/emacs-lisp/shortdoc.el | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index d0f06358872..c82aa3365cd 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -41,10 +41,12 @@ '((t :inherit variable-pitch)) "Face used for a section.") -(defvar shortdoc--groups nil) +;;;###autoload +(progn + (defvar shortdoc--groups nil) -(defmacro define-short-documentation-group (group &rest functions) - "Add GROUP to the list of defined documentation groups. + (defmacro define-short-documentation-group (group &rest functions) + "Add GROUP to the list of defined documentation groups. FUNCTIONS is a list of elements on the form: (FUNC @@ -88,8 +90,7 @@ string will be `read' and evaluated. (FUNC :no-eval EXAMPLE-FORM - :result RESULT-FORM ;Use `:result-string' if value is in string form - ) + :result RESULT-FORM) ;Use `:result-string' if value is in string form Using `:no-value' is the same as using `:no-eval'. @@ -102,17 +103,16 @@ execution of the documented form depends on some conditions. (FUNC :no-eval EXAMPLE-FORM - :eg-result RESULT-FORM ;Use `:eg-result-string' if value is in string form - ) + :eg-result RESULT-FORM) ;Use `:eg-result-string' if value is in string form A FUNC form can have any number of `:no-eval' (or `:no-value'), `:no-eval*', `:result', `:result-string', `:eg-result' and `:eg-result-string' properties." - (declare (indent defun)) - `(progn - (setq shortdoc--groups (delq (assq ',group shortdoc--groups) - shortdoc--groups)) - (push (cons ',group ',functions) shortdoc--groups))) + (declare (indent defun)) + `(progn + (setq shortdoc--groups (delq (assq ',group shortdoc--groups) + shortdoc--groups)) + (push (cons ',group ',functions) shortdoc--groups)))) (define-short-documentation-group alist "Alist Basics" -- cgit v1.2.3 From b31680ef040d4a232619e8d070794a43d2cdca2c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 3 Jul 2022 12:55:00 +0200 Subject: Add new function `seq-split' * doc/lispref/sequences.texi (Sequence Functions): Document it. * lisp/emacs-lisp/seq.el (seq-split): New function. * lisp/emacs-lisp/shortdoc.el (sequence): Mention it. --- doc/lispref/sequences.texi | 14 ++++++++++++++ etc/NEWS | 4 ++++ lisp/emacs-lisp/seq.el | 15 +++++++++++++++ lisp/emacs-lisp/shortdoc.el | 2 ++ test/lisp/emacs-lisp/seq-tests.el | 21 +++++++++++++++++++++ 5 files changed, 56 insertions(+) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index c3f4cff3015..39230d0adc4 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -577,6 +577,20 @@ starting from the first one for which @var{predicate} returns @code{nil}. @end example @end defun +@defun seq-split sequence length + This function returns a list consisting of sub-sequences of +@var{sequence} of (at most) length @var{length}. (The final element +may be shorter than @var{length} if the length of @var{sequence} isn't +a multiple of @var{length}. + +@example +@group +(seq-split [0 1 2 3 4] 2) +@result{} ([0 1] [2 3] [4]) +@end group +@end example +@end defun + @defun seq-do function sequence This function applies @var{function} to each element of @var{sequence} in turn (presumably for side effects), and returns diff --git a/etc/NEWS b/etc/NEWS index af3240e5046..e1cdbd5077a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2250,6 +2250,10 @@ patcomp.el, pc-mode.el, pc-select.el, s-region.el, and sregex.el. * Lisp Changes in Emacs 29.1 ++++ +** New function 'seq-split'. +This returns a list of sub-sequences of the specified sequence. + +++ ** 'plist-get', 'plist-put' and 'plist-member' are no longer limited to 'eq'. These function now take an optional comparison predicate argument. diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 947b64e8687..36c17f4cd5e 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -632,5 +632,20 @@ Signal an error if SEQUENCE is empty." ;; we automatically highlight macros. (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords)) +(defun seq-split (sequence length) + "Split SEQUENCE into a list of sub-sequences of at most LENGTH. +All the sub-sequences will be of LENGTH, except the last one, +which may be shorter." + (when (< length 1) + (error "Sub-sequence length must be larger than zero")) + (let ((result nil) + (seq-length (length sequence)) + (start 0)) + (while (< start seq-length) + (push (seq-subseq sequence start + (setq start (min seq-length (+ start length)))) + result)) + (nreverse result))) + (provide 'seq) ;;; seq.el ends here diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index c82aa3365cd..f53e783111c 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -889,6 +889,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (seq-subseq '(a b c d e) 2 4)) (seq-take :eval (seq-take '(a b c d e) 3)) + (seq-split + :eval (seq-split [0 1 2 3 5] 2)) (seq-take-while :eval (seq-take-while #'cl-evenp [2 4 9 6 5])) (seq-uniq diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 9e5d59163f9..d979604910e 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -511,5 +511,26 @@ Evaluate BODY for each created sequence. (should (equal (seq-difference '(1 nil) '(2 nil)) '(1))))) +(ert-deftest test-seq-split () + (let ((seq [0 1 2 3 4 5 6 7 8 9 10])) + (should (equal seq (car (seq-split seq 20)))) + (should (equal seq (car (seq-split seq 11)))) + (should (equal (seq-split seq 10) + '([0 1 2 3 4 5 6 7 8 9] [10]))) + (should (equal (seq-split seq 5) + '([0 1 2 3 4] [5 6 7 8 9] [10]))) + (should (equal (seq-split seq 1) + '([0] [1] [2] [3] [4] [5] [6] [7] [8] [9] [10]))) + (should-error (seq-split seq 0)) + (should-error (seq-split seq -10))) + (let ((seq '(0 1 2 3 4 5 6 7 8 9))) + (should (equal (seq-split seq 5) + '((0 1 2 3 4) (5 6 7 8 9))))) + (let ((seq "0123456789")) + (should (equal (seq-split seq 2) + '("01" "23" "45" "67" "89"))) + (should (equal (seq-split seq 3) + '("012" "345" "678" "9"))))) + (provide 'seq-tests) ;;; seq-tests.el ends here -- cgit v1.2.3 From 1ac383bcb69578ac9e89ab00538d81ee8daee022 Mon Sep 17 00:00:00 2001 From: Daanturo Date: Mon, 4 Jul 2022 13:07:51 +0200 Subject: Add file-parent-directory function * doc/lispref/files.texi: Document the function. * etc/NEWS: Add its entry. * lisp/emacs-lisp/shortdoc.el: Add it to 'file-name' group. * lisp/files.el: implementation (bug#56355). --- doc/lispref/files.texi | 6 ++++++ etc/NEWS | 4 ++++ lisp/emacs-lisp/shortdoc.el | 7 +++++++ lisp/files.el | 17 +++++++++++++++++ 4 files changed, 34 insertions(+) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index ea8683a6d8e..ee4e1ec4d96 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -2445,6 +2445,12 @@ You can use this function for directory names and for file names, because it recognizes abbreviations even as part of the name. @end defun +@defun file-parent-directory filename +This function returns the parent directory of @var{filename}. If +@var{filename} is at the top level, return @code{nil}. @var{filename} +can be relative to @code{default-directory}. +@end defun + @node File Name Expansion @subsection Functions that Expand Filenames @cindex expansion of file names diff --git a/etc/NEWS b/etc/NEWS index 3836efa6927..7967190c6e7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -339,6 +339,10 @@ increase and decrease the font size globally. Additionally, the variable 'global-text-scale-adjust-resizes-frames' controls whether the frames are resized when the font size is changed. ++++ +** New function 'file-parent-directory'. +Get the parent directory of a file. + ** New config variable 'syntax-wholeline-max' to reduce the cost of long lines. This variable is used by some operations (mostly syntax-propertization and font-locking) to treat lines longer than this variable as if they diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index f53e783111c..68293931c3c 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -353,6 +353,13 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (abbreviate-file-name :no-eval (abbreviate-file-name "/home/some-user") :eg-result "~some-user") + (file-parent-directory + :eval (file-parent-directory "/foo/bar") + :eval (file-parent-directory "~") + :eval (file-parent-directory "/tmp/") + :eval (file-parent-directory "foo/bar") + :eval (file-parent-directory "foo") + :eval (file-parent-directory "/")) "Quoted File Names" (file-name-quote :args (name) diff --git a/lisp/files.el b/lisp/files.el index 1295c24c933..b952b08ff47 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -5145,6 +5145,23 @@ On most systems, this will be true: (setq filename nil)))) components)) +(defun file-parent-directory (filename) + "Return the parent directory of FILENAME. +If FILENAME is at the top level, return nil. FILENAME can be +relative to `default-directory'." + (let* ((expanded-filename (expand-file-name filename)) + (parent (file-name-directory (directory-file-name expanded-filename)))) + (cond + ;; filename is at top-level, therefore no parent + ((or (null parent) + (file-equal-p parent expanded-filename)) + nil) + ;; filename is relative, return relative parent + ((not (file-name-absolute-p filename)) + (file-relative-name parent)) + (t + parent)))) + (defcustom make-backup-file-name-function #'make-backup-file-name--default-function "A function that `make-backup-file-name' uses to create backup file names. -- cgit v1.2.3 From 27c3a8b27707e401dfa28e833fcf12731d89669e Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sun, 10 Jul 2022 18:57:19 +0200 Subject: Remove some ineffectual calls to purecopy * lisp/dired.el (dired-chown-program, dired-trivial-filenames): * lisp/emacs-lisp/shortdoc.el (shortdoc--display-function): * lisp/help-fns.el (help-fns--mention-shortdoc-groups): * lisp/mail/mail-extr.el (mail-extr-full-name-prefixes) (mail-extr-all-letters-but-separators, mail-extr-all-letters) (mail-extr-first-letters, mail-extr-last-letters) (mail-extr-bad-dot-pattern, mail-extr-full-name-suffix-pattern) (mail-extr-alternative-address-pattern) (mail-extr-trailing-comment-start-pattern) (mail-extr-name-pattern, mail-extr-telephone-extension-pattern) (mail-extr-ham-call-sign-pattern, mail-extr-normal-name-pattern) (mail-extr-two-name-pattern) (mail-extr-listserv-list-name-pattern) (mail-extr-stupid-vms-date-stamp-pattern) (mail-extr-hz-embedded-gb-encoded-chinese-pattern) (mail-extr-x400-encoded-address-pattern) (mail-extr-x400-encoded-address-field-pattern-format) (mail-extr-x400-encoded-address-surname-pattern) (mail-extr-x400-encoded-address-given-name-pattern) (mail-extr-x400-encoded-address-full-name-pattern): Remove ineffectual calls to purecopy. --- lisp/dired.el | 10 ++-- lisp/emacs-lisp/shortdoc.el | 6 +-- lisp/help-fns.el | 2 +- lisp/mail/mail-extr.el | 113 ++++++++++++++++++++------------------------ 4 files changed, 59 insertions(+), 72 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/lisp/dired.el b/lisp/dired.el index b9ab2a9b1e6..43563d969f1 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -103,10 +103,10 @@ If `dired-maybe-use-globstar' is non-nil, then `dired-insert-directory' checks this alist to enable globstar in the shell subprocess.") (defcustom dired-chown-program - (purecopy (cond ((executable-find "chown") "chown") - ((file-executable-p "/usr/sbin/chown") "/usr/sbin/chown") - ((file-executable-p "/etc/chown") "/etc/chown") - (t "chown"))) + (cond ((executable-find "chown") "chown") + ((file-executable-p "/usr/sbin/chown") "/usr/sbin/chown") + ((file-executable-p "/etc/chown") "/etc/chown") + (t "chown")) "Name of chown command (usually `chown')." :group 'dired :type 'file) @@ -161,7 +161,7 @@ always set this variable to t." :type 'boolean :group 'dired-mark) -(defcustom dired-trivial-filenames (purecopy "\\`\\.\\.?\\'\\|\\`\\.?#") +(defcustom dired-trivial-filenames "\\`\\.\\.?\\'\\|\\`\\.?#" "Regexp of files to skip when finding first file of a directory. A value of nil means move to the subdir line. A value of t means move to first file." diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 68293931c3c..a2d954cadbb 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1367,15 +1367,15 @@ If SAME-WINDOW, don't pop to a new window." 'action (lambda (_) (describe-function function)) 'follow-link t - 'help-echo (purecopy "mouse-1, RET: describe function")) + 'help-echo "mouse-1, RET: describe function") (insert-text-button (symbol-name function) 'face 'button 'action (lambda (_) (info-lookup-symbol function 'emacs-lisp-mode)) 'follow-link t - 'help-echo (purecopy "mouse-1, RET: show \ -function's documentation in the Info manual"))) + 'help-echo "mouse-1, RET: show \ +function's documentation in the Info manual")) (setq arglist-start (point)) (insert ")\n") ;; Doc string. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 17354783ca0..fbd40158701 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -868,7 +868,7 @@ the C sources, too." (shortdoc-display-group group object help-window-keep-selected)) 'follow-link t - 'help-echo (purecopy "mouse-1, RET: show documentation group"))) + 'help-echo "mouse-1, RET: show documentation group")) groups) (insert (if (= (length groups) 1) " group.\n" diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index c87ea2b46e6..25ce4ea9025 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -1,7 +1,6 @@ ;;; mail-extr.el --- extract full name and address from email header -*- lexical-binding: t; -*- -;; Copyright (C) 1991-1994, 1997, 2001-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 1991-2022 Free Software Foundation, Inc. ;; Author: Joe Wells ;; Maintainer: emacs-devel@gnu.org @@ -240,8 +239,7 @@ we will act as though we couldn't find a full name in the address." ;; Matches a leading title that is not part of the name (does not ;; contribute to uniquely identifying the person). (defcustom mail-extr-full-name-prefixes - (purecopy - "\\(Prof\\|D[Rr]\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.?[ \t\n]") + "\\(Prof\\|D[Rr]\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.?[ \t\n]" "Matches prefixes to the full name that identify a person's position. These are stripped from the full name because they do not contribute to uniquely identifying the person." @@ -279,45 +277,42 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Yes, there are weird people with digits in their names. ;; You will also notice the consideration for the ;; Swedish/Finnish/Norwegian character set. -(defconst mail-extr-all-letters-but-separators - (purecopy "][[:alnum:]{|}'~`")) +(defconst mail-extr-all-letters-but-separators "][[:alnum:]{|}'~`") ;; Any character that can occur in a name in an RFC 822 (or later) ;; address including the separator (hyphen and possibly period) for ;; multipart names. ;; #### should . be in here? (defconst mail-extr-all-letters - (purecopy (concat mail-extr-all-letters-but-separators "-"))) + (concat mail-extr-all-letters-but-separators "-")) ;; Any character that can start a name. ;; Keep this set as minimal as possible. -(defconst mail-extr-first-letters (purecopy "[:alpha:]")) +(defconst mail-extr-first-letters "[:alpha:]") ;; Any character that can end a name. ;; Keep this set as minimal as possible. -(defconst mail-extr-last-letters (purecopy "[:alpha:]`'.")) +(defconst mail-extr-last-letters "[:alpha:]`'.") (defconst mail-extr-leading-garbage "\\W+") ;; (defconst mail-extr-non-begin-name-chars -;; (purecopy (concat "^" mail-extr-first-letters))) +;; (concat "^" mail-extr-first-letters)) ;; (defconst mail-extr-non-end-name-chars -;; (purecopy (concat "^" mail-extr-last-letters))) +;; (concat "^" mail-extr-last-letters)) ;; Matches periods used instead of spaces. Must not match the period ;; following an initial. (defconst mail-extr-bad-dot-pattern - (purecopy - (format "\\([%s][%s]\\)\\.+\\([%s]\\)" - mail-extr-all-letters - mail-extr-last-letters - mail-extr-first-letters))) + (format "\\([%s][%s]\\)\\.+\\([%s]\\)" + mail-extr-all-letters + mail-extr-last-letters + mail-extr-first-letters)) ;; Matches an embedded or leading nickname that should be removed. ;; (defconst mail-extr-nickname-pattern -;; (purecopy -;; (format "\\([ .]\\|\\`\\)[\"'`[(]\\([ .%s]+\\)[]\"')] " -;; mail-extr-all-letters))) +;; (format "\\([ .]\\|\\`\\)[\"'`[(]\\([ .%s]+\\)[]\"')] " +;; mail-extr-all-letters)) ;; Matches the occurrence of a generational name suffix, and the last ;; character of the preceding name. This is important because we want to @@ -325,59 +320,56 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; *** Perhaps this should be a user-customizable variable. However, the ;; *** regular expression is fairly tricky to alter, so maybe not. (defconst mail-extr-full-name-suffix-pattern - (purecopy - (format - "\\(,? ?\\([JjSs][Rr]\\.?\\|V?I+V?\\)\\)\\([^%s]\\([^%s]\\|\\'\\)\\|\\'\\)" - mail-extr-all-letters mail-extr-all-letters))) + (format + "\\(,? ?\\([JjSs][Rr]\\.?\\|V?I+V?\\)\\)\\([^%s]\\([^%s]\\|\\'\\)\\|\\'\\)" + mail-extr-all-letters mail-extr-all-letters)) -(defconst mail-extr-roman-numeral-pattern (purecopy "V?I+V?\\b")) +(defconst mail-extr-roman-numeral-pattern "V?I+V?\\b") ;; Matches a trailing uppercase (with other characters possible) acronym. ;; Must not match a trailing uppercase last name or trailing initial (defconst mail-extr-weird-acronym-pattern - (purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)")) + "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)") ;; Matches a mixed-case or lowercase name (not an initial). ;; #### Match Latin1 lower case letters here too? ;; (defconst mail-extr-mixed-case-name-pattern -;; (purecopy -;; (format -;; "\\b\\([a-z][%s]*[%s]\\|[%s][%s]*[a-z][%s]*[%s]\\|[%s][%s]*[a-z]\\)" -;; mail-extr-all-letters mail-extr-last-letters -;; mail-extr-first-letters mail-extr-all-letters mail-extr-all-letters -;; mail-extr-last-letters mail-extr-first-letters mail-extr-all-letters))) +;; (format +;; "\\b\\([a-z][%s]*[%s]\\|[%s][%s]*[a-z][%s]*[%s]\\|[%s][%s]*[a-z]\\)" +;; mail-extr-all-letters mail-extr-last-letters +;; mail-extr-first-letters mail-extr-all-letters mail-extr-all-letters +;; mail-extr-last-letters mail-extr-first-letters mail-extr-all-letters)) ;; Matches a trailing alternative address. ;; #### Match Latin1 letters here too? ;; #### Match _ before @ here too? (defconst mail-extr-alternative-address-pattern - (purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]")) + "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]") ;; Matches a variety of trailing comments not including comma-delimited ;; comments. (defconst mail-extr-trailing-comment-start-pattern - (purecopy " [-{]\\|--\\|[+@#>, Mark Feit @@ -386,7 +378,7 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; KE9TV KF0NV N1API N3FU N3GZE N3IGS N4KCC N7IKQ N9HHU W4YHF W6ANK WA2SUH ;; WB7VZI N2NJZ NR3G KJ4KK AB4UM AL7NI KH6OH WN3KBT N4TMI W1A N0NZO (defconst mail-extr-ham-call-sign-pattern - (purecopy "\\b\\(DX[0-9]+\\|[AKNW][A-Z]?[0-9][A-Z][A-Z]?[A-Z]?\\)")) + "\\b\\(DX[0-9]+\\|[AKNW][A-Z]?[0-9][A-Z][A-Z]?[A-Z]?\\)") ;; Possible trailing suffixes: "\\(/\\(KT\\|A[AEG]\\|[R0-9]\\)\\)?" ;; /KT == Temporary Technician (has CSC but not "real" license) @@ -400,31 +392,29 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Matches normal single-part name (defconst mail-extr-normal-name-pattern - (purecopy (format "\\b[%s][%s]+[%s]" - mail-extr-first-letters - mail-extr-all-letters-but-separators - mail-extr-last-letters))) + (format "\\b[%s][%s]+[%s]" + mail-extr-first-letters + mail-extr-all-letters-but-separators + mail-extr-last-letters)) ;; Matches a single word name. ;; (defconst mail-extr-one-name-pattern -;; (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'"))) +;; (concat "\\`" mail-extr-normal-name-pattern "\\'")) ;; Matches normal two names with missing middle initial ;; The first name is not allowed to have a hyphen because this can cause ;; false matches where the "middle initial" is actually the first letter ;; of the second part of the first name. (defconst mail-extr-two-name-pattern - (purecopy - (concat "\\`\\(" mail-extr-normal-name-pattern - "\\|" mail-extr-initial-pattern - "\\) +\\(" mail-extr-name-pattern "\\)\\(,\\|\\'\\)"))) + (concat "\\`\\(" mail-extr-normal-name-pattern + "\\|" mail-extr-initial-pattern + "\\) +\\(" mail-extr-name-pattern "\\)\\(,\\|\\'\\)")) (defconst mail-extr-listserv-list-name-pattern - (purecopy "Multiple recipients of list \\([-A-Z]+\\)")) + "Multiple recipients of list \\([-A-Z]+\\)") (defconst mail-extr-stupid-vms-date-stamp-pattern - (purecopy - "[0-9][0-9]-[JFMASOND][aepuco][nbrylgptvc]-[0-9][0-9][0-9][0-9] [0-9]+ *")) + "[0-9][0-9]-[JFMASOND][aepuco][nbrylgptvc]-[0-9][0-9][0-9][0-9] [0-9]+ *") ;;; HZ -- GB (PRC Chinese character encoding) in ASCII embedding protocol ;; @@ -443,25 +433,23 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; mode from GB back to ASCII. (Note that the escape-from-GB code '~}' ;; ($7E7D) is outside the defined GB range.) (defconst mail-extr-hz-embedded-gb-encoded-chinese-pattern - (purecopy "~{\\([^~].\\|~[^}]\\)+~}")) + "~{\\([^~].\\|~[^}]\\)+~}") ;; The leading optional lowercase letters are for a bastardized version of ;; the encoding, as is the optional nature of the final slash. (defconst mail-extr-x400-encoded-address-pattern - (purecopy "[a-z]?[a-z]?\\(/[A-Za-z]+\\(\\.[A-Za-z]+\\)?=[^/]+\\)+/?\\'")) + "[a-z]?[a-z]?\\(/[A-Za-z]+\\(\\.[A-Za-z]+\\)?=[^/]+\\)+/?\\'") (defconst mail-extr-x400-encoded-address-field-pattern-format - (purecopy "/%s=\\([^/]+\\)\\(/\\|\\'\\)")) + "/%s=\\([^/]+\\)\\(/\\|\\'\\)") (defconst mail-extr-x400-encoded-address-surname-pattern ;; S stands for Surname (family name). - (purecopy - (format mail-extr-x400-encoded-address-field-pattern-format "[Ss]"))) + (format mail-extr-x400-encoded-address-field-pattern-format "[Ss]")) (defconst mail-extr-x400-encoded-address-given-name-pattern ;; G stands for Given name. - (purecopy - (format mail-extr-x400-encoded-address-field-pattern-format "[Gg]"))) + (format mail-extr-x400-encoded-address-field-pattern-format "[Gg]")) (defconst mail-extr-x400-encoded-address-full-name-pattern ;; PN stands for Personal Name. When used it represents the combination @@ -469,8 +457,7 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; "The one system I used having this field asked it with the prompt ;; `Personal Name'. But they mapped it into G and S on outgoing real ;; X.400 addresses. As they mapped G and S into PN on incoming..." - (purecopy - (format mail-extr-x400-encoded-address-field-pattern-format "[Pp][Nn]"))) + (format mail-extr-x400-encoded-address-field-pattern-format "[Pp][Nn]")) -- cgit v1.2.3 From d62766305ad8fe6ca1695341c34b9836d051e3cb Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Wed, 13 Jul 2022 13:46:52 +0200 Subject: Add `take` and `ntake` (bug#56521) These are useful list primitives, complementary to `nthcdr`. * src/fns.c (Ftake, Fntake): New. (syms_of_fns): Defsubr them. * doc/lispref/lists.texi (List Elements): * lisp/emacs-lisp/shortdoc.el (list): Document. * lisp/emacs-lisp/byte-opt.el (side-effect-free-fns, pure-fns): Declare `take` pure and side-effect-free. * test/src/fns-tests.el (fns-tests--take-ref, fns--take-ntake): New test. * etc/NEWS: Announce. --- doc/lispref/lists.texi | 29 +++++++++++++++++++++++ etc/NEWS | 5 ++++ lisp/emacs-lisp/byte-opt.el | 4 ++-- lisp/emacs-lisp/shortdoc.el | 4 ++++ src/fns.c | 57 +++++++++++++++++++++++++++++++++++++++++++++ test/src/fns-tests.el | 49 ++++++++++++++++++++++++++++++++++++++ 6 files changed, 146 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index a4f0ba815b1..2a9ad1d5e00 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -340,6 +340,35 @@ If @var{n} is zero, @code{nthcdr} returns all of @end example @end defun +@defun take n list +This function returns the @var{n} first elements of @var{list}. Essentially, +it returns the part of @var{list} that @code{nthcdr} skips. + +@code{take} returns @var{list} if it is shorter than @var{n} elements; +it returns @code{nil} if @var{n} is zero or negative. + +@example +@group +(take 3 '(a b c d)) + @result{} (a b c) +@end group +@group +(take 10 '(a b c d)) + @result{} (a b c d) +@end group +@group +(take 0 '(a b c d)) + @result{} nil +@end group +@end example +@end defun + +@defun ntake n list +This is a version of @code{take} that works by destructively modifying +the list structure of the argument. That makes it faster, but the +original value of @var{list} is lost. +@end defun + @defun last list &optional n This function returns the last link of @var{list}. The @code{car} of this link is the list's last element. If @var{list} is null, diff --git a/etc/NEWS b/etc/NEWS index 604e30ce251..11189020f18 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3197,6 +3197,11 @@ to preserve the old behavior, apply (let ((default-directory temporary-file-directory)) (process-attributes pid)) ++++ +** New functions 'take' and 'ntake'. +'(take N LIST)' returns the first N elements of LIST; 'ntake' does +the same but works by modifying LIST destructively. + * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index ce73a5e91f4..a457e2044d8 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1459,7 +1459,7 @@ See Info node `(elisp) Integer Basics'." symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte string-to-multibyte - tan time-convert truncate + take tan time-convert truncate unibyte-char-to-multibyte upcase user-full-name user-login-name user-original-login-name custom-variable-p vconcat @@ -1560,7 +1560,7 @@ See Info node `(elisp) Integer Basics'." ;; arguments. This is pure enough for the purposes of ;; constant folding, but not necessarily for all kinds of ;; code motion. - car cdr car-safe cdr-safe nth nthcdr last + car cdr car-safe cdr-safe nth nthcdr last take equal length safe-length memq memql member diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index a2d954cadbb..1514ece6d1f 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -595,6 +595,10 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (nth 1 '(one two three))) (nthcdr :eval (nthcdr 1 '(one two three))) + (take + :eval (take 3 '(one two three four))) + (ntake + :eval (ntake 3 (list 'one 'two 'three 'four))) (elt :eval (elt '(one two three) 1)) (car-safe diff --git a/src/fns.c b/src/fns.c index 1f57e675b12..84cfec6c3f0 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1557,6 +1557,61 @@ substring_both (Lisp_Object string, ptrdiff_t from, ptrdiff_t from_byte, return res; } +DEFUN ("take", Ftake, Stake, 2, 2, 0, + doc: /* Return the first N elements of LIST. +If N is zero or negative, return nil. +If LIST is no more than N elements long, return it (or a copy). */) + (Lisp_Object n, Lisp_Object list) +{ + CHECK_FIXNUM (n); + EMACS_INT m = XFIXNUM (n); + if (m <= 0) + return Qnil; + CHECK_LIST (list); + if (NILP (list)) + return Qnil; + Lisp_Object ret = Fcons (XCAR (list), Qnil); + Lisp_Object prev = ret; + m--; + list = XCDR (list); + while (m > 0 && CONSP (list)) + { + Lisp_Object p = Fcons (XCAR (list), Qnil); + XSETCDR (prev, p); + prev = p; + m--; + list = XCDR (list); + } + if (m > 0 && !NILP (list)) + wrong_type_argument (Qlistp, list); + return ret; +} + +DEFUN ("ntake", Fntake, Sntake, 2, 2, 0, + doc: /* Modify LIST to keep only the first N elements. +If N is zero or negative, return nil. +If LIST is no more than N elements long, return it. */) + (Lisp_Object n, Lisp_Object list) +{ + CHECK_FIXNUM (n); + EMACS_INT m = XFIXNUM (n); + if (m <= 0) + return Qnil; + CHECK_LIST (list); + Lisp_Object tail = list; + --m; + while (m > 0 && CONSP (tail)) + { + tail = XCDR (tail); + m--; + } + if (CONSP (tail)) + XSETCDR (tail, Qnil); + else if (!NILP (tail)) + wrong_type_argument (Qlistp, list); + return list; +} + DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0, doc: /* Take cdr N times on LIST, return the result. */) (Lisp_Object n, Lisp_Object list) @@ -6082,6 +6137,8 @@ The same variable also affects the function `read-answer'. */); defsubr (&Scopy_alist); defsubr (&Ssubstring); defsubr (&Ssubstring_no_properties); + defsubr (&Stake); + defsubr (&Sntake); defsubr (&Snthcdr); defsubr (&Snth); defsubr (&Selt); diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 20074ca0d21..a84cce3ad4e 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -1365,4 +1365,53 @@ (should-error (string-to-unibyte "å")) (should-error (string-to-unibyte "ABC∀BC"))) +(defun fns-tests--take-ref (n list) + "Reference implementation of `take'." + (named-let loop ((m n) (tail list) (ac nil)) + (if (and (> m 0) tail) + (loop (1- m) (cdr tail) (cons (car tail) ac)) + (nreverse ac)))) + +(ert-deftest fns--take-ntake () + "Test `take' and `ntake'." + ;; Check errors and edge cases. + (should-error (take 'x '(a))) + (should-error (ntake 'x '(a))) + (should-error (take 1 'a)) + (should-error (ntake 1 'a)) + (should-error (take 2 '(a . b))) + (should-error (ntake 2 '(a . b))) + ;; Tolerate non-lists for a count of zero. + (should (equal (take 0 'a) nil)) + (should (equal (ntake 0 'a) nil)) + ;; But not non-numbers for empty lists. + (should-error (take 'x nil)) + (should-error (ntake 'x nil)) + + (dolist (list '(nil (a) (a b) (a b c) (a b c d) (a . b) (a b . c))) + (ert-info ((prin1-to-string list) :prefix "list: ") + (let ((max (if (proper-list-p list) + (+ 2 (length list)) + (safe-length list)))) + (dolist (n (number-sequence -1 max)) + (ert-info ((prin1-to-string n) :prefix "n: ") + (let* ((l (copy-tree list)) + (ref (fns-tests--take-ref n l))) + (should (equal (take n l) ref)) + (should (equal l list)) + (should (equal (ntake n l) ref)))))))) + + ;; Circular list. + (let ((list (list 'a 'b 'c))) + (setcdr (nthcdr 2 list) (cdr list)) ; list now (a b c b c b c ...) + (should (equal (take 0 list) nil)) + (should (equal (take 1 list) '(a))) + (should (equal (take 2 list) '(a b))) + (should (equal (take 3 list) '(a b c))) + (should (equal (take 4 list) '(a b c b))) + (should (equal (take 5 list) '(a b c b c))) + (should (equal (take 10 list) '(a b c b c b c b c b))) + + (should (equal (ntake 10 list) '(a b))))) + ;;; fns-tests.el ends here -- cgit v1.2.3 From b70a00d9bf119b6bc5c1f7c3397d04b7d8892fb7 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Wed, 20 Jul 2022 11:24:49 +0200 Subject: Gently discourage use of `lsh` (bug#56641) * lisp/subr.el (lsh): Note the general preference for `ash`. * lisp/emacs-lisp/shortdoc.el (number): Remove entry for `lsh`. It was identical to that for `ash` which is misleading. Shortdoc is very helpful for finding the right function to use, and `lsh` is just for compatibility at this point. --- lisp/emacs-lisp/shortdoc.el | 3 --- lisp/subr.el | 5 ++++- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 1514ece6d1f..05b3361cb3d 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1183,9 +1183,6 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (ash :eval (ash 1 4) :eval (ash 16 -1)) - (lsh - :eval (lsh 1 4) - :eval (lsh 16 -1)) (logand :no-eval "(logand #b10 #b111)" :result-string "#b10") diff --git a/lisp/subr.el b/lisp/subr.el index ef6cc41f3b9..510a77dbc8d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -524,7 +524,10 @@ was called." "Return VALUE with its bits shifted left by COUNT. If COUNT is negative, shifting is actually to the right. In this case, if VALUE is a negative fixnum treat it as unsigned, -i.e., subtract 2 * `most-negative-fixnum' from VALUE before shifting it." +i.e., subtract 2 * `most-negative-fixnum' from VALUE before shifting it. + +This function is provided for compatibility. In new code, use `ash' +instead." (when (and (< value 0) (< count 0)) (when (< value most-negative-fixnum) (signal 'args-out-of-range (list value count))) -- cgit v1.2.3 From 70341cab3eb26e2f49bbc13d6bca247ab9403abc Mon Sep 17 00:00:00 2001 From: Sam Steingold Date: Tue, 26 Jul 2022 13:47:03 -0400 Subject: string-equal-ignore-case: new function * lisp/cedet/semantic/complete.el (semantic-collector-calculate-completions): Use `string-prefix-p' instead of explicit `compare-strings'. * lisp/emacs-lisp/byte-opt.el (side-effect-free-fns): Add `string-equal-ignore-case'. * lisp/emacs-lisp/cl-extra.el (cl-equalp): Use `string-equal-ignore-case'. * lisp/emacs-lisp/shadow.el (load-path-shadows-find): Likewise. * lisp/emacs-lisp/shortdoc.el (string): Add `string-equal-ignore-case'. * lisp/files.el (file-truename): Use `string-equal-ignore-case'. (file-relative-name): Likewise. * lisp/gnus/gnus-art.el (article-hide-boring-headers): Use `string-equal-ignore-case' instead of `gnus-string-equal'. * lisp/gnus/gnus-util.el (gnus-string-equal): Remove, use `string-equal-ignore-case' instead. * lisp/international/mule-cmds.el (describe-language-environment): Use `string-equal-ignore-case'. (locale-charset-match-p): Likewise. * lisp/man.el (Man-softhyphen-to-minus): Use `string-prefix-p'. * lisp/minibuffer.el (completion--string-equal-p): Remove, use `string-equal-ignore-case' instead. (completion--twq-all): Use `string-equal-ignore-case'. (completion--do-completion): Likewise. * lisp/net/browse-url.el (browse-url-default-windows-browser): Use `string-prefix-p' instead of explicit `compare-strings'. * lisp/org/ob-core.el (org-babel-results-keyword): Use `string-equal-ignore-case' instead of explicit `compare-strings'. (org-babel-insert-result): Likewise. * lisp/org/org-compat.el (string-equal-ignore-case): Define unless defined already. (org-mode-flyspell-verify): Use `string-equal-ignore-case'. * lisp/org/org-lint.el (org-lint-duplicate-custom-id): Likewise. * lisp/org/ox.el (org-export-resolve-radio-link): Use `string-equal-ignore-case' and `string-clean-whitespace'. * lisp/progmodes/flymake-proc.el (flymake-proc--check-patch-master-file-buffer): Use `string-prefix-p' instead of explicit `compare-strings'. * lisp/progmodes/idlwave.el (idlwave-class-or-superclass-with-tag): Use `string-equal-ignore-case' instead of explicit `compare-strings'. * lisp/subr.el (member-ignore-case): Use `string-equal-ignore-case'. (string-equal-ignore-case): Compare strings ignoring case. * lisp/textmodes/bibtex.el (bibtex-string=): Remove. (bibtex-format-entry, bibtex-font-lock-url, bibtex-autofill-entry) (bibtex-print-help-message, bibtex-validate, bibtex-validate-globally) (bibtex-clean-entry, bibtex-completion-at-point-function, (bibtex-url): Use `string-equal-ignore-case' instead of `bibtex-string='. * lisp/textmodes/sgml-mode.el (sgml-get-context): Use `string-equal-ignore-case' instead of explicit `compare-strings'. (sgml-calculate-indent): Likewise * test/lisp/subr-tests.el (string-comparison-test): Add tests for `string-equal-ignore-case'. --- doc/lispref/hash.texi | 10 ++++------ doc/lispref/strings.texi | 5 +++++ etc/NEWS | 3 +++ lisp/cedet/semantic/complete.el | 10 ++-------- lisp/emacs-lisp/byte-opt.el | 2 +- lisp/emacs-lisp/cl-extra.el | 3 +-- lisp/emacs-lisp/shadow.el | 7 ++----- lisp/emacs-lisp/shortdoc.el | 2 ++ lisp/files.el | 28 ++++++++++++---------------- lisp/gnus/gnus-art.el | 12 ++++++------ lisp/gnus/gnus-util.el | 9 --------- lisp/international/mule-cmds.el | 5 ++--- lisp/man.el | 3 +-- lisp/minibuffer.el | 15 +++++---------- lisp/net/browse-url.el | 3 +-- lisp/org/ob-core.el | 9 ++++----- lisp/org/org-compat.el | 14 ++++++++++---- lisp/org/org-lint.el | 6 ++---- lisp/org/ox.el | 12 +++++------- lisp/progmodes/flymake-proc.el | 5 +---- lisp/progmodes/idlwave.el | 2 +- lisp/subr.el | 8 +++++++- lisp/textmodes/bibtex.el | 32 ++++++++++++++------------------ lisp/textmodes/sgml-mode.el | 13 +++++-------- lisp/vc/vc-dispatcher.el | 3 +-- test/lisp/subr-tests.el | 7 +++++++ 26 files changed, 104 insertions(+), 124 deletions(-) (limited to 'lisp/emacs-lisp/shortdoc.el') diff --git a/doc/lispref/hash.texi b/doc/lispref/hash.texi index d3ae673d44d..25a56bd7151 100644 --- a/doc/lispref/hash.texi +++ b/doc/lispref/hash.texi @@ -324,15 +324,13 @@ the same integer. compared case-insensitively. @example -(defun case-fold-string= (a b) - (eq t (compare-strings a nil nil b nil nil t))) -(defun case-fold-string-hash (a) +(defun string-hash-ignore-case (a) (sxhash-equal (upcase a))) -(define-hash-table-test 'case-fold - 'case-fold-string= 'case-fold-string-hash) +(define-hash-table-test 'ignore-case + 'string-equal-ignore-case 'string-hash-ignore-case) -(make-hash-table :test 'case-fold) +(make-hash-table :test 'ignore-case) @end example Here is how you could define a hash table test equivalent to the diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index cb9019daa9b..bf61bb7c479 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -560,6 +560,11 @@ Representations}. @code{string-equal} is another name for @code{string=}. @end defun +@defun string-equal-ignore-case string1 string2 +@code{string-equal-ignore-case} compares strings ignoring case +differences, like @code{char-equal} when @code{case-fold-search} is +@code{t}. + @cindex locale-dependent string equivalence @defun string-collate-equalp string1 string2 &optional locale ignore-case This function returns @code{t} if @var{string1} and @var{string2} are diff --git a/etc/NEWS b/etc/NEWS index a31c50a850c..7c1462ee573 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2502,6 +2502,9 @@ abbrevs. This has been generalized via the 'save-some-buffers-functions' variable, and packages can now register things to be saved. +** New function 'string-equal-ignore-case'. +This compares strings ignoring case differences. + ** Themes --- diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index cd04cf86434..436ad08c5fc 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -1011,20 +1011,14 @@ Output must be in semanticdb Find result format." (oref obj last-prefix))) (completionlist (cond ((or same-prefix-p - (and last-prefix (eq (compare-strings - last-prefix 0 nil - prefix 0 (length last-prefix)) - t))) + (and last-prefix (string-prefix-p last-prefix prefix t))) ;; We have the same prefix, or last-prefix is a ;; substring of the of new prefix, in which case we are ;; refining our symbol so just re-use cache. (oref obj last-all-completions)) ((and last-prefix (> (length prefix) 1) - (eq (compare-strings - prefix 0 nil - last-prefix 0 (length prefix)) - t)) + (string-prefix-p prefix last-prefix t)) ;; The new prefix is a substring of the old ;; prefix, and it's longer than one character. ;; Perform a full search to pull in additional diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 5705b2a8fd7..3f4af44051c 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1451,7 +1451,7 @@ See Info node `(elisp) Integer Basics'." radians-to-degrees rassq rassoc read-from-string regexp-opt regexp-quote region-beginning region-end reverse round sin sqrt string string< string= string-equal string-lessp - string> string-greaterp string-empty-p + string> string-greaterp string-empty-p string-equal-ignore-case string-prefix-p string-suffix-p string-blank-p string-search string-to-char string-to-number string-to-syntax substring diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 8e38df43c87..607810ee141 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -71,8 +71,7 @@ numbers of different types (float vs. integer), and also compares strings case-insensitively." (cond ((eq x y) t) ((stringp x) - (and (stringp y) (= (length x) (length y)) - (eq (compare-strings x nil nil y nil nil t) t))) + (and (stringp y) (string-equal-ignore-case x y))) ((numberp x) (and (numberp y) (= x y))) ((consp x) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 2343a9b589f..da32e4564f6 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -128,11 +128,8 @@ See the documentation for `list-load-path-shadows' for further information." (if (setq orig-dir (assoc file files - (when dir-case-insensitive - (lambda (f1 f2) - (eq (compare-strings f1 nil nil - f2 nil nil t) - t))))) + (and dir-case-insensitive + #'string-equal-ignore-case))) ;; This file was seen before, we have a shadowing. ;; Report it unless the files are identical. (let ((base1 (concat (cdr orig-dir) "/" (car orig-dir))) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 05b3361cb3d..315afd4312b 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -243,6 +243,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) + (string-equal-ignore-case + :eval (string-equal-ignore-case "foo" "FOO")) (eq :eval (eq "foo" "foo")) (eql diff --git a/lisp/files.el b/lisp/files.el index bc74dfa7381..37ed796a687 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1428,7 +1428,7 @@ containing it, until no links are left at any level. ;; If these are equal, we have the (or a) root directory. (or (string= dir dirfile) (and (file-name-case-insensitive-p dir) - (eq (compare-strings dir 0 nil dirfile 0 nil t) t)) + (string-equal-ignore-case dir dirfile)) ;; If this is the same dir we last got the truename for, ;; save time--don't recalculate. (if (assoc dir (car prev-dirs)) @@ -5459,21 +5459,17 @@ on a DOS/Windows machine, it returns FILENAME in expanded form." ;; Test for different drive letters (not (eq t (compare-strings filename 0 2 directory 0 2 fold-case))) ;; Test for UNCs on different servers - (not (eq t (compare-strings - (progn - (if (string-match "\\`//\\([^:/]+\\)/" filename) - (match-string 1 filename) - ;; Windows file names cannot have ? in - ;; them, so use that to detect when - ;; neither FILENAME nor DIRECTORY is a - ;; UNC. - "?")) - 0 nil - (progn - (if (string-match "\\`//\\([^:/]+\\)/" directory) - (match-string 1 directory) - "?")) - 0 nil t))))) + (not (string-equal-ignore-case + (if (string-match "\\`//\\([^:/]+\\)/" filename) + (match-string 1 filename) + ;; Windows file names cannot have ? in + ;; them, so use that to detect when + ;; neither FILENAME nor DIRECTORY is a + ;; UNC. + "?") + (if (string-match "\\`//\\([^:/]+\\)/" directory) + (match-string 1 directory) + "?"))))) ;; Test for different remote file system identification (not (equal fremote dremote))) filename diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 4b68a54ce81..e28d84e06fe 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -1939,8 +1939,8 @@ always hide." 'boring-headers))) ;; Hide boring Newsgroups header. ((eq elem 'newsgroups) - (when (gnus-string-equal - (gnus-fetch-field "newsgroups") + (when (string-equal-ignore-case + (or (gnus-fetch-field "newsgroups") "") (gnus-group-real-name (if (boundp 'gnus-newsgroup-name) gnus-newsgroup-name @@ -1954,7 +1954,7 @@ always hide." gnus-newsgroup-name "")))) (when (and to to-address (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in To (nth 1 (mail-extract-address-components to)) to-address))) @@ -1967,7 +1967,7 @@ always hide." gnus-newsgroup-name "")))) (when (and to to-list (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in To (nth 1 (mail-extract-address-components to)) to-list))) @@ -1980,13 +1980,13 @@ always hide." gnus-newsgroup-name "")))) (when (and cc to-list (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in Cc (nth 1 (mail-extract-address-components cc)) to-list))) (gnus-article-hide-header "cc")))) ((eq elem 'followup-to) - (when (gnus-string-equal + (when (string-equal-ignore-case (message-fetch-field "followup-to") (message-fetch-field "newsgroups")) (gnus-article-hide-header "followup-to"))) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 218a4d242b2..31a275c7d05 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1073,15 +1073,6 @@ ARG is passed to the first function." s) (error string))) -;; This might use `compare-strings' to reduce consing in the -;; case-insensitive case, but it has to cope with null args. -;; (`string-equal' uses symbol print names.) -(defun gnus-string-equal (x y) - "Like `string-equal', except it compares case-insensitively." - (and (= (length x) (length y)) - (or (string-equal x y) - (string-equal (downcase x) (downcase y))))) - (defcustom gnus-use-byte-compile t "If non-nil, byte-compile crucial run-time code." :type 'boolean diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index df1c06ec272..12896cc4b0e 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -2199,8 +2199,7 @@ See `set-language-info-alist' for use in programs." first nil)) (dolist (elt l) (when (or (eq input-method elt) - (eq t (compare-strings language-name nil nil - (nth 1 elt) nil nil t))) + (string-equal-ignore-case language-name (nth 1 elt))) (when first (insert "Input methods:\n") (setq first nil)) @@ -2599,7 +2598,7 @@ Matching is done ignoring case and any hyphens and underscores in the names. E.g. `ISO_8859-1' and `iso88591' both match `iso-8859-1'." (setq charset1 (replace-regexp-in-string "[-_]" "" charset1)) (setq charset2 (replace-regexp-in-string "[-_]" "" charset2)) - (eq t (compare-strings charset1 nil nil charset2 nil nil t))) + (string-equal-ignore-case charset1 charset2)) (defvar locale-charset-alist nil "Coding system alist keyed on locale-style charset name. diff --git a/lisp/man.el b/lisp/man.el index 951e0ef9add..d66f63972ae 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1241,8 +1241,7 @@ See the variable `Man-notify-method' for the different notification behaviors." (defun Man-softhyphen-to-minus () ;; \255 is SOFT HYPHEN in Latin-N. Versions of Debian man, at ;; least, emit it even when not in a Latin-N locale. - (unless (eq t (compare-strings "latin-" 0 nil - current-language-environment 0 6 t)) + (unless (string-prefix-p "latin-" current-language-environment t) (goto-char (point-min)) (while (search-forward "­" nil t) (replace-match "-")))) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index bdf6d852a95..3daab8a1e8d 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -634,9 +634,6 @@ for use at QPOS." (let ((qstr (funcall qfun completion))) (cons qstr (length qstr)))))) -(defun completion--string-equal-p (s1 s2) - (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case))) - (defun completion--twq-all (string ustring completions boundary _unquote requote) (when completions @@ -650,7 +647,7 @@ for use at QPOS." (qfullprefix (substring string 0 qfullpos)) ;; FIXME: This assertion can be wrong, e.g. in Cygwin, where ;; (unquote "c:\bin") => "/usr/bin" but (unquote "c:\") => "/". - ;;(cl-assert (completion--string-equal-p + ;;(cl-assert (string-equal-ignore-case ;; (funcall unquote qfullprefix) ;; (concat (substring ustring 0 boundary) prefix)) ;; t)) @@ -688,7 +685,7 @@ for use at QPOS." (let* ((rest (substring completion 0 (length prefix))) (qrest (funcall qfun rest))) - (if (completion--string-equal-p qprefix qrest) + (if (string-equal-ignore-case qprefix qrest) (propertize qrest 'face 'completions-common-part) qprefix)))) @@ -696,7 +693,7 @@ for use at QPOS." ;; FIXME: Similarly here, Cygwin's mapping trips this ;; assertion. ;;(cl-assert - ;; (completion--string-equal-p + ;; (string-equal-ignore-case ;; (funcall unquote ;; (concat (substring string 0 qboundary) ;; qcompletion)) @@ -1309,10 +1306,8 @@ when the buffer's text is already an exact match." ;; for appearance, the string is rewritten if the case changes. (let* ((comp-pos (cdr comp)) (completion (car comp)) - (completed (not (eq t (compare-strings completion nil nil - string nil nil t)))) - (unchanged (eq t (compare-strings completion nil nil - string nil nil nil)))) + (completed (not (string-equal-ignore-case completion string))) + (unchanged (string-equal completion string))) (if unchanged (goto-char end) ;; Insert in minibuffer the chars we got. diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index a55aec76bfc..6713208d268 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -981,8 +981,7 @@ The optional NEW-WINDOW argument is not used." ;; quotes in the MAILTO URLs, so we prefer ;; to leave the URL with its embedded %nn ;; encoding intact. - (if (eq t (compare-strings url nil 7 - "file://" nil nil)) + (if (string-prefix-p "file://" url) (url-unhex-string url) url))))) diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 04af84d2e44..3d159ed38a9 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -136,8 +136,7 @@ used." :type 'string :safe (lambda (v) (and (stringp v) - (eq (compare-strings "RESULTS" nil nil v nil nil t) - t)))) + (string-equal-ignore-case "RESULTS" v)))) (defcustom org-babel-noweb-wrap-start "<<" "String used to begin a noweb reference in a code block. @@ -2435,7 +2434,7 @@ INFO may provide the values of these header arguments (in the ;; Escape contents from "export" wrap. Wrap ;; inline results within an export snippet with ;; appropriate value. - ((eq t (compare-strings type nil nil "export" nil nil t)) + ((string-equal-ignore-case type "export") (let ((backend (pcase split (`(,_) "none") (`(,_ ,b . ,_) b)))) @@ -2446,14 +2445,14 @@ INFO may provide the values of these header arguments (in the backend) "@@)}}}"))) ;; Escape contents from "example" wrap. Mark ;; inline results as verbatim. - ((eq t (compare-strings type nil nil "example" nil nil t)) + ((string-equal-ignore-case type "example") (funcall wrap opening-line closing-line nil nil "{{{results(=" "=)}}}")) ;; Escape contents from "src" wrap. Mark ;; inline results as inline source code. - ((eq t (compare-strings type nil nil "src" nil nil t)) + ((string-equal-ignore-case type "src") (let ((inline-open (pcase split (`(,_) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index a65bf6f677a..085e32d6774 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -934,6 +934,14 @@ Implements `define-error' for older emacsen." (put name 'error-conditions (copy-sequence (cons name (get 'error 'error-conditions)))))) +(unless (fboundp 'string-equal-ignore-case) + ;; From Emacs subr.el. + (defun string-equal-ignore-case (string1 string2) + "Like `string-equal', but case-insensitive. +Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison." + (eq t (compare-strings string1 0 nil string2 0 nil t)))) + (unless (fboundp 'string-suffix-p) ;; From Emacs subr.el. (defun string-suffix-p (suffix string &optional ignore-case) @@ -1125,10 +1133,8 @@ ELEMENT is the element at point." (and log (let ((drawer (org-element-lineage element '(drawer)))) (and drawer - (eq (compare-strings - log nil nil - (org-element-property :drawer-name drawer) nil nil t) - t))))) + (string-equal-ignore-case + log (org-element-property :drawer-name drawer)))))) nil) (t (cl-case (org-element-type element) diff --git a/lisp/org/org-lint.el b/lisp/org/org-lint.el index 83c2d08a907..6d8cf3f2374 100644 --- a/lisp/org/org-lint.el +++ b/lisp/org/org-lint.el @@ -334,10 +334,8 @@ called with one argument, the key used for comparison." ast 'node-property (lambda (property) - (and (eq (compare-strings "CUSTOM_ID" nil nil - (org-element-property :key property) nil nil - t) - t) + (and (string-equal-ignore-case + "CUSTOM_ID" (org-element-property :key property)) (org-element-property :value property))) (lambda (property _) (org-element-property :begin property)) (lambda (key) (format "Duplicate CUSTOM_ID property \"%s\"" key)))) diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 55258bc79da..1bdf4dead89 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -80,6 +80,7 @@ (require 'org-element) (require 'org-macro) (require 'tabulated-list) +(require 'subr-x) (declare-function org-src-coderef-format "org-src" (&optional element)) (declare-function org-src-coderef-regexp "org-src" (fmt &optional label)) @@ -4436,15 +4437,12 @@ INFO is a plist used as a communication channel. Return value can be a radio-target object or nil. Assume LINK has type \"radio\"." - (let ((path (replace-regexp-in-string - "[ \r\t\n]+" " " (org-element-property :path link)))) + (let ((path (string-clean-whitespace (org-element-property :path link)))) (org-element-map (plist-get info :parse-tree) 'radio-target (lambda (radio) - (and (eq (compare-strings - (replace-regexp-in-string - "[ \r\t\n]+" " " (org-element-property :value radio)) - nil nil path nil nil t) - t) + (and (string-equal-ignore-case + (string-clean-whitespace (org-element-property :value radio)) + path) radio)) info 'first-match))) diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el index 4ab16831bc1..249ae9dff2f 100644 --- a/lisp/progmodes/flymake-proc.el +++ b/lisp/progmodes/flymake-proc.el @@ -399,10 +399,7 @@ instead of reading master file from disk." (not (string-match (format "\\.%s\\'" source-file-extension) inc-name)) (setq inc-name (concat inc-name "." source-file-extension))) - (when (eq t (compare-strings - source-file-nondir nil nil - inc-name (- (length inc-name) - (length source-file-nondir)) nil)) + (when (string-suffix-p source-file-nondir inc-name) (flymake-log 3 "inc-name=%s" inc-name) (when (flymake-proc--check-include source-file-name inc-name include-dirs) diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index a2061fde762..b3dc3cac763 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -7528,7 +7528,7 @@ associated TAG, if any." (setq cl (pop sclasses)) (let ((tags (idlwave-class-tags cl))) (while tags - (if (eq t (compare-strings tag 0 nil (car tags) 0 nil t)) + (if (string-equal-ignore-case tag (car tags)) (throw 'exit cl)) (setq tags (cdr tags)))))))) diff --git a/lisp/subr.el b/lisp/subr.el index a0ad967533d..c82b33bba53 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -868,7 +868,7 @@ Non-strings in LIST are ignored." (declare (side-effect-free t)) (while (and list (not (and (stringp (car list)) - (eq t (compare-strings elt 0 nil (car list) 0 nil t))))) + (string-equal-ignore-case elt (car list))))) (setq list (cdr list))) list) @@ -5302,6 +5302,12 @@ and replace a sub-expression, e.g. (setq matches (cons (substring string start l) matches)) ; leftover (apply #'concat (nreverse matches))))) +(defun string-equal-ignore-case (string1 string2) + "Like `string-equal', but case-insensitive. +Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison." + (eq t (compare-strings string1 0 nil string2 0 nil t))) + (defun string-prefix-p (prefix string &optional ignore-case) "Return non-nil if PREFIX is a prefix of STRING. If IGNORE-CASE is non-nil, the comparison is done without paying attention diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 333cfa51695..64cb0dc0fe6 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -2213,10 +2213,6 @@ Point must be at beginning of preamble. Do not move point." ;; Helper Functions -(defsubst bibtex-string= (str1 str2) - "Return t if STR1 and STR2 are equal, ignoring case." - (eq t (compare-strings str1 0 nil str2 0 nil t))) - (defun bibtex-delete-whitespace () "Delete all whitespace starting at point." (if (looking-at "[ \t\n]+") @@ -2657,7 +2653,7 @@ Formats current entry according to variable `bibtex-entry-format'." ;; update page dashes (if (and (memq 'page-dashes format) - (bibtex-string= field-name "pages") + (string-equal-ignore-case field-name "pages") (progn (goto-char beg-text) (looking-at "\\([\"{][0-9]+\\)[ \t\n]*--?[ \t\n]*\\([0-9]+[\"}]\\)"))) @@ -2710,7 +2706,7 @@ Formats current entry according to variable `bibtex-entry-format'." ;; use book title of crossref'd entry (if (and (memq 'inherit-booktitle format) empty-field - (bibtex-string= field-name "booktitle") + (string-equal-ignore-case field-name "booktitle") crossref-key) (let ((title (save-excursion (save-restriction @@ -3503,7 +3499,7 @@ If NO-BUTTON is non-nil do not generate buttons." (let ((lst bibtex-generate-url-list) url) (while (and (not found) (setq url (car (pop lst)))) (goto-char start) - (setq found (and (bibtex-string= name (car url)) + (setq found (and (string-equal-ignore-case name (car url)) (re-search-forward (cdr url) end t)))))) (unless found (goto-char end))) (if (and found (not no-button)) @@ -3954,7 +3950,7 @@ entry (for example, the year parts of the keys)." (goto-char (1- (match-beginning 0))) (bibtex-beginning-of-entry) (if (and (looking-at bibtex-entry-head) - (bibtex-string= type (bibtex-type-in-head)) + (string-equal-ignore-case type (bibtex-type-in-head)) ;; In case we found ourselves :-( (not (equal key (setq tmp (bibtex-key-in-head))))) (setq other-key tmp @@ -3963,7 +3959,7 @@ entry (for example, the year parts of the keys)." (bibtex-end-of-entry) (bibtex-skip-to-valid-entry) (if (and (looking-at bibtex-entry-head) - (bibtex-string= type (bibtex-type-in-head)) + (string-equal-ignore-case type (bibtex-type-in-head)) ;; In case we found ourselves :-( (not (equal key (setq tmp (bibtex-key-in-head)))) (or (not other-key) @@ -4004,9 +4000,9 @@ interactive calls." (interactive (list nil t)) (unless field (setq field (car (bibtex-find-text-internal nil nil comma)))) (if (string-search "@" field) - (cond ((bibtex-string= field "@string") + (cond ((string-equal-ignore-case field "@string") (message "String definition")) - ((bibtex-string= field "@preamble") + ((string-equal-ignore-case field "@preamble") (message "Preamble definition")) (t (message "Entry key"))) (let* ((case-fold-search t) @@ -4588,7 +4584,7 @@ Return t if test was successful, nil otherwise." bounds field idx) (while (setq bounds (bibtex-parse-field)) (let ((field-name (bibtex-name-in-field bounds))) - (if (and (bibtex-string= field-name "month") + (if (and (string-equal-ignore-case field-name "month") ;; Check only abbreviated month fields. (let ((month (bibtex-text-in-field-bounds bounds))) (not (or (string-match "\\`[\"{].+[\"}]\\'" month) @@ -4669,7 +4665,7 @@ Return t if test was successful, nil otherwise." (while (re-search-forward bibtex-entry-head nil t) (setq entry-type (bibtex-type-in-head) key (bibtex-key-in-head)) - (if (or (and strings (bibtex-string= entry-type "string")) + (if (or (and strings (string-equal-ignore-case entry-type "string")) (assoc-string entry-type bibtex-entry-alist t)) (if (member key key-list) (push (format-message @@ -5046,10 +5042,10 @@ At end of the cleaning process, the functions in (user-error "Not inside a BibTeX entry"))) (entry-type (bibtex-type-in-head)) (key (bibtex-key-in-head))) - (cond ((bibtex-string= entry-type "preamble") + (cond ((string-equal-ignore-case entry-type "preamble") ;; (bibtex-format-preamble) (user-error "No clean up of @Preamble entries")) - ((bibtex-string= entry-type "string") + ((string-equal-ignore-case entry-type "string") (setq entry-type 'string)) ;; (bibtex-format-string) (t (bibtex-format-entry))) @@ -5326,10 +5322,10 @@ entries from minibuffer." (>= pnt (bibtex-start-of-text-in-field bounds)) (<= pnt (bibtex-end-of-text-in-field bounds))) (setq name (bibtex-name-in-field bounds t) - compl (cond ((bibtex-string= name "crossref") + compl (cond ((string-equal-ignore-case name "crossref") ;; point is in crossref field 'crossref-key) - ((bibtex-string= name "month") + ((string-equal-ignore-case name "month") ;; point is in month field bibtex-predefined-month-strings) ;; point is in other field @@ -5488,7 +5484,7 @@ Return the URL or nil if none can be generated." (while (and (not url) (setq scheme (pop lst))) ;; Verify the match of `bibtex-font-lock-url' by ;; comparing with TEXT. - (when (and (bibtex-string= (caar scheme) name) + (when (and (string-equal-ignore-case (caar scheme) name) (string-match (cdar scheme) text)) (setq url t scheme (cdr scheme))))))) diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 8f9b603ef5f..ba0a94b4a1f 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -1536,8 +1536,7 @@ not the case, the first tag returned is the one inside which we are." ;; [ Well, actually it depends, but we don't have the info about ;; when it doesn't and when it does. --Stef ] (setq ignore nil))) - ((eq t (compare-strings (sgml-tag-name tag-info) nil nil - (car stack) nil nil t)) + ((string-equal-ignore-case (sgml-tag-name tag-info) (car stack)) (setq stack (cdr stack))) (t ;; The open and close tags don't match. @@ -1549,9 +1548,8 @@ not the case, the first tag returned is the one inside which we are." ;; but it's a bad assumption when tags *are* closed but ;; not properly nested. (while (and (cdr tmp) - (not (eq t (compare-strings - (sgml-tag-name tag-info) nil nil - (cadr tmp) nil nil t)))) + (not (string-equal-ignore-case + (sgml-tag-name tag-info) (cadr tmp)))) (setq tmp (cdr tmp))) (if (cdr tmp) (setcdr tmp (cddr tmp))))) (message "Unmatched tags <%s> and " @@ -1701,9 +1699,8 @@ LCON is the lexical context, if any." (there (point))) ;; Ignore previous unclosed start-tag in context. (while (and context unclosed - (eq t (compare-strings - (sgml-tag-name (car context)) nil nil - unclosed nil nil t))) + (string-equal-ignore-case + (sgml-tag-name (car context)) unclosed)) (setq context (cdr context))) ;; Indent to reflect nesting. (cond diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index f50d45217c7..e2a490092b5 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -761,8 +761,7 @@ the buffer contents as a comment." ;; (while (and (not member) fileset) ;; (let ((elem (pop fileset))) ;; (if (if (file-directory-p elem) -;; (eq t (compare-strings buffer-file-name nil (length elem) -;; elem nil nil)) +;; (string-prefix-p elem buffer-file-name) ;; (eq (current-buffer) (get-file-buffer elem))) ;; (setq member t)))) ;; member)) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 84f3e41148d..d45f409e85b 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -368,6 +368,13 @@ 2))) (ert-deftest string-comparison-test () + (should (string-equal-ignore-case "abc" "abc")) + (should (string-equal-ignore-case "abc" "ABC")) + (should (string-equal-ignore-case "abc" "abC")) + (should-not (string-equal-ignore-case "abc" "abCD")) + (should (string-equal-ignore-case "S" "s")) + ;; not yet: (should (string-equal-ignore-case "SS" "ß")) + (should (string-lessp "abc" "acb")) (should (string-lessp "aBc" "abc")) (should (string-lessp "abc" "abcd")) -- cgit v1.2.3