Mercurial > hg > xemacs-beta
changeset 5865:a45722e74335
Merge.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 12 Mar 2015 16:27:13 +0000 |
| parents | 27876789edc5 (diff) 750fab17b299 (current diff) |
| children | 5ea790936de9 |
| files | lisp/ChangeLog src/ChangeLog tests/ChangeLog tests/automated/lisp-tests.el |
| diffstat | 15 files changed, 464 insertions(+), 178 deletions(-) [+] |
line wrap: on
line diff
--- a/ChangeLog Wed Feb 25 11:47:12 2015 +0000 +++ b/ChangeLog Thu Mar 12 16:27:13 2015 +0000 @@ -1,3 +1,7 @@ +2015-02-28 Mike Kupfer <mike.kupfer@xemacs.org> + + * README: fix note about which Bitbucket repository to push to. + 2015-01-10 Stephen J. Turnbull <stephen@xemacs.org> * configure.ac (Postgresql): Improve Installation text.
--- a/README Wed Feb 25 11:47:12 2015 +0000 +++ b/README Thu Mar 12 16:27:13 2015 +0000 @@ -1,5 +1,8 @@ This directory tree holds version 21.5 of XEmacs. +Note: new changesets should be pushed to the "xemacs" repository +(https://bitbucket.org/xemacs/xemacs), not "xemacs-beta". + The information in this file has been superseded by the XEmacs FAQ. The easiest way to read the FAQ is to go to @@ -11,5 +14,3 @@ If you don't have XEmacs running and can't access the web, look directly at `man/xemacs-faq.texi' or `info/xemacs-faq.info'. - -
--- a/lib-src/ChangeLog Wed Feb 25 11:47:12 2015 +0000 +++ b/lib-src/ChangeLog Thu Mar 12 16:27:13 2015 +0000 @@ -1,3 +1,16 @@ +2015-03-08 Aidan Kehoe <kehoea@parhasard.net> + + * gnuserv.c (echo_request): + No longer close the file handle unconditionally, leave this to the + individual socket types. + * gnuserv.c (handle_internet_request): + Close the file handle here. + * gnuserv.c (handle_unix_request): + Don't close the file handle here, document why (it broke gnuclient + under OS X). It should actually be OK, but my suspicion is that + the issues is that the Unix (local) domain sockets are still + underdocumented compared to the internet sockets. + 2014-12-05 Jerry James <james@xemacs.org> * gnuserv.c (echo_request): close the socket when done
--- a/lib-src/gnuserv.c Wed Feb 25 11:47:12 2015 +0000 +++ b/lib-src/gnuserv.c Thu Mar 12 16:27:13 2015 +0000 @@ -321,7 +321,6 @@ exit(1); } /* if */ - close(s); } /* echo_request */ @@ -754,6 +753,7 @@ echo_request(s); + close(s); } /* handle_internet_request */ #endif /* INTERNET_DOMAIN_SOCKETS */ @@ -864,6 +864,14 @@ echo_request(s); + /* Closing s here (or rather, within echo_request() with both + internet and local connections) meant gnuserv never returned + usefully under OS X, as of 20150308, reflecting changeset + https://bitbucket.org/xemacs/xemacs/commits/c03dd89 . Keeping it + open is not a significant security risk (it's a local connection, + with file system access restrictions) and given the practical + limitation on the number of handles gnuserv will keep around, + it's also not a significant resource issue. Leave it open. */ } /* handle_unix_request */ #endif /* UNIX_DOMAIN_SOCKETS */
--- a/lisp/ChangeLog Wed Feb 25 11:47:12 2015 +0000 +++ b/lisp/ChangeLog Thu Mar 12 16:27:13 2015 +0000 @@ -1,3 +1,57 @@ +2015-03-12 Aidan Kehoe <kehoea@parhasard.net> + + * simple.el (append-message): Be more careful about saving a + non-nil value for START in message-stack. + +2015-03-11 Aidan Kehoe <kehoea@parhasard.net> + + * isearch-mode.el: + * isearch-mode.el (isearch-fix-case): + Use the new #'no-case-regexp-p function if treating ISEARCH-STRING + as a regular expression; otherwise, use the [[:upper:]] character + class. + * isearch-mode.el (isearch-no-upper-case-p): Removed. + * isearch-mode.el (with-caps-disable-folding): Removed. + These two haven't been used since 1998. + * occur.el (occur-1): + Use #'no-case-regexp-p here. + * replace.el (perform-replace): + Don't use #'no-upper-case-p, use #'no-case-regexp-p or + (string-match "[[:upper:]]" ...) as appropriate. + * simple.el: + * simple.el (no-upper-case-p): Removed. This did two different + things, and its secondary function (examining regular expressions) + just became much more complicated; move the regular expression + functionality to its own function, use character classes when + examining non-regular-expressions instead. + The code to look for character classes, and the design decision + that this should be done, are from GNU, thank you Stefan Monnier. + * simple.el (no-case-regexp-p): New. + Given a REGEXP, return non-nil if it has nothing to suggest an + interactive user wants a case-sensitive search. + * simple.el (with-search-caps-disable-folding): + * simple.el (with-interactive-search-caps-disable-folding): + Update both these macros to use #'no-case-regexp-p. + +2015-03-11 Aidan Kehoe <kehoea@parhasard.net> + + Correct #'clear-message and friends so the START and END supplied + to #'append-message are reflected when restoring messages from the + message stack. + * simple.el (remove-message-hook): + Update this to reflect the START and END keyword arguments. + * simple.el (log-message): + Update this to take START and END keyword arguments. + * simple.el (clear-message): + Update this to reflect a changed `message-stack' alist structure. + * simple.el (remove-message): + Update this to reflect a changed `message-stack' alist structure; + don't do `with-trapping-errors' and resignal use + #'call-with-condition-handler directly instead, for better + backtraces and easier debugging. + * simple.el (append-message): + Update this to reflect a changed message-stack structure. + 2015-02-25 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (digit-char-p): Moved to data.c.
--- a/lisp/isearch-mode.el Wed Feb 25 11:47:12 2015 +0000 +++ b/lisp/isearch-mode.el Thu Mar 12 16:27:13 2015 +0000 @@ -1068,7 +1068,11 @@ (not isearch-fixed-case) search-caps-disable-folding) (setq isearch-case-fold-search - (no-upper-case-p isearch-string isearch-regexp))) + (if isearch-regexp + (no-case-regexp-p isearch-string) + (save-match-data + (let (case-fold-search) + (not (string-match "[[:upper:]]" isearch-string))))))) (setq isearch-mode (if case-fold-search (if isearch-case-fold-search " Isearch" ;As God Intended Mode @@ -1856,15 +1860,6 @@ t)) isearch-unhidden-extents))))) -(defun isearch-no-upper-case-p (string) - "Return t if there are no upper case chars in string. -But upper case chars preceded by \\ do not count since they -have special meaning in a regexp." - ;; this incorrectly returns t for "\\\\A" - (let ((case-fold-search nil)) - (not (string-match "\\(^\\|[^\\]\\)[A-Z]" string)))) -(make-obsolete 'isearch-no-upper-case-p 'no-upper-case-p) - ;; Portability functions to support various Emacs versions. (defun isearch-char-to-string (c) @@ -1876,20 +1871,6 @@ ; (isearch-char-to-string c)) (define-function 'isearch-text-char-description 'text-char-description) - -;; Used by etags.el and info.el -(defmacro with-caps-disable-folding (string &rest body) "\ -Eval BODY with `case-fold-search' let to nil if STRING contains -uppercase letters and `search-caps-disable-folding' is t." - `(let ((case-fold-search - (if (and case-fold-search search-caps-disable-folding) - (isearch-no-upper-case-p ,string) - case-fold-search))) - ,@body)) -(make-obsolete 'with-caps-disable-folding 'with-search-caps-disable-folding) -(put 'with-caps-disable-folding 'lisp-indent-function 1) -(put 'with-caps-disable-folding 'edebug-form-spec '(form body)) - ;;;======================================================== ;;; Advanced highlighting
--- a/lisp/occur.el Wed Feb 25 11:47:12 2015 +0000 +++ b/lisp/occur.el Thu Mar 12 16:27:13 2015 +0000 @@ -394,8 +394,7 @@ (let ((count (occur-engine regexp active-bufs occur-buf (or nlines list-matching-lines-default-context-lines) - (and case-fold-search - (no-upper-case-p regexp t)) + (and case-fold-search (no-case-regexp-p regexp)) list-matching-lines-buffer-name-face nil list-matching-lines-face t))) (let* ((bufcount (length active-bufs))
--- a/lisp/replace.el Wed Feb 25 11:47:12 2015 +0000 +++ b/lisp/replace.el Thu Mar 12 16:27:13 2015 +0000 @@ -563,7 +563,11 @@ ;; XEmacs addition (qr-case-fold-search (if (and case-fold-search search-caps-disable-folding) - (no-upper-case-p search-string regexp-flag) + (if regexp-flag + (no-case-regexp-p search-string) + (save-match-data + (let (case-fold-search) + (not (string-match "[[:upper:]]" search-string))))) case-fold-search)) (message (if query-flag
--- a/lisp/simple.el Wed Feb 25 11:47:12 2015 +0000 +++ b/lisp/simple.el Thu Mar 12 16:27:13 2015 +0000 @@ -94,47 +94,70 @@ "Warnings customizations." :group 'minibuffer) - (defcustom search-caps-disable-folding t "*If non-nil, upper case chars disable case fold searching. This does not apply to \"yanked\" strings." :type 'boolean :group 'editing-basics) -;; This is stolen (and slightly modified) from FSF emacs's -;; `isearch-no-upper-case-p'. -(defun no-upper-case-p (string &optional regexp-flag) - "Return t if there are no upper case chars in STRING. -If REGEXP-FLAG is non-nil, disregard letters preceded by `\\' (but not `\\\\') -since they have special meaning in a regexp." +(defun no-case-regexp-p (regexp) + "Return t if there are no case-specific constructs in REGEXP. + +Lower case characters are regarded as not case-specific. Upper case +characters are usually regarded as case-specific, but upper case characters +used in special regexp constructs, where they do not match upper case +characters specifically, are regarded as not case-specific. In contrast, the +character classes [:lower:] and [:upper:] are viewed as case-specific. + +This is intended to be used by interactive searching code to decide, in a +do-what-I-mean fashion, whether a given search should be case-sensitive." (let ((case-fold-search nil)) - (not (string-match (if regexp-flag - "\\(^\\|\\\\\\\\\\|[^\\]\\)[A-Z]" - "[A-Z]") - string)) - )) - -(defmacro with-search-caps-disable-folding (string regexp-flag &rest body) "\ -Eval BODY with `case-fold-search' let to nil if `search-caps-disable-folding' -is non-nil, and if STRING (either a string or a regular expression according -to REGEXP-FLAG) contains uppercase letters." + (save-match-data + (not (or (string-match "\\(^\\|\\\\\\\\\\|[^\\]\\)[[:upper:]]" regexp) + (and (string-match "\\[:\\(upp\\|low\\)er:]" regexp) + (condition-case err + (progn + (string-match (substring regexp 0 + (match-beginning 0)) "") + nil) + (invalid-regexp + (equal "Unmatched [ or [^" (cadr err)))))))))) + +(defmacro* with-search-caps-disable-folding (string regexp-p &body body) + "Execute the forms in BODY, respecting `search-caps-disable-folding'. + +Within BODY, bind `case-fold-search' to nil if `search-caps-disable-folding' +is non-nil, REGEXP-P is nil, and if STRING contains any uppercase characters. + +If REGEXP-P is non-nil, treat STRING as a regular expression, and bind +`case-fold-search' to nil if it contains uppercase characters that are +not special regular expression constructs, or if it contains +case-specific character classes such as `[[:upper:]]' or +`[[:lower:]]'. See `no-case-regexp-p'." `(let ((case-fold-search (if (and case-fold-search search-caps-disable-folding) - (no-upper-case-p ,string ,regexp-flag) + (if ,regexp-p + (no-case-regexp-p ,string) + (save-match-data + (let (case-fold-search) + (not (string-match "[[:upper:]]" ,string))))) case-fold-search))) ,@body)) (put 'with-search-caps-disable-folding 'lisp-indent-function 2) (put 'with-search-caps-disable-folding 'edebug-form-spec '(sexp sexp &rest form)) -(defmacro with-interactive-search-caps-disable-folding (string regexp-flag - &rest body) - "Same as `with-search-caps-disable-folding', but only in the case of a -function called interactively." +(defmacro* with-interactive-search-caps-disable-folding (string regexp-p + &body body) + "Like `with-search-caps-disable-folding', but only when interactive." `(let ((case-fold-search - (if (and (interactive-p) - case-fold-search search-caps-disable-folding) - (no-upper-case-p ,string ,regexp-flag) + (if (and (interactive-p) case-fold-search + search-caps-disable-folding) + (if ,regexp-p + (no-case-regexp-p ,string) + (save-match-data + (let (case-fold-search) + (not (string-match "[[:upper:]]" ,string))))) case-fold-search))) ,@body)) (put 'with-interactive-search-caps-disable-folding 'lisp-indent-function 2) @@ -4166,8 +4189,9 @@ (defvar remove-message-hook 'log-message "A function or list of functions to be called when a message is removed from the echo area at the bottom of the frame. The label of the removed -message is passed as the first argument, and the text of the message -as the second argument.") +message is passed as the first argument, the text of the message as the second +argument, and the start and end of the substring of the message can be +supplied as keyword arguments.") (defcustom log-message-max-size 50000 "Maximum size of the \" *Message-Log*\" buffer. See `log-message'." @@ -4300,7 +4324,7 @@ "For use as the `log-message-filter-function'. Only logs error messages." (eq label 'error)) -(defun log-message (label message) +(defun* log-message (label message &key (start 0) end) "Stuff a copy of the message into the \" *Message-Log*\" buffer, if it satisfies the `log-message-filter-function'. @@ -4316,12 +4340,10 @@ (let (extent) ;; Mark multiline message with an extent, which `view-lossage' ;; will recognize. - (save-match-data - (when (string-match "\n" message) - (setq extent (make-extent (point) (point))) - (set-extent-properties extent '(end-open nil message-multiline t))) - ) - (insert message "\n") + (when (find ?\n message :start start :end end) + (setq extent (make-extent (point) (point))) + (set-extent-properties extent '(end-open nil message-multiline t))) + (write-line message (current-buffer) :start start :end end) (when extent (set-extent-property extent 'end-open t))) (when (> (point-max) (max log-message-max-size (point-min))) @@ -4377,42 +4399,48 @@ (if no-restore nil ; just preparing to put another msg up (if message-stack - (let ((oldmsg (cdr (car message-stack)))) - (raw-append-message oldmsg frame stdout-p) - oldmsg) + (let ((oldmsg (second (car message-stack)))) + (prog1 + ;; #### Doesn't pass back information about the substring of + ;; OLDMSG displayed. None of our callers use this, as of + ;; 20150311, though. + oldmsg + (raw-append-message oldmsg frame stdout-p + :start (third (car message-stack)) + :end (fourth (car message-stack))))) ;; #### Should we (redisplay-echo-area) here? Messes some ;; things up. nil)))) (defun remove-message (&optional label frame) - ;; If label is nil, we want to remove all matching messages. - ;; Must reverse the stack first to log them in the right order. - (let ((log nil)) - (while (and message-stack - (or (null label) ; null label means clear whole stack - (eq label (car (car message-stack))))) - (push (car message-stack) log) - (setq message-stack (cdr message-stack))) - (let ((s message-stack)) - (while (cdr s) - (let ((msg (car (cdr s)))) - (if (eq label (car msg)) - (progn - (push msg log) - (setcdr s (cdr (cdr s)))) - (setq s (cdr s)))))) + "Remove any message with a specified LABEL from `message-stack'. + +With nil LABEL, remove all messages from `message-stack'. Calls those +functions specified by `remove-message-hook' with the details of each removed +message." + (let (log) + (if label + (setq log (reverse (remove* label message-stack :test-not #'eq + :key #'car)) + message-stack (delete* label message-stack :key #'car)) + ;; If label is nil, we want to remove all messages. Must reverse the + ;; stack first to log them in the right order. + (setq log (nreverse message-stack) + message-stack nil)) ;; (possibly) log each removed message (while log - (with-trapping-errors - :operation 'remove-message-hook - :class 'message-log - :error-form (progn - (setq remove-message-hook nil) - (let ((inhibit-read-only t)) - (erase-buffer " *Echo Area*"))) - :resignal t - (run-hook-with-args 'remove-message-hook - (car (car log)) (cdr (car log)))) + (call-with-condition-handler + ((macro . (lambda (function) (subst '#:xEbgpd2 'error function))) + #'(lambda (error) + (setq remove-message-hook nil) + (let ((inhibit-read-only t)) + (erase-buffer " *Echo Area*")) + (lwarn 'message-log 'warning + "Error in `remove-message-hook': %s\n\nBacktrace follows:\n%s" + (error-message-string error) + (backtrace-in-condition-handler-eliminating-handler 'error)))) + #'run-hook-with-args 'remove-message-hook (caar log) + (cadar log) :start (third (car log)) :end (fourth (car log))) (setq log (cdr log))))) (defun* append-message (label message &optional frame stdout-p @@ -4436,10 +4464,16 @@ ;; able to append to an existing message. (if (eq 'stream (frame-type frame)) (set-device-clear-left-side (frame-device frame) nil)) - (let ((top (car message-stack))) - (if (eq label (car top)) - (setcdr top (concat (cdr top) message)) - (push (cons label message) message-stack))) + (if (eq label (caar message-stack)) + (setf (cadar message-stack) + (concat (subseq (cadar message-stack) (third (car message-stack)) + (fourth (car message-stack))) + (if (or end (not (eql start 0))) + (subseq message start end) + message)) + (caddar message-stack) 0 + (car (cdddar message-stack)) nil) + (push (list label message start end) message-stack)) (raw-append-message message frame stdout-p :start start :end end) (if (eq 'stream (frame-type frame)) (set-device-clear-left-side (frame-device frame) t)))
--- a/man/ChangeLog Wed Feb 25 11:47:12 2015 +0000 +++ b/man/ChangeLog Thu Mar 12 16:27:13 2015 +0000 @@ -1,3 +1,9 @@ +2015-02-23 Mike Kupfer <mike.kupfer@xemacs.org> + + * internals/internals.texi (The Redisplay Mechanism): + Add notes about pixel_to_glyph_translation and related code. + (pixel_to_glyph_translation): New section. + 2014-03-28 Jerry James <james@xemacs.org> * Makefile.in: Do not build texinfo files.
--- a/man/internals/internals.texi Wed Feb 25 11:47:12 2015 +0000 +++ b/man/internals/internals.texi Thu Mar 12 16:27:13 2015 +0000 @@ -625,6 +625,7 @@ * Critical Redisplay Sections:: * Line Start Cache:: * Redisplay Piece by Piece:: +* pixel_to_glyph_translation:: * Modules for the Redisplay Mechanism:: * Modules for other Display-Related Lisp Objects:: @@ -19049,12 +19050,18 @@ @chapter The Redisplay Mechanism @cindex redisplay mechanism, the - The redisplay mechanism is one of the most complicated sections of + The redisplay mechanism is responsible for updating the display, +such as after an edit or a highlighting change. It is one of the most +complicated sections of XEmacs, especially from a conceptual standpoint. This is doubly so because, unlike for the basic aspects of the Lisp interpreter, the computer science theories of how to efficiently handle redisplay are not well-developed. + The redisplay code also provides a low-level operation to +map window system coordinates to XEmacs objects. This is used +elsewhere in XEmacs, most notably for dealing with mouse events. + When working with the redisplay mechanism, remember the Golden Rules of Redisplay: @@ -19071,6 +19078,7 @@ * Critical Redisplay Sections:: * Line Start Cache:: * Redisplay Piece by Piece:: +* pixel_to_glyph_translation:: * Modules for the Redisplay Mechanism:: * Modules for other Display-Related Lisp Objects:: @end menu @@ -19485,7 +19493,7 @@ In case you're wondering, the Second Golden Rule of Redisplay is not applicable. -@node Redisplay Piece by Piece, Modules for the Redisplay Mechanism, Line Start Cache, The Redisplay Mechanism +@node Redisplay Piece by Piece, pixel_to_glyph_translation, Line Start Cache, The Redisplay Mechanism @section Redisplay Piece by Piece @cindex redisplay piece by piece @@ -19582,7 +19590,30 @@ @code{ensure_face_cachel_complete}, with the actual work being done by @code{ensure_face_cachel_contains_charset}. -@node Modules for the Redisplay Mechanism, Modules for other Display-Related Lisp Objects, Redisplay Piece by Piece, The Redisplay Mechanism +@node pixel_to_glyph_translation, Modules for the Redisplay Mechanism, Redisplay Piece by Piece, The Redisplay Mechanism +@section pixel_to_glyph_translation +@cindex pixel_to_glyph_translation +@cindex events, mouse motion +@cindex mouse motion events + +The data structures described in @ref{Redisplay Piece by Piece} are +also the basis for mapping native window system coordinates to +higher-level objects, such as a toolbar button, a modeline character, +a glyph, or a text character. @code{pixel_to_glyph_translation} does +the bulk of this translation, with some further tweaking done by the +functions in @file{events.c}. + +@code{pixel_to_glyph_translation} is called very frequently when +XEmacs is processing mouse-motion events. To improve performance, +@code{pixel_to_glyph_translation} caches the most recently returned +values. The cache includes the pixel coordinate boundaries for which +the cached results are valid. So if the next event is within those +boundaries, @code{pixel_to_glyph_translation} returns the cached +results (fast path). Otherwise, @code{pixel_to_glyph_translation} +walks through the redisplay data structures, then updates the cache +with the new results (slow path). + +@node Modules for the Redisplay Mechanism, Modules for other Display-Related Lisp Objects, pixel_to_glyph_translation, The Redisplay Mechanism @section Modules for the Redisplay Mechanism @cindex modules for the redisplay mechanism @cindex redisplay mechanism, modules for the
--- a/src/ChangeLog Wed Feb 25 11:47:12 2015 +0000 +++ b/src/ChangeLog Thu Mar 12 16:27:13 2015 +0000 @@ -1,3 +1,18 @@ +2015-03-04 Aidan Kehoe <kehoea@parhasard.net> + + * sequence.c (count_with_tail): + Accept COUNT from #'substitute, #'nsubstitute too. + * sequence.c (FdeleteX): + Only remove COUNT from the arguments if FROM-END is non-nil. + * sequence.c (Fnsubstitute): + Remove COUNT from the arguments if specified and FROM-END is + non-nil. + * sequence.c (Fsubstitute): + Remove COUNT from the arguments if specified and FROM-END is + non-nil. Do this before calling count_with_tail(). When we + encounter the cons return by count_with_tail(), use the + replacement object. + 2015-02-25 Aidan Kehoe <kehoea@parhasard.net> * lread.c (read_atom): Use the new calling convention for
--- a/src/sequence.c Wed Feb 25 11:47:12 2015 +0000 +++ b/src/sequence.c Thu Mar 12 16:27:13 2015 +0000 @@ -710,9 +710,6 @@ /* Our callers should have filtered out non-positive COUNT. */ assert (counting >= 0); - /* And we're not prepared to handle COUNT from any other caller at the - moment. */ - assert (EQ (caller, QremoveX)|| EQ (caller, QdeleteX)); } check_test = get_check_test_function (item, &test, test_not, if_, if_not, @@ -1878,7 +1875,7 @@ PARSE_KEYWORDS (FdeleteX, nargs, args, 9, (test, if_not, if_, test_not, key, start, end, from_end, - count), (start = Qzero, count = Qunbound)); + count), (start = Qzero)); CHECK_SEQUENCE (sequence); CHECK_NATNUM (start); @@ -1890,45 +1887,41 @@ ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); } - if (!UNBOUNDP (count)) - { - if (!NILP (count)) - { - CHECK_INTEGER (count); - if (FIXNUMP (count)) - { - counting = XFIXNUM (count); - } + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (FIXNUMP (count)) + { + counting = XFIXNUM (count); + } #ifdef HAVE_BIGNUM - else - { - counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? - 1 + MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM - 1; - } + else + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM - 1; + } #endif - - if (counting < 1) - { - return sequence; - } - - if (!NILP (from_end)) + if (counting < 1) + { + return sequence; + } + + if (!NILP (from_end)) + { + /* Sigh, this is inelegant. Force count_with_tail () to ignore + the count keyword, so we get the actual number of matching + elements, and can start removing from the beginning for the + from-end case. */ + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args; + ii < nargs; ii += 2) { - /* Sigh, this is inelegant. Force count_with_tail () to ignore - the count keyword, so we get the actual number of matching - elements, and can start removing from the beginning for the - from-end case. */ - for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args; - ii < nargs; ii += 2) + if (EQ (args[ii], Q_count)) { - if (EQ (args[ii], Q_count)) - { - args[ii + 1] = Qnil; - break; - } + args[ii + 1] = Qnil; + break; } - ii = 0; } + ii = 0; } } @@ -5797,6 +5790,20 @@ { return sequence; } + + if (!NILP (from_end)) + { + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (Fnsubstitute))->min_args; + ii < nargs; ii += 2) + { + if (EQ (args[ii], Q_count)) + { + args[ii + 1] = Qnil; + break; + } + } + ii = 0; + } } check_test = get_check_test_function (item, &test, test_not, if_, if_not, @@ -6015,16 +6022,16 @@ { Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil; Lisp_Object result = Qnil, result_tail = Qnil; - Lisp_Object object, position0, matched_count; + Lisp_Object object, position0, matched; Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0; - Elemcount ii = 0, counting = MOST_POSITIVE_FIXNUM, presenting = 0; + Elemcount ii = 0, counting = MOST_POSITIVE_FIXNUM, skipping = 0; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; struct gcpro gcpro1; PARSE_KEYWORDS (Fsubstitute, nargs, args, 9, (test, if_, if_not, test_not, key, start, end, count, - from_end), (start = Qzero, count = Qunbound)); + from_end), (start = Qzero)); CHECK_SEQUENCE (sequence); @@ -6040,30 +6047,6 @@ check_test = get_check_test_function (item, &test, test_not, if_, if_not, key, &test_not_unboundp); - if (!UNBOUNDP (count)) - { - if (!NILP (count)) - { - CHECK_INTEGER (count); - if (FIXNUMP (count)) - { - counting = XFIXNUM (count); - } -#ifdef HAVE_BIGNUM - else - { - counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? - 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM; - } -#endif - - if (counting <= 0) - { - return sequence; - } - } - } - if (!CONSP (sequence)) { position0 = position (&object, item, sequence, check_test, @@ -6081,17 +6064,62 @@ } } - matched_count = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute); - - if (ZEROP (matched_count)) + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (FIXNUMP (count)) + { + counting = XFIXNUM (count); + } +#ifdef HAVE_BIGNUM + else + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM; + } +#endif + + if (counting <= 0) + { + return sequence; + } + + /* Sigh, this is inelegant. Force count_with_tail () to ignore the count + keyword, so we get the actual number of matching elements, and can + start removing from the beginning for the from-end case. */ + if (!NILP (from_end)) + { + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (Fsubstitute))->min_args; + ii < nargs; ii += 2) + { + if (EQ (args[ii], Q_count)) + { + args[ii + 1] = Qnil; + break; + } + } + ii = 0; + } + } + + matched = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute); + + if (ZEROP (matched)) { return sequence; } if (!NILP (count) && !NILP (from_end)) { - presenting = XFIXNUM (matched_count); - presenting = presenting <= counting ? 0 : presenting - counting; + Elemcount matching = XFIXNUM (matched); + if (matching > counting) + { + /* skipping is the number of elements to be skipped before we start + substituting. It is for those cases where both :count and + :from-end are specified, and the number of elements present is + greater than that limit specified with :count. */ + skipping = matching - counting; + } } GCPRO1 (result); @@ -6100,20 +6128,32 @@ { if (EQ (tail, tailing)) { + /* No need to do check_test, we're sure that this element matches + because its cons is what count_with_tail returned as the + tail. */ + if (skipping ? encountered >= skipping : encountered < counting) + { + if (NILP (result)) + { + result = Fcons (new_, XCDR (tail)); + } + else + { + XSETCDR (result_tail, Fcons (new_, XCDR (tail))); + } + } + else + { + XSETCDR (result_tail, tail); + } + XUNGCPRO (elt); UNGCPRO; - - if (NILP (result)) - { - return XCDR (tail); - } - - XSETCDR (result_tail, XCDR (tail)); - return result; + return result; } else if (starting <= ii && ii < ending && (check_test (test, key, item, elt) == test_not_unboundp) - && (presenting ? encountered++ >= presenting + && (skipping ? encountered++ >= skipping : encountered++ < counting)) { if (NILP (result))
--- a/tests/ChangeLog Wed Feb 25 11:47:12 2015 +0000 +++ b/tests/ChangeLog Thu Mar 12 16:27:13 2015 +0000 @@ -1,3 +1,8 @@ +2015-03-04 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Add some tests for #'substitute. + 2015-02-25 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el:
--- a/tests/automated/lisp-tests.el Wed Feb 25 11:47:12 2015 +0000 +++ b/tests/automated/lisp-tests.el Thu Mar 12 16:27:13 2015 +0000 @@ -2988,6 +2988,97 @@ (Check-Error wrong-number-of-arguments (funcall list-and-four 7 8 9 10))) +;; Test #'substitute. Paul Dietz has much more comprehensive tests. + +(Assert (equal (substitute 'a 'b '(a b c d e f g)) '(a a c d e f g))) +(Assert (equal (substitute 'a 'b '(a b c d e b f g) :from-end t :count 1) + '(a b c d e a f g))) + +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :count nil))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :key nil))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :count 100))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :count 0))) + (and (equal nomodif x) y)) + '(a b c a b d a c b a e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :count 1))) + (and (equal nomodif x) y)) + '(z b c a b d a c b a e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'c x :count 1))) + (and (equal nomodif x) y)) + '(a b z a b d a c b a e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :from-end t))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :from-end t :count 1))) + (and (equal nomodif x) y)) + '(a b c a b d a c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :from-end t :count 4))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (multiple-value-list + (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif))) + (values + (loop for i from 0 to 10 + collect (substitute 'z 'a x :start i)) + (equal nomodif x)))) + '(((z b c z b d z c b z e) (a b c z b d z c b z e) + (a b c z b d z c b z e) (a b c z b d z c b z e) + (a b c a b d z c b z e) (a b c a b d z c b z e) + (a b c a b d z c b z e) (a b c a b d a c b z e) + (a b c a b d a c b z e) (a b c a b d a c b z e) + (a b c a b d a c b a e)) + t))) +(Assert (equal (multiple-value-list + (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif))) + (values + (loop for i from 0 to 10 + collect (substitute 'z 'a x :start i :end nil)) + (equal nomodif x)))) + '(((z b c z b d z c b z e) (a b c z b d z c b z e) + (a b c z b d z c b z e) (a b c z b d z c b z e) + (a b c a b d z c b z e) (a b c a b d z c b z e) + (a b c a b d z c b z e) (a b c a b d a c b z e) + (a b c a b d a c b z e) (a b c a b d a c b z e) + (a b c a b d a c b a e)) + t))) +(Assert (equal + (let* ((nomodif '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-list nomodif)) + (y (substitute 300 1 x :key #'1-))) + (and (equal nomodif x) y)) + '(1 300 3 300 6 1 300 4 1 3 300 7))) + ;; Test labels and inlining. (labels ((+ (&rest arguments)