[COMMIT] Avoid duplicate declarations, assumptions about HAVE_BIGNUM, fns.c
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1293989837 0
# Node ID 7ea8373997344348749ca8d95359010a67b75914
# Parent fbafdc1bb4d28d024d776bcbdfdea33edff96e9c
Avoid duplicate declarations, assumptions about HAVE_BIGNUM, fns.c
src/ChangeLog addition:
2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (FdeleteX, FremoveX, Fnsubstitute, Fsubstitute, syms_of_fns):
Don't repeat the declaration and DEFSYMBOL() for Qnintersection in
this file; don't assume that bignums are always available. Fixes
some of the build problems the buildbot is showing me at the
moment.
diff -r fbafdc1bb4d2 -r 7ea837399734 src/ChangeLog
--- a/src/ChangeLog Sun Jan 02 17:04:13 2011 +0000
+++ b/src/ChangeLog Sun Jan 02 17:37:17 2011 +0000
＠＠ -1,3 +1,11 ＠＠
+2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (FdeleteX, FremoveX, Fnsubstitute, Fsubstitute, syms_of_fns):
+ Don't repeat the declaration and DEFSYMBOL() for Qnintersection in
+ this file; don't assume that bignums are always available. Fixes
+ some of the build problems the buildbot is showing me at the
+ moment.
+
2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
* data.c (print_ephemeron, print_weak_list, print_weak_box):
diff -r fbafdc1bb4d2 -r 7ea837399734 src/fns.c
--- a/src/fns.c Sun Jan 02 17:04:13 2011 +0000
+++ b/src/fns.c Sun Jan 02 17:37:17 2011 +0000
＠＠ -62,7 +62,7 ＠＠
Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable;
Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch;
-Lisp_Object Qintersection, Qnintersection, Qset_difference, Qnset_difference;
+Lisp_Object Qintersection, Qset_difference, Qnset_difference;
Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qnset_difference;
Lisp_Object Qbase64_conversion_error;
＠＠ -3280,15 +3280,17 ＠＠
if (!NILP (count))
{
CHECK_INTEGER (count);
- if (BIGNUMP (count))
+ if (INTP (count))
+ {
+ counting = XINT (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
{
counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1 + EMACS_INT_MAX : EMACS_INT_MIN - 1;
}
- else
- {
- counting = XINT (count);
- }
+#endif
if (counting < 1)
{
＠＠ -3625,15 +3627,17 ＠＠
if (!NILP (count))
{
CHECK_INTEGER (count);
- if (BIGNUMP (count))
+ if (INTP (count))
+ {
+ counting = XINT (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
{
counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
}
- else
- {
- counting = XINT (count);
- }
+#endif
if (counting <= 0)
{
＠＠ -8679,15 +8683,17 ＠＠
if (!NILP (count))
{
CHECK_INTEGER (count);
- if (BIGNUMP (count))
+ if (INTP (count))
+ {
+ counting = XINT (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
{
counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
}
- else
- {
- counting = XINT (count);
- }
+#endif
if (counting <= 0)
{
＠＠ -8944,15 +8950,17 ＠＠
if (!NILP (count))
{
CHECK_INTEGER (count);
- if (BIGNUMP (count))
+ if (INTP (count))
+ {
+ counting = XINT (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
{
counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
}
- else
- {
- counting = XINT (count);
- }
+#endif
if (counting <= 0)
{
＠＠ -11722,7 +11730,6 ＠＠
DEFSYMBOL (Qset_difference);
DEFSYMBOL (Qnset_difference);
DEFSYMBOL (Qnunion);
- DEFSYMBOL (Qnintersection);
DEFSYMBOL (Qset_difference);
DEFSYMBOL (Qnset_difference);
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Avoid duplicate declarations, assumptions about HAVE_BIGNUM, fns.c
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5331:7ea837399734
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jan 02 17:37:17 2011 +0000
files: src/ChangeLog src/fns.c
description:
Avoid duplicate declarations, assumptions about HAVE_BIGNUM, fns.c
src/ChangeLog addition:
2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (FdeleteX, FremoveX, Fnsubstitute, Fsubstitute, syms_of_fns):
Don't repeat the declaration and DEFSYMBOL() for Qnintersection in
this file; don't assume that bignums are always available. Fixes
some of the build problems the buildbot is showing me at the
moment.
diff -r fbafdc1bb4d2 -r 7ea837399734 src/ChangeLog
--- a/src/ChangeLog Sun Jan 02 17:04:13 2011 +0000
+++ b/src/ChangeLog Sun Jan 02 17:37:17 2011 +0000
＠＠ -1,3 +1,11 ＠＠
+2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (FdeleteX, FremoveX, Fnsubstitute, Fsubstitute, syms_of_fns):
+ Don't repeat the declaration and DEFSYMBOL() for Qnintersection in
+ this file; don't assume that bignums are always available. Fixes
+ some of the build problems the buildbot is showing me at the
+ moment.
+
2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
* data.c (print_ephemeron, print_weak_list, print_weak_box):
diff -r fbafdc1bb4d2 -r 7ea837399734 src/fns.c
--- a/src/fns.c Sun Jan 02 17:04:13 2011 +0000
+++ b/src/fns.c Sun Jan 02 17:37:17 2011 +0000
＠＠ -62,7 +62,7 ＠＠
Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable;
Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch;
-Lisp_Object Qintersection, Qnintersection, Qset_difference, Qnset_difference;
+Lisp_Object Qintersection, Qset_difference, Qnset_difference;
Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qnset_difference;
Lisp_Object Qbase64_conversion_error;
＠＠ -3280,15 +3280,17 ＠＠
if (!NILP (count))
{
CHECK_INTEGER (count);
- if (BIGNUMP (count))
+ if (INTP (count))
+ {
+ counting = XINT (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
{
counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1 + EMACS_INT_MAX : EMACS_INT_MIN - 1;
}
- else
- {
- counting = XINT (count);
- }
+#endif
if (counting < 1)
{
＠＠ -3625,15 +3627,17 ＠＠
if (!NILP (count))
{
CHECK_INTEGER (count);
- if (BIGNUMP (count))
+ if (INTP (count))
+ {
+ counting = XINT (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
{
counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
}
- else
- {
- counting = XINT (count);
- }
+#endif
if (counting <= 0)
{
＠＠ -8679,15 +8683,17 ＠＠
if (!NILP (count))
{
CHECK_INTEGER (count);
- if (BIGNUMP (count))
+ if (INTP (count))
+ {
+ counting = XINT (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
{
counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
}
- else
- {
- counting = XINT (count);
- }
+#endif
if (counting <= 0)
{
＠＠ -8944,15 +8950,17 ＠＠
if (!NILP (count))
{
CHECK_INTEGER (count);
- if (BIGNUMP (count))
+ if (INTP (count))
+ {
+ counting = XINT (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
{
counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
}
- else
- {
- counting = XINT (count);
- }
+#endif
if (counting <= 0)
{
＠＠ -11722,7 +11730,6 ＠＠
DEFSYMBOL (Qset_difference);
DEFSYMBOL (Qnset_difference);
DEFSYMBOL (Qnunion);
- DEFSYMBOL (Qnintersection);
DEFSYMBOL (Qset_difference);
DEFSYMBOL (Qnset_difference);
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5330:fbafdc1bb4d2
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jan 02 17:04:13 2011 +0000
files: lisp/ChangeLog lisp/dialog.el lisp/list-mode.el
description:
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
lisp/ChangeLog addition:
2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
diff -r 7b391d07b334 -r fbafdc1bb4d2 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jan 02 16:18:26 2011 +0000
+++ b/lisp/ChangeLog Sun Jan 02 17:04:13 2011 +0000
＠＠ -1,3 +1,11 ＠＠
+2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * dialog.el (make-dialog-box):
+ * list-mode.el (display-completion-list):
+ These functions used to use cl-parsing-keywords; change them to
+ use defun* instead, fixing the build. (Not sure what led to me
+ not including this change in d1b17a33450b!)
+
2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (define-star-compiler-macros):
diff -r 7b391d07b334 -r fbafdc1bb4d2 lisp/dialog.el
--- a/lisp/dialog.el Sun Jan 02 16:18:26 2011 +0000
+++ b/lisp/dialog.el Sun Jan 02 17:04:13 2011 +0000
＠＠ -121,7 +121,9 ＠＠
(apply 'message-box fmt args)
(apply 'message fmt args)))
-(defun make-dialog-box (type &rest cl-keys)
+(defun* make-dialog-box (type &rest rest &key (title "XEmacs")
+ (parent (selected-frame)) modal properties autosize
+ spec &allow-other-keys)
"Pop up a dialog box.
TYPE is a symbol, the type of dialog box. Remaining arguments are
keyword-value pairs, specifying the particular characteristics of the
＠＠ -570,112 +572,100 ＠＠
(signal 'quit nil)))))
(case type
(general
- (cl-parsing-keywords
- ((:title "XEmacs")
- (:parent (selected-frame))
- :modal
- :properties
- :autosize
- :spec)
- ()
- (flet ((create-dialog-box-frame ()
- (let* ((ftop (frame-property cl-parent 'top))
- (fleft (frame-property cl-parent 'left))
- (fwidth (frame-pixel-width cl-parent))
- (fheight (frame-pixel-height cl-parent))
- (fonth (font-height (face-font 'default)))
- (fontw (font-width (face-font 'default)))
- (cl-properties (append cl-properties
- dialog-frame-plist))
- (dfheight (plist-get cl-properties 'height))
- (dfwidth (plist-get cl-properties 'width))
- (unmapped (plist-get cl-properties
- 'initially-unmapped))
- (gutter-spec cl-spec)
- (name (or (plist-get cl-properties 'name) "XEmacs"))
- (frame nil))
- (plist-remprop cl-properties 'initially-unmapped)
- ;; allow the user to just provide a glyph
- (or (glyphp cl-spec) (setq cl-spec (make-glyph cl-spec)))
- (setq gutter-spec (copy-sequence "\n"))
- (set-extent-begin-glyph (make-extent 0 1 gutter-spec)
- cl-spec)
- ;; under FVWM at least, if I don't specify the
- ;; initial position, it ends up always at (0, 0).
- ;; xwininfo doesn't tell me that there are any
- ;; program-specified position hints, so it must be
- ;; an FVWM bug. So just be smashing and position in
- ;; the center of the selected frame.
- (setq frame
- (make-frame
- (append cl-properties
- `(popup
- ,cl-parent initially-unmapped t
- menubar-visible-p nil
- has-modeline-p nil
- default-toolbar-visible-p nil
- top-gutter-visible-p t
- top-gutter-height ,(* dfheight fonth)
- top-gutter ,gutter-spec
- minibuffer none
- name ,name
- modeline-shadow-thickness 0
- vertical-scrollbar-visible-p nil
- horizontal-scrollbar-visible-p nil
- unsplittable t
- internal-border-width 8
- left ,(+ fleft (- (/ fwidth 2)
- (/ (* dfwidth
- fontw)
- 2)))
- top ,(+ ftop (- (/ fheight 2)
- (/ (* dfheight
- fonth)
- 2)))))))
- (set-face-foreground 'modeline [default foreground] frame)
- (set-face-background 'modeline [default background] frame)
- ;; resize before mapping
- (when cl-autosize
- (set-frame-displayable-pixel-size
- frame
- (image-instance-width
- (glyph-image-instance cl-spec
- (frame-selected-window frame)))
- (image-instance-height
- (glyph-image-instance cl-spec
- (frame-selected-window frame)))))
- ;; somehow, even though the resizing is supposed
- ;; to be while the frame is not visible, a
- ;; visible resize is perceptible
- (unless unmapped (make-frame-visible frame))
- (let ((newbuf (generate-new-buffer " *dialog box*")))
- (set-buffer-dedicated-frame newbuf frame)
- (set-frame-property frame 'dialog-box-buffer newbuf)
- (set-window-buffer (frame-root-window frame) newbuf)
- (with-current-buffer newbuf
- (set (make-local-variable 'frame-title-format)
- cl-title)
- (add-local-hook 'delete-frame-hook
- #'(lambda (frame)
- (kill-buffer
- (frame-property
- frame
- 'dialog-box-buffer))))))
- frame)))
- (if cl-modal
- (dialog-box-modal-loop '(create-dialog-box-frame))
- (create-dialog-box-frame)))))
+ (flet ((create-dialog-box-frame ()
+ (let* ((ftop (frame-property parent 'top))
+ (fleft (frame-property parent 'left))
+ (fwidth (frame-pixel-width parent))
+ (fheight (frame-pixel-height parent))
+ (fonth (font-height (face-font 'default)))
+ (fontw (font-width (face-font 'default)))
+ (properties (append properties
+ dialog-frame-plist))
+ (dfheight (plist-get properties 'height))
+ (dfwidth (plist-get properties 'width))
+ (unmapped (plist-get properties
+ 'initially-unmapped))
+ (gutter-spec spec)
+ (name (or (plist-get properties 'name) "XEmacs"))
+ (frame nil))
+ (plist-remprop properties 'initially-unmapped)
+ ;; allow the user to just provide a glyph
+ (or (glyphp spec) (setq spec (make-glyph spec)))
+ (setq gutter-spec (copy-sequence "\n"))
+ (set-extent-begin-glyph (make-extent 0 1 gutter-spec)
+ spec)
+ ;; under FVWM at least, if I don't specify the
+ ;; initial position, it ends up always at (0, 0).
+ ;; xwininfo doesn't tell me that there are any
+ ;; program-specified position hints, so it must be
+ ;; an FVWM bug. So just be smashing and position in
+ ;; the center of the selected frame.
+ (setq frame
+ (make-frame
+ (append properties
+ `(popup
+ ,parent initially-unmapped t
+ menubar-visible-p nil
+ has-modeline-p nil
+ default-toolbar-visible-p nil
+ top-gutter-visible-p t
+ top-gutter-height ,(* dfheight fonth)
+ top-gutter ,gutter-spec
+ minibuffer none
+ name ,name
+ modeline-shadow-thickness 0
+ vertical-scrollbar-visible-p nil
+ horizontal-scrollbar-visible-p nil
+ unsplittable t
+ internal-border-width 8
+ left ,(+ fleft (- (/ fwidth 2)
+ (/ (* dfwidth
+ fontw)
+ 2)))
+ top ,(+ ftop (- (/ fheight 2)
+ (/ (* dfheight
+ fonth)
+ 2)))))))
+ (set-face-foreground 'modeline [default foreground] frame)
+ (set-face-background 'modeline [default background] frame)
+ ;; resize before mapping
+ (when autosize
+ (set-frame-displayable-pixel-size
+ frame
+ (image-instance-width
+ (glyph-image-instance spec
+ (frame-selected-window frame)))
+ (image-instance-height
+ (glyph-image-instance spec
+ (frame-selected-window frame)))))
+ ;; somehow, even though the resizing is supposed
+ ;; to be while the frame is not visible, a
+ ;; visible resize is perceptible
+ (unless unmapped (make-frame-visible frame))
+ (let ((newbuf (generate-new-buffer " *dialog box*")))
+ (set-buffer-dedicated-frame newbuf frame)
+ (set-frame-property frame 'dialog-box-buffer newbuf)
+ (set-window-buffer (frame-root-window frame) newbuf)
+ (with-current-buffer newbuf
+ (set (make-local-variable 'frame-title-format)
+ title)
+ (add-local-hook 'delete-frame-hook
+ #'(lambda (frame)
+ (kill-buffer
+ (frame-property
+ frame
+ 'dialog-box-buffer))))))
+ frame)))
+ (if modal
+ (dialog-box-modal-loop '(create-dialog-box-frame))
+ (create-dialog-box-frame))))
(question
- (cl-parsing-keywords
- ((:modal nil))
- t
- (remf cl-keys :modal)
- (if cl-modal
- (dialog-box-modal-loop `(make-dialog-box-internal ',type
- ',cl-keys))
- (make-dialog-box-internal type cl-keys))))
- (t
- (make-dialog-box-internal type cl-keys)))))
+ (remf rest :modal)
+ (if modal
+ (dialog-box-modal-loop `(make-dialog-box-internal ',type ',rest))
+ (make-dialog-box-internal type rest))))
+ (t
+ (make-dialog-box-internal type rest))))
(defun dialog-box-finish (result)
"Exit a modal dialog box, returning RESULT.
diff -r 7b391d07b334 -r fbafdc1bb4d2 lisp/list-mode.el
--- a/lisp/list-mode.el Sun Jan 02 16:18:26 2011 +0000
+++ b/lisp/list-mode.el Sun Jan 02 17:04:13 2011 +0000
＠＠ -276,7 +276,11 ＠＠
This string is inserted at the beginning of the buffer.
See `display-completion-list'.")
-(defun display-completion-list (completions &rest cl-keys)
+(defun* display-completion-list (completions &key user-data reference-buffer
+ (activate-callback 'default-choose-completion)
+ (help-string completion-default-help-string)
+ (completion-string "Possible completions are:")
+ window-width window-height)
"Display the list of completions, COMPLETIONS, using `standard-output'.
Each element may be just a symbol or string or may be a list of two
strings to be printed as if concatenated.
＠＠ -310,158 +314,148 ＠＠
It can find the completion buffer in `standard-output'.
If `completion-highlight-first-word-only' is non-nil, then only the start
of the string is highlighted."
- ;; #### I18N3 should set standard-output to be (temporarily)
- ;; output-translating.
- (cl-parsing-keywords
- ((:activate-callback 'default-choose-completion)
-:user-data
-:reference-buffer
- (:help-string completion-default-help-string)
- (:completion-string "Possible completions are:")
-:window-width
-:window-height)
- ()
- (let ((old-buffer (current-buffer))
- (bufferp (bufferp standard-output)))
- (if bufferp
- (set-buffer standard-output))
- (if (null completions)
- (princ (gettext
- "There are no possible completions of what you have typed."))
- (let ((win-width
- (or cl-window-width
- (if bufferp
- ;; We have to use last-nonminibuf-frame here
- ;; and not selected-frame because if a
- ;; minibuffer-only frame is being used it will
- ;; be the selected-frame at the point this is
- ;; run. We keep the selected-frame call around
- ;; just in case.
- (window-width (get-lru-window (last-nonminibuf-frame)))
- 80))))
- (let ((count 0)
- (max-width 0)
- old-max-width)
- ;; Find longest completion
- (let ((tail completions))
- (while tail
- (let* ((elt (car tail))
- (len (cond ((stringp elt)
- (length elt))
- ((and (consp elt)
- (stringp (car elt))
- (stringp (car (cdr elt))))
- (+ (length (car elt))
- (length (car (cdr elt)))))
- (t
- (signal 'wrong-type-argument
- (list 'stringp elt))))))
- (if (> len max-width)
- (setq max-width len))
- (setq count (1+ count)
- tail (cdr tail)))))
+ ;; #### I18N3 should set standard-output to be (temporarily)
+ ;; output-translating.
+ (let ((old-buffer (current-buffer)) (bufferp (bufferp standard-output)))
+ (if bufferp
+ (set-buffer standard-output))
+ (if (null completions)
+ (princ (gettext
+ "There are no possible completions of what you have typed."))
+ (let ((win-width
+ (or window-width
+ (if bufferp
+ ;; We have to use last-nonminibuf-frame here
+ ;; and not selected-frame because if a
+ ;; minibuffer-only frame is being used it will
+ ;; be the selected-frame at the point this is
+ ;; run. We keep the selected-frame call around
+ ;; just in case.
+ (window-width (get-lru-window (last-nonminibuf-frame)))
+ 80))))
+ (let ((count 0)
+ (max-width 0)
+ old-max-width)
+ ;; Find longest completion
+ (let ((tail completions))
+ (while tail
+ (let* ((elt (car tail))
+ (len (cond ((stringp elt)
+ (length elt))
+ ((and (consp elt)
+ (stringp (car elt))
+ (stringp (car (cdr elt))))
+ (+ (length (car elt))
+ (length (car (cdr elt)))))
+ (t
+ (signal 'wrong-type-argument
+ (list 'stringp elt))))))
+ (if (> len max-width)
+ (setq max-width len))
+ (setq count (1+ count)
+ tail (cdr tail)))))
- (setq max-width (+ 2 max-width)) ; at least two chars between cols
- (setq old-max-width max-width)
- (let ((rows (let ((cols (min (/ win-width max-width) count)))
- (if (<= cols 1)
- count
- (progn
- ;; re-space the columns
- (setq max-width (/ win-width cols))
- (if (/= (% count cols) 0) ; want ceiling...
- (1+ (/ count cols))
- (/ count cols)))))))
- (when
- (and cl-window-height
- (> rows cl-window-height))
- (setq max-width old-max-width)
- (setq rows cl-window-height))
- (when (and (stringp cl-completion-string)
- (> (length cl-completion-string) 0))
- (princ (gettext cl-completion-string))
- (terpri))
- (let ((tail completions)
- (r 0)
- (regexp-string
- (if (eq t
- completion-highlight-first-word-only)
- "[ \t]"
- completion-highlight-first-word-only)))
- (while (< r rows)
- (and (> r 0) (terpri))
- (let ((indent 0)
- (column 0)
- (tail2 tail))
- (while tail2
- (let ((elt (car tail2)))
- (if (/= indent 0)
- (if bufferp
- (indent-to indent 2)
- (while (progn (write-char ?\ )
- (setq column (1+ column))
- (< column indent)))))
- (setq indent (+ indent max-width))
- (let ((start (point))
- end)
- ;; Frob some mousable extents in there too!
- (if (consp elt)
- (progn
- (princ (car elt))
- (princ (car (cdr elt)))
- (or bufferp
- (setq column
- (+ column
- (length (car elt))
- (length (car (cdr elt)))))))
- (progn
- (princ elt)
- (or bufferp
- (setq column (+ column (length
- elt))))))
- (add-list-mode-item
- start
- (progn
- (setq end (point))
- (or
- (and completion-highlight-first-word-only
- (goto-char start)
- (re-search-forward regexp-string end t)
- (match-beginning 0))
- end))
- nil cl-activate-callback cl-user-data)
- (goto-char end)))
- (setq tail2 (nthcdr rows tail2)))
- (setq tail (cdr tail)
- r (1+ r)))))))))
- (if bufferp
- (set-buffer old-buffer)))
- (save-excursion
- (let ((mainbuf (or cl-reference-buffer (current-buffer))))
- (set-buffer standard-output)
- (completion-list-mode)
- (make-local-variable 'completion-reference-buffer)
- (setq completion-reference-buffer mainbuf)
+ (setq max-width (+ 2 max-width)) ; at least two chars between cols
+ (setq old-max-width max-width)
+ (let ((rows (let ((cols (min (/ win-width max-width) count)))
+ (if (<= cols 1)
+ count
+ (progn
+ ;; re-space the columns
+ (setq max-width (/ win-width cols))
+ (if (/= (% count cols) 0) ; want ceiling...
+ (1+ (/ count cols))
+ (/ count cols)))))))
+ (when
+ (and window-height
+ (> rows window-height))
+ (setq max-width old-max-width)
+ (setq rows window-height))
+ (when (and (stringp completion-string)
+ (> (length completion-string) 0))
+ (princ (gettext completion-string))
+ (terpri))
+ (let ((tail completions)
+ (r 0)
+ (regexp-string
+ (if (eq t
+ completion-highlight-first-word-only)
+ "[ \t]"
+ completion-highlight-first-word-only)))
+ (while (< r rows)
+ (and (> r 0) (terpri))
+ (let ((indent 0)
+ (column 0)
+ (tail2 tail))
+ (while tail2
+ (let ((elt (car tail2)))
+ (if (/= indent 0)
+ (if bufferp
+ (indent-to indent 2)
+ (while (progn (write-char ?\ )
+ (setq column (1+ column))
+ (< column indent)))))
+ (setq indent (+ indent max-width))
+ (let ((start (point))
+ end)
+ ;; Frob some mousable extents in there too!
+ (if (consp elt)
+ (progn
+ (princ (car elt))
+ (princ (car (cdr elt)))
+ (or bufferp
+ (setq column
+ (+ column
+ (length (car elt))
+ (length (car (cdr elt)))))))
+ (progn
+ (princ elt)
+ (or bufferp
+ (setq column (+ column (length
+ elt))))))
+ (add-list-mode-item
+ start
+ (progn
+ (setq end (point))
+ (or
+ (and completion-highlight-first-word-only
+ (goto-char start)
+ (re-search-forward regexp-string end t)
+ (match-beginning 0))
+ end))
+ nil activate-callback user-data)
+ (goto-char end)))
+ (setq tail2 (nthcdr rows tail2)))
+ (setq tail (cdr tail)
+ r (1+ r)))))))))
+ (if bufferp
+ (set-buffer old-buffer)))
+ (save-excursion
+ (let ((mainbuf (or reference-buffer (current-buffer))))
+ (set-buffer standard-output)
+ (completion-list-mode)
+ (make-local-variable 'completion-reference-buffer)
+ (setq completion-reference-buffer mainbuf)
;;; The value 0 is right in most cases, but not for file name completion.
;;; so this has to be turned off.
-;;; (setq completion-base-size 0)
- (goto-char (point-min))
- (let ((buffer-read-only nil))
- (insert (eval cl-help-string)))
- ;; unnecessary FSFmacs crock
- ;;(forward-line 1)
- ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t)
- ;; (let ((beg (match-beginning 0))
- ;; (end (point)))
- ;; (if completion-fixup-function
- ;; (funcall completion-fixup-function))
- ;; (put-text-property beg (point) 'mouse-face 'highlight)
- ;; (put-text-property beg (point) 'list-mode-item t)
- ;; (goto-char end)))))
- ))
- (save-excursion
- (set-buffer standard-output)
- (run-hooks 'completion-setup-hook))))
+;;; (setq completion-base-size 0)
+ (goto-char (point-min))
+ (let ((buffer-read-only nil))
+ (insert (eval help-string)))
+ ;; unnecessary FSFmacs crock
+ ;;(forward-line 1)
+ ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t)
+ ;; (let ((beg (match-beginning 0))
+ ;; (end (point)))
+ ;; (if completion-fixup-function
+ ;; (funcall completion-fixup-function))
+ ;; (put-text-property beg (point) 'mouse-face 'highlight)
+ ;; (put-text-property beg (point) 'list-mode-item t)
+ ;; (goto-char end)))))
+ ))
+ (save-excursion
+ (set-buffer standard-output)
+ (run-hooks 'completion-setup-hook)))
(defvar completion-display-completion-list-function 'display-completion-list
"Function to set up the list of completions in the completion buffer.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Tweak a few compiler macros for functions in cl-seq.el.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1293985106 0
# Node ID 7b391d07b3340003dd97bb04c1658e71b63baef1
# Parent dae3d95cf3197464547e5cea66196fe44bf188ea
Tweak a few compiler macros for functions in cl-seq.el.
lisp/ChangeLog addition:
2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
tests/ChangeLog addition:
2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (test-fun): Test member*, assoc*,
rassoc*, delete* here too.
diff -r dae3d95cf319 -r 7b391d07b334 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jan 02 02:32:59 2011 +0000
+++ b/lisp/ChangeLog Sun Jan 02 16:18:26 2011 +0000
＠＠ -1,3 +1,13 ＠＠
+2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (define-star-compiler-macros):
+ Make sure the form has ITEM and LIST specified before attempting
+ to change to calls with explicit tests; necessary for some tests
+ in lisp-tests.el to compile correctly.
+ (stable-union, stable-intersection): Add compiler macros for these
+ functions, in the same way we do for most of the other functions
+ in cl-seq.el.
+
2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
diff -r dae3d95cf319 -r 7b391d07b334 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jan 02 02:32:59 2011 +0000
+++ b/lisp/cl-macs.el Sun Jan 02 16:18:26 2011 +0000
＠＠ -3283,51 +3283,53 ＠＠
(mapcar
(function*
(lambda ((star-function eq-function equal-function))
- `(define-compiler-macro ,star-function (&whole form item list
- &rest keys)
- (condition-case nil
- (symbol-macrolet ((not-constant '#:not-constant))
- (let* ((test-expr (plist-get keys :test ''eql))
- (test (cl-const-expr-val test-expr not-constant))
- (item-val (cl-const-expr-val item not-constant))
- (list-val (cl-const-expr-val list not-constant)))
- (if (and keys
- (not (and (eq :test (car keys))
- (eql 2 (length keys)))))
- form
- (cond ((eq test 'eq) `(,',eq-function ,item ,list))
- ((eq test 'equal)
- `(,',equal-function ,item ,list))
- ((and (eq test 'eql)
- (not (eq not-constant item-val)))
- (if (cl-non-fixnum-number-p item-val)
- `(,',equal-function ,item ,list)
- `(,',eq-function ,item ,list)))
- ((and (eq test 'eql) (not (eq not-constant
- list-val)))
- (if (some 'cl-non-fixnum-number-p list-val)
- `(,',equal-function ,item ,list)
- ;; This compiler macro used to limit calls
- ;; to ,,eq-function to lists where all
- ;; elements were either fixnums or
- ;; symbols. There's no
- ;; reason to do this.
- `(,',eq-function ,item ,list)))
- ;; This is a hilariously specific case; see
- ;; add-to-list in subr.el.
- ((and (eq test not-constant)
- (eq 'or (car-safe test-expr))
- (eql 3 (length test-expr))
- (every #'cl-safe-expr-p (cdr form))
- `(if ,(second test-expr)
- (,',star-function ,item ,list :test
- ,(second test-expr))
- (,',star-function
- ,item ,list :test ,(third test-expr)))))
- (t form)))))
- ;; No need to warn about a malformed property list,
- ;; #'byte-compile-normal-call will do that for us.
- (malformed-property-list form)))))
+ `(define-compiler-macro ,star-function (&whole form &rest keys)
+ (if (< (length form) 3)
+ form
+ (condition-case nil
+ (symbol-macrolet ((not-constant '#:not-constant))
+ (let* ((item (pop keys))
+ (list (pop keys))
+ (test-expr (plist-get keys :test ''eql))
+ (test (cl-const-expr-val test-expr not-constant))
+ (item-val (cl-const-expr-val item not-constant))
+ (list-val (cl-const-expr-val list not-constant)))
+ (if (and keys (not (and (eq :test (car keys))
+ (eql 2 (length keys)))))
+ form
+ (cond ((eq test 'eq) `(,',eq-function ,item ,list))
+ ((eq test 'equal)
+ `(,',equal-function ,item ,list))
+ ((and (eq test 'eql)
+ (not (eq not-constant item-val)))
+ (if (cl-non-fixnum-number-p item-val)
+ `(,',equal-function ,item ,list)
+ `(,',eq-function ,item ,list)))
+ ((and (eq test 'eql) (not (eq not-constant
+ list-val)))
+ (if (some 'cl-non-fixnum-number-p list-val)
+ `(,',equal-function ,item ,list)
+ ;; This compiler macro used to limit
+ ;; calls to ,,eq-function to lists where
+ ;; all elements were either fixnums or
+ ;; symbols. There's no reason to do this.
+ `(,',eq-function ,item ,list)))
+ ;; This is a hilariously specific case; see
+ ;; add-to-list in subr.el.
+ ((and (eq test not-constant)
+ (eq 'or (car-safe test-expr))
+ (eql 3 (length test-expr))
+ (every #'cl-safe-expr-p (cdr form))
+ `(if ,(second test-expr)
+ (,',star-function ,item ,list :test
+ ,(second test-expr))
+ (,',star-function
+ ,item ,list :test
+ ,(third test-expr)))))
+ (t form)))))
+ ;; No need to warn about a malformed property list,
+ ;; #'byte-compile-normal-call will do that for us.
+ (malformed-property-list form))))))
macros))))
(define-star-compiler-macros
(member* memq member)
＠＠ -3736,6 +3738,16 ＠＠
(the string ,string) :test #'eq)
form))
+(define-compiler-macro stable-union (&whole form &rest cl-keys)
+ (if (> (length form) 2)
+ (list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys)
+ form))
+
+(define-compiler-macro stable-intersection (&whole form &rest cl-keys)
+ (if (> (length form) 2)
+ (list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys)
+ form))
+
(map nil
#'(lambda (function)
;; There are byte codes for the two-argument versions of these
diff -r dae3d95cf319 -r 7b391d07b334 tests/ChangeLog
--- a/tests/ChangeLog Sun Jan 02 02:32:59 2011 +0000
+++ b/tests/ChangeLog Sun Jan 02 16:18:26 2011 +0000
＠＠ -1,3 +1,8 ＠＠
+2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el (test-fun): Test member*, assoc*,
+ rassoc*, delete* here too.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (wrong-type-argument): Add a missing
diff -r dae3d95cf319 -r 7b391d07b334 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Jan 02 02:32:59 2011 +0000
+++ b/tests/automated/lisp-tests.el Sun Jan 02 16:18:26 2011 +0000
＠＠ -798,12 +798,12 ＠＠
collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
(test-funs (&rest funs) `(progn ,＠(loop for fun in funs collect `(test-fun ,fun)))))
- (test-funs member old-member
+ (test-funs member* member old-member
memq old-memq
- assoc old-assoc
- rassoc old-rassoc
+ assoc* assoc old-assoc
+ rassoc* rassoc old-rassoc
rassq old-rassq
- delete old-delete
+ delete* delete old-delete
delq old-delq
remassoc remassq remrassoc remrassq))
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Tweak a few compiler macros for functions in cl-seq.el.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5329:7b391d07b334
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jan 02 16:18:26 2011 +0000
files: lisp/ChangeLog lisp/cl-macs.el tests/ChangeLog tests/automated/lisp-tests.el
description:
Tweak a few compiler macros for functions in cl-seq.el.
lisp/ChangeLog addition:
2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
tests/ChangeLog addition:
2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (test-fun): Test member*, assoc*,
rassoc*, delete* here too.
diff -r dae3d95cf319 -r 7b391d07b334 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jan 02 02:32:59 2011 +0000
+++ b/lisp/ChangeLog Sun Jan 02 16:18:26 2011 +0000
＠＠ -1,3 +1,13 ＠＠
+2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (define-star-compiler-macros):
+ Make sure the form has ITEM and LIST specified before attempting
+ to change to calls with explicit tests; necessary for some tests
+ in lisp-tests.el to compile correctly.
+ (stable-union, stable-intersection): Add compiler macros for these
+ functions, in the same way we do for most of the other functions
+ in cl-seq.el.
+
2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
diff -r dae3d95cf319 -r 7b391d07b334 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jan 02 02:32:59 2011 +0000
+++ b/lisp/cl-macs.el Sun Jan 02 16:18:26 2011 +0000
＠＠ -3283,51 +3283,53 ＠＠
(mapcar
(function*
(lambda ((star-function eq-function equal-function))
- `(define-compiler-macro ,star-function (&whole form item list
- &rest keys)
- (condition-case nil
- (symbol-macrolet ((not-constant '#:not-constant))
- (let* ((test-expr (plist-get keys :test ''eql))
- (test (cl-const-expr-val test-expr not-constant))
- (item-val (cl-const-expr-val item not-constant))
- (list-val (cl-const-expr-val list not-constant)))
- (if (and keys
- (not (and (eq :test (car keys))
- (eql 2 (length keys)))))
- form
- (cond ((eq test 'eq) `(,',eq-function ,item ,list))
- ((eq test 'equal)
- `(,',equal-function ,item ,list))
- ((and (eq test 'eql)
- (not (eq not-constant item-val)))
- (if (cl-non-fixnum-number-p item-val)
- `(,',equal-function ,item ,list)
- `(,',eq-function ,item ,list)))
- ((and (eq test 'eql) (not (eq not-constant
- list-val)))
- (if (some 'cl-non-fixnum-number-p list-val)
- `(,',equal-function ,item ,list)
- ;; This compiler macro used to limit calls
- ;; to ,,eq-function to lists where all
- ;; elements were either fixnums or
- ;; symbols. There's no
- ;; reason to do this.
- `(,',eq-function ,item ,list)))
- ;; This is a hilariously specific case; see
- ;; add-to-list in subr.el.
- ((and (eq test not-constant)
- (eq 'or (car-safe test-expr))
- (eql 3 (length test-expr))
- (every #'cl-safe-expr-p (cdr form))
- `(if ,(second test-expr)
- (,',star-function ,item ,list :test
- ,(second test-expr))
- (,',star-function
- ,item ,list :test ,(third test-expr)))))
- (t form)))))
- ;; No need to warn about a malformed property list,
- ;; #'byte-compile-normal-call will do that for us.
- (malformed-property-list form)))))
+ `(define-compiler-macro ,star-function (&whole form &rest keys)
+ (if (< (length form) 3)
+ form
+ (condition-case nil
+ (symbol-macrolet ((not-constant '#:not-constant))
+ (let* ((item (pop keys))
+ (list (pop keys))
+ (test-expr (plist-get keys :test ''eql))
+ (test (cl-const-expr-val test-expr not-constant))
+ (item-val (cl-const-expr-val item not-constant))
+ (list-val (cl-const-expr-val list not-constant)))
+ (if (and keys (not (and (eq :test (car keys))
+ (eql 2 (length keys)))))
+ form
+ (cond ((eq test 'eq) `(,',eq-function ,item ,list))
+ ((eq test 'equal)
+ `(,',equal-function ,item ,list))
+ ((and (eq test 'eql)
+ (not (eq not-constant item-val)))
+ (if (cl-non-fixnum-number-p item-val)
+ `(,',equal-function ,item ,list)
+ `(,',eq-function ,item ,list)))
+ ((and (eq test 'eql) (not (eq not-constant
+ list-val)))
+ (if (some 'cl-non-fixnum-number-p list-val)
+ `(,',equal-function ,item ,list)
+ ;; This compiler macro used to limit
+ ;; calls to ,,eq-function to lists where
+ ;; all elements were either fixnums or
+ ;; symbols. There's no reason to do this.
+ `(,',eq-function ,item ,list)))
+ ;; This is a hilariously specific case; see
+ ;; add-to-list in subr.el.
+ ((and (eq test not-constant)
+ (eq 'or (car-safe test-expr))
+ (eql 3 (length test-expr))
+ (every #'cl-safe-expr-p (cdr form))
+ `(if ,(second test-expr)
+ (,',star-function ,item ,list :test
+ ,(second test-expr))
+ (,',star-function
+ ,item ,list :test
+ ,(third test-expr)))))
+ (t form)))))
+ ;; No need to warn about a malformed property list,
+ ;; #'byte-compile-normal-call will do that for us.
+ (malformed-property-list form))))))
macros))))
(define-star-compiler-macros
(member* memq member)
＠＠ -3736,6 +3738,16 ＠＠
(the string ,string) :test #'eq)
form))
+(define-compiler-macro stable-union (&whole form &rest cl-keys)
+ (if (> (length form) 2)
+ (list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys)
+ form))
+
+(define-compiler-macro stable-intersection (&whole form &rest cl-keys)
+ (if (> (length form) 2)
+ (list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys)
+ form))
+
(map nil
#'(lambda (function)
;; There are byte codes for the two-argument versions of these
diff -r dae3d95cf319 -r 7b391d07b334 tests/ChangeLog
--- a/tests/ChangeLog Sun Jan 02 02:32:59 2011 +0000
+++ b/tests/ChangeLog Sun Jan 02 16:18:26 2011 +0000
＠＠ -1,3 +1,8 ＠＠
+2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el (test-fun): Test member*, assoc*,
+ rassoc*, delete* here too.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (wrong-type-argument): Add a missing
diff -r dae3d95cf319 -r 7b391d07b334 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Jan 02 02:32:59 2011 +0000
+++ b/tests/automated/lisp-tests.el Sun Jan 02 16:18:26 2011 +0000
＠＠ -798,12 +798,12 ＠＠
collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
(test-funs (&rest funs) `(progn ,＠(loop for fun in funs collect `(test-fun ,fun)))))
- (test-funs member old-member
+ (test-funs member* member old-member
memq old-memq
- assoc old-assoc
- rassoc old-rassoc
+ assoc* assoc old-assoc
+ rassoc* rassoc old-rassoc
rassq old-rassq
- delete old-delete
+ delete* delete old-delete
delq old-delq
remassoc remassq remrassoc remrassq))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[PATCH] Move the heavy lifting from cl-seq.el to C.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
This hasn’t been committed yet, I’m going to give it a few days. It makes
fns.c immense, and I think it’s reasonable to split off various functions in
it into a sequence.c (for the more general functions) and a list.c (for
those specifically limited to lists). But that’s best done after the below
goes in.
I also plan to write something similar to get_check_match_function for
#'sort* and #'merge; it’s analagous to a bytecode, it’s easy to avoid
funcalls for the common comparison operations, in particular #'< and
#'string-lessp.
I’ve compiled with and without --with-xemacs-compiler=g++-4.0,
--with-union-type; I don’t get any warnings about declarations interleaving
with statements, and I caught a couple of incompatibilities with the union
build. There may still be incompatibilities, and I will be watching the
buildbots once I commit it.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1293674392 0
# Node ID d1b17a33450bbfaa57820405a9dc556eda146582
# Parent f87bb35a6b94954e154e89f9138c6dd6487377cc
Move the heavy lifting from cl-seq.el to C.
src/ChangeLog addition:
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
Move the heavy lifting from cl-seq.el to C, finally making those
functions first-class XEmacs citizens, with circularity checking,
built-in support for tests other than #'eql, and as much
compatibility with current Common Lisp as Paul Dietz' tests require.
* fns.c (check_eq_nokey, check_eq_key, check_eql_nokey)
(check_eql_key, check_equal_nokey, check_equal_key)
(check_equalp_nokey, check_equalp_key, check_string_match_nokey)
(check_string_match_key, check_other_nokey, check_other_key)
(check_if_nokey, check_if_key, check_match_eq_key)
(check_match_eql_key, check_match_equal_key)
(check_match_equalp_key, check_match_other_key): New. These are
basically to provide function pointers to be used by Lisp
functions that take TEST, TEST-NOT and KEY arguments.
(get_check_match_function_1, get_check_test_function)
(get_check_match_function): These functions work out which of the
previous list of functions to use, given the keywords supplied by
the user.
(count_with_tail): New. This is the bones of #'count.
(list_count_from_end, string_count_from_end): Utility functions
for #'count.
(Fcount): New, moved from cl-seq.el.
(list_position_cons_before): New. The implementation of #'member*,
and important in implementing various other functions.
(FmemberX, Fadjoin, FassocX, FrassocX, Fposition, Ffind)
(FdeleteX, FremoveX, Fdelete_duplicates, Fremove_duplicates)
(Fnsubstitute, Fsubstitute, Fsublis, Fnsublis, Fsubst, Fnsubst)
(Ftree_equal, Fmismatch, Fsearch, Fintersection, Fnintersection)
(Fsubsetp, Fset_difference, Fnset_difference, Fnunion, Funion)
(Fset_exclusive_or, Fnset_exclusive_or): New, moved here from
cl-seq.el.
(position): New. The implementation of #'find and #'position.
(list_delete_duplicates_from_end, subst, sublis, nsublis)
(tree_equal, mismatch_from_end, mismatch_list_list)
(mismatch_list_string, mismatch_list_array)
(mismatch_string_array, mismatch_string_string)
(mismatch_array_array, get_mismatch_func): Helper C functions for
the Lisp-visible functions.
(venn, nvenn): New. The implementation of the main Lisp functions that
treat lists as sets.
lisp/ChangeLog addition:
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
diff -r f87bb35a6b94 -r d1b17a33450b lisp/ChangeLog
--- a/lisp/ChangeLog Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/ChangeLog Thu Dec 30 01:59:52 2010 +0000
＠＠ -1,3 +1,18 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-seq.el:
+ Move the heavy lifting from this file to C. Dump the
+ cl-parsing-keywords macro, but don't use defun* for the functions
+ we define that do take keywords, dynamic scope lossage makes that
+ not practical.
+ * subr.el (sort, fillarray): Move these aliases here.
+ (map-plist): #'nsublis is now built-in, but at this point #'eql
+ isn't necessarily available as a test; use #'eq.
+ * obsolete.el (cl-delete-duplicates): Make this available for old
+ compiler macros and old code.
+ (memql): Document that this is equivalent to #'member*, and worse.
+ * cl.el (adjoin, subst): Removed. These are in C.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
diff -r f87bb35a6b94 -r d1b17a33450b lisp/cl-seq.el
--- a/lisp/cl-seq.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/cl-seq.el Thu Dec 30 01:59:52 2010 +0000
＠＠ -47,541 +47,189 ＠＠
;; See cl.el for Change Log.
-
;;; Code:
-;;; Keyword parsing. This is special-cased here so that we can compile
-;;; this file independent from cl-macs.
+;; XEmacs; all the heavy lifting of this file is now in C. There's no need
+;; for the cl-parsing-keywords macro. We could use defun* for the
+;; keyword-parsing code, which would avoid the necessity of the arguments:
+;; () lists in the docstrings, but that often breaks because of dynamic
+;; scope (e.g. a variable called start bound in this file and one in a
+;; user-supplied test predicate may well interfere with each other).
-(defmacro cl-parsing-keywords (kwords other-keys &rest body)
- "Helper macro for functions with keyword arguments.
-This is a temporary solution, until keyword arguments are natively supported.
-Declare your function ending with (... &rest cl-keys), then wrap the
-function body in a call to `cl-parsing-keywords'.
+;; XEmacs change: these two are in subr.el in GNU Emacs.
+(defun remove (cl-item cl-seq)
+ "Remove all occurrences of ITEM in SEQUENCE, testing with `equal'.
-KWORDS is a list of keyword definitions. Each definition should be
-either a keyword or a list (KEYWORD DEFAULT-VALUE). In the former case,
-the default value is nil. The keywords are available in BODY as the name
-of the keyword, minus its initial colon and prepended with `cl-'.
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE.
+Also see: `remove*', `delete', `delete*'
-OTHER-KEYS specifies other keywords that are accepted but ignored. It
-is either the value 't' (ignore all other keys, equivalent to the
-&allow-other-keys argument declaration in Common Lisp) or a list in the
-same format as KWORDS. If keywords are given that are not in KWORDS
-and not allowed by OTHER-KEYS, an error will normally be signalled; but
-the caller can override this by specifying a non-nil value for the
-keyword:allow-other-keys (which defaults to t)."
- (cons
- 'let*
- (cons (mapcar
- (function
- (lambda (x)
- (let* ((var (if (consp x) (car x) x))
- (mem (list 'car (list 'cdr (list 'memq (list 'quote var)
- 'cl-keys)))))
- (if (eq var :test-not)
- (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
- (if (eq var :if-not)
- (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
- (list (intern
- (format "cl-%s" (substring (symbol-name var) 1)))
- (if (consp x) (list 'or mem (car (cdr x))) mem)))))
- kwords)
- (append
- (and (not (eq other-keys t))
- (list
- (list 'let '((cl-keys-temp cl-keys))
- (list 'while 'cl-keys-temp
- (list 'or (list 'memq '(car cl-keys-temp)
- (list 'quote
- (mapcar
- (function
- (lambda (x)
- (if (consp x)
- (car x) x)))
- (append kwords
- other-keys))))
- '(car (cdr (memq (quote :allow-other-keys)
- cl-keys)))
- '(error 'invalid-keyword-argument
- (car cl-keys-temp)))
- '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
- body))))
-(put 'cl-parsing-keywords 'lisp-indent-function 2)
-(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
+arguments: (ITEM SEQUENCE)"
+ (remove* cl-item cl-seq :test #'equal))
-(defmacro cl-check-key (x)
- (list 'if 'cl-key (list 'funcall 'cl-key x) x))
+(defun remq (cl-item cl-seq)
+ "Remove all occurrences of ITEM in SEQUENCE, comparing with `eq'.
-(defmacro cl-check-test-nokey (item x)
- (list 'cond
- (list 'cl-test
- (list 'eq (list 'not (list 'funcall 'cl-test item x))
- 'cl-test-not))
- (list 'cl-if
- (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
- (list 't (list 'if (list 'numberp item)
- (list 'equal item x) (list 'eq item x)))))
+This is a non-destructive function; it makes a copy of SEQUENCE to avoid
+corrupting the original LIST. See also the more general `remove*'.
-(defmacro cl-check-test (item x)
- (list 'cl-check-test-nokey item (list 'cl-check-key x)))
+arguments: (ITEM SEQUENCE)"
+ (remove* cl-item cl-seq :test #'eq))
-(defmacro cl-check-match (x y)
- (setq x (list 'cl-check-key x) y (list 'cl-check-key y))
- (list 'if 'cl-test
- (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
- (list 'if (list 'numberp x)
- (list 'equal x y) (list 'eq x y))))
+(defun remove-if (cl-predicate cl-seq &rest cl-keys)
+ "Remove all items satisfying PREDICATE in SEQUENCE.
-(put 'cl-check-key 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-test 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-match 'edebug-form-spec 'edebug-forms)
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE. If SEQUENCE is a list, the copy
+may share list structure with SEQUENCE. If no item satisfies PREDICATE,
+SEQUENCE itself is returned, unmodified.
-(defvar cl-test) (defvar cl-test-not)
-(defvar cl-if) (defvar cl-if-not)
-(defvar cl-key)
+See `remove*' for the meaning of the keywords.
-;; XEmacs; #'replace is in fns.c.
+arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
+ (apply 'remove* 'remove* cl-seq :if cl-predicate cl-keys))
-(defun remove* (cl-item cl-seq &rest cl-keys)
- "Remove all occurrences of ITEM in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Keywords supported: :test :test-not :key :count :start :end :from-end
-The keywords :test and :test-not specify two-argument test and negated-test
-predicates, respectively; :test defaults to `eql'. :key specifies a
-one-argument function that transforms elements of SEQ into \"comparison keys\"
-before the test predicate is applied. See `member*' for more information
-on these keywords.
-:start and :end, if given, specify indices of a subsequence of SEQ to
-be processed. Indices are 0-based and processing involves the subsequence
-starting at the index given by :start and ending just before the index
-given by :end.
-:count, if given, limits the number of items removed to the number specified.
-:from-end, if given, causes processing to proceed starting from the end
-instead of the beginning; in this case, this matters only if :count is given."
- (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
- (:start 0) :end) ()
- (if (<= (or cl-count (setq cl-count 8000000)) 0)
- cl-seq
- (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000)))
- (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
- cl-from-end)))
- (if cl-i
- (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
- (append (if cl-from-end
- (list :end (1+ cl-i))
- (list :start cl-i))
- cl-keys))))
- (typecase cl-seq
- (list cl-res)
- (string (concat cl-res))
- (vector (vconcat cl-res))
- (bit-vector (bvconcat cl-res))))
- cl-seq))
- (setq cl-end (- (or cl-end 8000000) cl-start))
- (if (= cl-start 0)
- (while (and cl-seq (> cl-end 0)
- (cl-check-test cl-item (car cl-seq))
- (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
- (> (setq cl-count (1- cl-count)) 0))))
- (if (and (> cl-count 0) (> cl-end 0))
- (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
- (setq cl-end (1- cl-end)) (cdr cl-seq))))
- (while (and cl-p (> cl-end 0)
- (not (cl-check-test cl-item (car cl-p))))
- (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
- (if (and cl-p (> cl-end 0))
- (nconc (ldiff cl-seq cl-p)
- (if (= cl-count 1) (cdr cl-p)
- (and (cdr cl-p)
- (apply 'delete* cl-item
- (copy-sequence (cdr cl-p))
- :start 0 :end (1- cl-end)
- :count (1- cl-count) cl-keys))))
- cl-seq))
- cl-seq)))))
+(defun remove-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Remove all items not satisfying PREDICATE in SEQUENCE.
-(defun remove-if (cl-pred cl-list &rest cl-keys)
- "Remove all items satisfying PREDICATE in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'remove* nil cl-list :if cl-pred cl-keys))
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE. If SEQUENCE is a list, the copy
+may share list structure with SEQUENCE.
-(defun remove-if-not (cl-pred cl-list &rest cl-keys)
- "Remove all items not satisfying PREDICATE in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'remove* nil cl-list :if-not cl-pred cl-keys))
+See `remove*' for the meaning of the keywords.
-(defun delete* (cl-item cl-seq &rest cl-keys)
- "Remove all occurrences of ITEM in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :test :test-not :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
- (:start 0) :end) ()
- (if (<= (or cl-count (setq cl-count 8000000)) 0)
- cl-seq
- (if (listp cl-seq)
- (if (and cl-from-end (< cl-count 4000000))
- (let (cl-i)
- (while (and (>= (setq cl-count (1- cl-count)) 0)
- (setq cl-i (cl-position cl-item cl-seq cl-start
- cl-end cl-from-end)))
- (if (= cl-i 0) (setq cl-seq (cdr cl-seq))
- (let ((cl-tail (nthcdr (1- cl-i) cl-seq)))
- (setcdr cl-tail (cdr (cdr cl-tail)))))
- (setq cl-end cl-i))
- cl-seq)
- (setq cl-end (- (or cl-end 8000000) cl-start))
- (if (= cl-start 0)
- (progn
- (while (and cl-seq
- (> cl-end 0)
- (cl-check-test cl-item (car cl-seq))
- (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
- (> (setq cl-count (1- cl-count)) 0)))
- (setq cl-end (1- cl-end)))
- (setq cl-start (1- cl-start)))
- (if (and (> cl-count 0) (> cl-end 0))
- (let ((cl-p (nthcdr cl-start cl-seq)))
- (while (and (cdr cl-p) (> cl-end 0))
- (if (cl-check-test cl-item (car (cdr cl-p)))
- (progn
- (setcdr cl-p (cdr (cdr cl-p)))
- (if (= (setq cl-count (1- cl-count)) 0)
- (setq cl-end 1)))
- (setq cl-p (cdr cl-p)))
- (setq cl-end (1- cl-end)))))
- cl-seq)
- (apply 'remove* cl-item cl-seq cl-keys)))))
+arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
+ (apply 'remove* 'remove* cl-seq :if-not cl-predicate cl-keys))
-(defun delete-if (cl-pred cl-list &rest cl-keys)
- "Remove all items satisfying PREDICATE in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'delete* nil cl-list :if cl-pred cl-keys))
+(defun delete-if (cl-predicate cl-seq &rest cl-keys)
+ "Remove all items satisfying PREDICATE in SEQUENCE.
-(defun delete-if-not (cl-pred cl-list &rest cl-keys)
- "Remove all items not satisfying PREDICATE in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'delete* nil cl-list :if-not cl-pred cl-keys))
+This is a destructive function; if SEQUENCE is a list, it reuses its
+storage. If SEQUENCE is an array and some element satisfies SEQUENCE, a
+copy is always returned.
-;; XEmacs change: this is in subr.el in GNU Emacs
-(defun remove (cl-item cl-seq)
- "Remove all occurrences of ITEM in SEQ, testing with `equal'
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Also see: `remove*', `delete', `delete*'"
- (remove* cl-item cl-seq ':test 'equal))
+See `remove*' for the meaning of the keywords.
-;; XEmacs change: this is in subr.el in GNU Emacs
-(defun remq (cl-elt cl-list)
- "Remove all occurrences of ELT in LIST, comparing with `eq'.
-This is a non-destructive function; it makes a copy of LIST to avoid
-corrupting the original LIST.
-Also see: `delq', `delete', `delete*', `remove', `remove*'."
- (if (memq cl-elt cl-list)
- (delq cl-elt (copy-list cl-list))
- cl-list))
+arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
+ (apply 'delete* 'delete* cl-seq :if cl-predicate cl-keys))
-(defun remove-duplicates (cl-seq &rest cl-keys)
- "Return a copy of SEQ with all duplicate elements removed.
-Keywords supported: :test :test-not :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-delete-duplicates cl-seq cl-keys t))
+(defun delete-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Remove all items not satisfying PREDICATE in SEQUENCE.
-(defun delete-duplicates (cl-seq &rest cl-keys)
- "Remove all duplicate elements from SEQ (destructively).
-Keywords supported: :test :test-not :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-delete-duplicates cl-seq cl-keys nil))
+This is a destructive function; it reuses the storage of SEQUENCE whenever
+possible.
-(defun cl-delete-duplicates (cl-seq cl-keys cl-copy)
- (if (listp cl-seq)
- (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
- ()
- (if cl-from-end
- (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
- (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
- (while (> cl-end 1)
- (setq cl-i 0)
- (while (setq cl-i (cl-position (cl-check-key (car cl-p))
- (cdr cl-p) cl-i (1- cl-end)))
- (if cl-copy (setq cl-seq (copy-sequence cl-seq)
- cl-p (nthcdr cl-start cl-seq) cl-copy nil))
- (let ((cl-tail (nthcdr cl-i cl-p)))
- (setcdr cl-tail (cdr (cdr cl-tail))))
- (setq cl-end (1- cl-end)))
- (setq cl-p (cdr cl-p) cl-end (1- cl-end)
- cl-start (1+ cl-start)))
- cl-seq)
- (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
- (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
- (cl-position (cl-check-key (car cl-seq))
- (cdr cl-seq) 0 (1- cl-end)))
- (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
- (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
- (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
- (while (and (cdr (cdr cl-p)) (> cl-end 1))
- (if (cl-position (cl-check-key (car (cdr cl-p)))
- (cdr (cdr cl-p)) 0 (1- cl-end))
- (progn
- (if cl-copy (setq cl-seq (copy-sequence cl-seq)
- cl-p (nthcdr (1- cl-start) cl-seq)
- cl-copy nil))
- (setcdr cl-p (cdr (cdr cl-p))))
- (setq cl-p (cdr cl-p)))
- (setq cl-end (1- cl-end) cl-start (1+ cl-start)))
- cl-seq)))
- (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil)))
- (typecase cl-seq
- (string (concat cl-res))
- (vector (vconcat cl-res))
- (bit-vector (bvconcat cl-res))))))
+See `remove*' for the meaning of the keywords.
-(defun substitute (cl-new cl-old cl-seq &rest cl-keys)
- "Substitute NEW for OLD in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Keywords supported: :test :test-not :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not :count
- (:start 0) :end :from-end) ()
- (if (or (eq cl-old cl-new)
- (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
- cl-seq
- (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end)))
- (if (not cl-i)
- cl-seq
- (setq cl-seq (copy-sequence cl-seq))
- (or cl-from-end
- (progn (cl-set-elt cl-seq cl-i cl-new)
- (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
- (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count
- :start cl-i cl-keys))))))
+arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
+ (apply 'delete* 'delete* cl-seq :if-not cl-predicate cl-keys))
-(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
- "Substitute NEW for all items satisfying PREDICATE in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-See `remove*' for the meaning of the keywords."
- (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys))
+(defun substitute-if (cl-new cl-predicate cl-seq &rest cl-keys)
+ "Substitute NEW for all items satisfying PREDICATE in SEQUENCE.
-(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
- "Substitute NEW for all items not satisfying PREDICATE in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-See `remove*' for the meaning of the keywords."
- (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys))
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE.
-(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
- "Substitute NEW for OLD in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :test :test-not :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not :count
- (:start 0) :end :from-end) ()
- (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
- (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
- (let ((cl-p (nthcdr cl-start cl-seq)))
- (setq cl-end (- (or cl-end 8000000) cl-start))
- (while (and cl-p (> cl-end 0) (> cl-count 0))
- (if (cl-check-test cl-old (car cl-p))
- (progn
- (setcar cl-p cl-new)
- (setq cl-count (1- cl-count))))
- (setq cl-p (cdr cl-p) cl-end (1- cl-end))))
- (or cl-end (setq cl-end (length cl-seq)))
- (if cl-from-end
- (while (and (< cl-start cl-end) (> cl-count 0))
- (setq cl-end (1- cl-end))
- (if (cl-check-test cl-old (elt cl-seq cl-end))
- (progn
- (cl-set-elt cl-seq cl-end cl-new)
- (setq cl-count (1- cl-count)))))
- (while (and (< cl-start cl-end) (> cl-count 0))
- (if (cl-check-test cl-old (aref cl-seq cl-start))
- (progn
- (aset cl-seq cl-start cl-new)
- (setq cl-count (1- cl-count))))
- (setq cl-start (1+ cl-start))))))
- cl-seq))
+See `remove*' for the meaning of the keywords.
-(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
- "Substitute NEW for all items satisfying PREDICATE in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
+arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
+ (apply 'substitute cl-new 'substitute cl-seq :if cl-predicate cl-keys))
-(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
- "Substitute NEW for all items not satisfying PREDICATE in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
+(defun substitute-if-not (cl-new cl-predicate cl-seq &rest cl-keys)
+ "Substitute NEW for all items not satisfying PREDICATE in SEQUENCE.
-(defun find (cl-item cl-seq &rest cl-keys)
- "Find the first occurrence of ITEM in LIST.
-Return the matching ITEM, or nil if not found.
-Keywords supported: :test :test-not :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
- (and cl-pos (elt cl-seq cl-pos))))
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE.
-(defun find-if (cl-pred cl-list &rest cl-keys)
- "Find the first item satisfying PREDICATE in LIST.
-Return the matching ITEM, or nil if not found.
-Keywords supported: :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'find nil cl-list :if cl-pred cl-keys))
+See `remove*' for the meaning of the keywords.
-(defun find-if-not (cl-pred cl-list &rest cl-keys)
- "Find the first item not satisfying PREDICATE in LIST.
-Return the matching ITEM, or nil if not found.
-Keywords supported: :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'find nil cl-list :if-not cl-pred cl-keys))
+arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
+ (apply 'substitute cl-new 'substitute cl-seq :if-not cl-predicate
+ cl-keys))
-(defun position (cl-item cl-seq &rest cl-keys)
- "Find the first occurrence of ITEM in LIST.
+(defun nsubstitute-if (cl-new cl-predicate cl-seq &rest cl-keys)
+ "Substitute NEW for all items satisfying PREDICATE in SEQUENCE.
+
+This is destructive function; it modifies SEQUENCE directly, never returning
+a copy. See `substitute-if' for a non-destructive version.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
+ (apply 'nsubstitute cl-new 'nsubstitute cl-seq :if cl-predicate
+ cl-keys))
+
+(defun nsubstitute-if-not (cl-new cl-predicate cl-seq &rest cl-keys)
+ "Substitute NEW for all items not satisfying PREDICATE in SEQUENCE.
+
+This is destructive function; it modifies SEQUENCE directly, never returning
+a copy. See `substitute-if-not' for a non-destructive version.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
+ (apply 'nsubstitute cl-new 'nsubstitute cl-seq :if-not cl-predicate
+ cl-keys))
+
+(defun find-if (cl-predicate cl-seq &rest cl-keys)
+ "Find the first item satisfying PREDICATE in SEQUENCE.
+
+Return the matching item, or DEFAULT (not a keyword specified for this
+function by Common Lisp) if not found.
+
+See `remove*' for the meaning of the other keywords.
+
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END DEFAULT)"
+ (apply 'find 'find cl-seq :if cl-predicate cl-keys))
+
+(defun find-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Find the first item not satisfying PREDICATE in SEQUENCE.
+
+Return the matching ITEM, or DEFAULT (not a keyword specified for this
+function by Common Lisp) if not found.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END DEFAULT)"
+ (apply 'find 'find cl-seq :if-not cl-predicate cl-keys))
+
+(defun position-if (cl-predicate cl-seq &rest cl-keys)
+ "Find the first item satisfying PREDICATE in SEQUENCE.
+
Return the index of the matching item, or nil if not found.
-Keywords supported: :test :test-not :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not
- (:start 0) :end :from-end) ()
- (cl-position cl-item cl-seq cl-start cl-end cl-from-end)))
-(defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
- (if (listp cl-seq)
- (let ((cl-p (nthcdr cl-start cl-seq)))
- (or cl-end (setq cl-end 8000000))
- (let ((cl-res nil))
- (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
- (if (cl-check-test cl-item (car cl-p))
- (setq cl-res cl-start))
- (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
- cl-res))
- (or cl-end (setq cl-end (length cl-seq)))
- (if cl-from-end
- (progn
- (while (and (>= (setq cl-end (1- cl-end)) cl-start)
- (not (cl-check-test cl-item (aref cl-seq cl-end)))))
- (and (>= cl-end cl-start) cl-end))
- (while (and (< cl-start cl-end)
- (not (cl-check-test cl-item (aref cl-seq cl-start))))
- (setq cl-start (1+ cl-start)))
- (and (< cl-start cl-end) cl-start))))
+See `remove*' for the meaning of the keywords.
-(defun position-if (cl-pred cl-list &rest cl-keys)
- "Find the first item satisfying PREDICATE in LIST.
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
+ (apply 'position 'position cl-seq :if cl-predicate cl-keys))
+
+(defun position-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Find the first item not satisfying PREDICATE in SEQUENCE.
+
Return the index of the matching item, or nil if not found.
-Keywords supported: :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'position nil cl-list :if cl-pred cl-keys))
-(defun position-if-not (cl-pred cl-list &rest cl-keys)
- "Find the first item not satisfying PREDICATE in LIST.
-Return the index of the matching item, or nil if not found.
-Keywords supported: :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'position nil cl-list :if-not cl-pred cl-keys))
+See `remove*' for the meaning of the keywords.
-(defun count (cl-item cl-seq &rest cl-keys)
- "Count the number of occurrences of ITEM in LIST.
-Keywords supported: :test :test-not :key :start :end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
- (let ((cl-count 0) cl-x)
- (or cl-end (setq cl-end (length cl-seq)))
- (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
- (while (< cl-start cl-end)
- (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start)))
- (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
- (setq cl-start (1+ cl-start)))
- cl-count)))
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
+ (apply 'position 'position cl-seq :if-not cl-predicate cl-keys))
-(defun count-if (cl-pred cl-list &rest cl-keys)
- "Count the number of items satisfying PREDICATE in LIST.
-Keywords supported: :key :start :end
-See `remove*' for the meaning of the keywords."
- (apply 'count nil cl-list :if cl-pred cl-keys))
+(defun count-if (cl-predicate cl-seq &rest cl-keys)
+ "Count the number of items satisfying PREDICATE in SEQUENCE.
-(defun count-if-not (cl-pred cl-list &rest cl-keys)
- "Count the number of items not satisfying PREDICATE in LIST.
-Keywords supported: :key :start :end
-See `remove*' for the meaning of the keywords."
- (apply 'count nil cl-list :if-not cl-pred cl-keys))
+See `remove*' for the meaning of the keywords.
-(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
- "Compare SEQ1 with SEQ2, return index of first mismatching element.
-Return nil if the sequences match. If one sequence is a prefix of the
-other, the return value indicates the end of the shorter sequence.
-Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
-See `search' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :from-end
- (:start1 0) :end1 (:start2 0) :end2) ()
- (or cl-end1 (setq cl-end1 (length cl-seq1)))
- (or cl-end2 (setq cl-end2 (length cl-seq2)))
- (if cl-from-end
- (progn
- (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
- (cl-check-match (elt cl-seq1 (1- cl-end1))
- (elt cl-seq2 (1- cl-end2))))
- (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
- (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
- (1- cl-end1)))
- (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
- (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
- (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
- (cl-check-match (if cl-p1 (car cl-p1)
- (aref cl-seq1 cl-start1))
- (if cl-p2 (car cl-p2)
- (aref cl-seq2 cl-start2))))
- (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
- cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
- (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
- cl-start1)))))
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
+ (apply 'count 'count cl-seq :if cl-predicate cl-keys))
-(defun search (cl-seq1 cl-seq2 &rest cl-keys)
- "Search for SEQ1 as a subsequence of SEQ2.
-Return the index of the leftmost element of the first match found;
-return nil if there are no matches.
-Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
-See `remove*' for the meaning of the keywords. In this case, :start1 and :end1
-specify a subsequence of SEQ1, and :start2 and :end2 specify a subsequence
-of SEQ2."
- (cl-parsing-keywords (:test :test-not :key :from-end
- (:start1 0) :end1 (:start2 0) :end2) ()
- (or cl-end1 (setq cl-end1 (length cl-seq1)))
- (or cl-end2 (setq cl-end2 (length cl-seq2)))
- (if (>= cl-start1 cl-end1)
- (if cl-from-end cl-end2 cl-start2)
- (let* ((cl-len (- cl-end1 cl-start1))
- (cl-first (cl-check-key (elt cl-seq1 cl-start1)))
- (cl-if nil) cl-pos)
- (setq cl-end2 (- cl-end2 (1- cl-len)))
- (while (and (< cl-start2 cl-end2)
- (setq cl-pos (cl-position cl-first cl-seq2
- cl-start2 cl-end2 cl-from-end))
- (apply 'mismatch cl-seq1 cl-seq2
- :start1 (1+ cl-start1) :end1 cl-end1
- :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
- :from-end nil cl-keys))
- (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
- (and (< cl-start2 cl-end2) cl-pos)))))
+(defun count-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Count the number of items not satisfying PREDICATE in SEQUENCE.
-(defun stable-sort (cl-seq cl-pred &rest cl-keys)
+See `remove*' for the meaning of the keywords.
+
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
+ (apply 'count 'count cl-seq :if-not cl-predicate cl-keys))
+
+(defun stable-sort (cl-seq cl-predicate &rest cl-keys)
"Sort the argument SEQUENCE stably according to PREDICATE.
This is a destructive function; it reuses the storage of SEQUENCE if possible.
Keywords supported: :key
＠＠ -589,144 +237,52 ＠＠
into \"comparison keys\" before the test predicate is applied. See
`member*' for more information.
-arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY))"
- (apply 'sort* cl-seq cl-pred cl-keys))
+arguments: (SEQUENCE PREDICATE &key (KEY #'identity))"
+ (apply 'sort* cl-seq cl-predicate cl-keys))
-;;; See compiler macro in cl-macs.el
-(defun member* (cl-item cl-list &rest cl-keys)
- "Find the first occurrence of ITEM in LIST.
-Return the sublist of LIST whose car is ITEM.
-Keywords supported: :test :test-not :key
-The keyword :test specifies a two-argument function that is used to
- compare ITEM with elements in LIST; if omitted, it defaults to `eql'.
-The keyword :test-not is similar, but specifies a negated predicate. That
- is, ITEM is considered equal to an element in LIST if the given predicate
- returns nil.
-:key specifies a one-argument function that transforms elements of LIST into
-\"comparison keys\" before the test predicate is applied. For example,
-if:key is #'car, then ITEM is compared with the car of elements from LIST1.
-The:key function, however, is not applied to ITEM, and does not affect the
-elements in the returned list, which are taken directly from the elements in
-LIST."
- (if cl-keys
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (while (and cl-list (not (cl-check-test cl-item (car cl-list))))
- (setq cl-list (cdr cl-list)))
- cl-list)
- (if (and (numberp cl-item) (not (fixnump cl-item)))
- (member cl-item cl-list)
- (memq cl-item cl-list))))
-
-(defun member-if (cl-pred cl-list &rest cl-keys)
+(defun member-if (cl-predicate cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'member* nil cl-list :if cl-pred cl-keys))
+See `member*' for the meaning of :key.
-(defun member-if-not (cl-pred cl-list &rest cl-keys)
+arguments: (PREDICATE LIST &key (KEY #'identity))"
+ (apply 'member* 'member* cl-list :if cl-predicate cl-keys))
+
+(defun member-if-not (cl-predicate cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'member* nil cl-list :if-not cl-pred cl-keys))
+See `member*' for the meaning of :key.
-(defun cl-adjoin (cl-item cl-list &rest cl-keys)
- (if (cl-parsing-keywords (:key) t
- (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
- cl-list
- (cons cl-item cl-list)))
+arguments: (PREDICATE LIST &key (KEY #'identity))"
+ (apply 'member* 'member* cl-list :if-not cl-predicate cl-keys))
-;;; See compiler macro in cl-macs.el
-(defun assoc* (cl-item cl-alist &rest cl-keys)
- "Find the first item whose car matches ITEM in LIST.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (if cl-keys
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (while (and cl-alist
- (or (not (consp (car cl-alist)))
- (not (cl-check-test cl-item (car (car cl-alist))))))
- (setq cl-alist (cdr cl-alist)))
- (and cl-alist (car cl-alist)))
- (if (and (numberp cl-item) (not (fixnump cl-item)))
- (assoc cl-item cl-alist)
- (assq cl-item cl-alist))))
+(defun assoc-if (cl-predicate cl-alist &rest cl-keys)
+ "Return the first item whose car satisfies PREDICATE in ALIST.
+See `member*' for the meaning of :key.
-(defun assoc-if (cl-pred cl-list &rest cl-keys)
- "Find the first item whose car satisfies PREDICATE in LIST.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'assoc* nil cl-list :if cl-pred cl-keys))
+arguments: (PREDICATE ALIST &key (KEY #'identity))"
+ (apply 'assoc* 'assoc* cl-alist :if cl-predicate cl-keys))
-(defun assoc-if-not (cl-pred cl-list &rest cl-keys)
- "Find the first item whose car does not satisfy PREDICATE in LIST.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'assoc* nil cl-list :if-not cl-pred cl-keys))
+(defun assoc-if-not (cl-predicate cl-alist &rest cl-keys)
+ "Return the first item whose car does not satisfy PREDICATE in ALIST.
+See `member*' for the meaning of :key.
-(defun rassoc* (cl-item cl-alist &rest cl-keys)
- "Find the first item whose cdr matches ITEM in LIST.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (if (or cl-keys (and (numberp cl-item) (not (fixnump cl-item))))
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (while (and cl-alist
- (or (not (consp (car cl-alist)))
- (not (cl-check-test cl-item (cdr (car cl-alist))))))
- (setq cl-alist (cdr cl-alist)))
- (and cl-alist (car cl-alist)))
- (rassq cl-item cl-alist)))
+arguments: (PREDICATE ALIST &key (KEY #'identity))"
+ (apply 'assoc* 'assoc* cl-alist :if-not cl-predicate cl-keys))
-(defun rassoc-if (cl-pred cl-list &rest cl-keys)
- "Find the first item whose cdr satisfies PREDICATE in LIST.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'rassoc* nil cl-list :if cl-pred cl-keys))
+(defun rassoc-if (cl-predicate cl-alist &rest cl-keys)
+ "Return the first item whose cdr satisfies PREDICATE in ALIST.
+See `member*' for the meaning of :key.
-(defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
- "Find the first item whose cdr does not satisfy PREDICATE in LIST.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys))
+arguments: (PREDICATE ALIST &key (KEY #'identity))"
+ (apply 'rassoc* 'rassoc* cl-alist :if cl-predicate cl-keys))
-(defun union (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-union operation.
-The result list contains all items that appear in either LIST1 or LIST2.
-This is a non-destructive function; it makes a copy of the data if necessary
-to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
-The keywords :test and :test-not specify two-argument test and negated-test
-predicates, respectively; :test defaults to `eql'. see `member*' for more
-information.
-:key specifies a one-argument function that transforms elements of LIST1
-and LIST2 into \"comparison keys\" before the test predicate is applied.
-For example, if :key is #'car, then the car of elements from LIST1 is
-compared with the car of elements from LIST2. The :key function, however,
-does not affect the elements in the returned list, which are taken directly
-from the elements in LIST1 and LIST2."
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- ((equal cl-list1 cl-list2) cl-list1)
- (t
- (or (>= (length cl-list1) (length cl-list2))
- (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
- (while cl-list2
- (if (or cl-keys (numberp (car cl-list2)))
- (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
- (or (memq (car cl-list2) cl-list1)
- (push (car cl-list2) cl-list1)))
- (pop cl-list2))
- cl-list1)))
+(defun rassoc-if-not (cl-predicate cl-alist &rest cl-keys)
+ "Return the first item whose cdr does not satisfy PREDICATE in ALIST.
+See `member*' for the meaning of :key.
-(defun nunion (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-union operation.
-The result list contains all items that appear in either LIST1 or LIST2.
-This is a destructive function; it reuses the storage of LIST1 and LIST2
-whenever possible.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- (t (apply 'union cl-list1 cl-list2 cl-keys))))
+arguments: (PREDICATE ALIST &key (KEY #'identity))"
+ (apply 'rassoc* 'rassoc* cl-alist :if-not cl-predicate cl-keys))
;; XEmacs addition: NOT IN COMMON LISP.
(defun stable-union (cl-list1 cl-list2 &rest cl-keys)
＠＠ -736,257 +292,90 ＠＠
LIST1 and LIST2. The result specifically consists of the elements in LIST1
in order, followed by any elements in LIST2 that are not also in LIST1, in
the order given in LIST2.
+
This is a non-destructive function; it makes a copy of the data if necessary
to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
+
See `union' for the meaning of :test, :test-not and :key.
NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs
-extension."
+extension.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)"
;; The standard `union' doesn't produce a "stable" union --
;; it iterates over the second list instead of the first one, and returns
;; the values in backwards order. According to the CLTL2 documentation,
;; `union' is not required to preserve the ordering of elements in
;; any fashion, so we add a new function rather than changing the
;; semantics of `union'.
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- ((equal cl-list1 cl-list2) cl-list1)
- (t
- (append
- cl-list1
- (cl-parsing-keywords (:key) (:test :test-not)
- (loop for cl-l in cl-list2
- if (not (if (or cl-keys (numberp cl-l))
- (apply 'member* (cl-check-key cl-l)
- cl-list1 cl-keys)
- (memq cl-l cl-list1)))
- collect cl-l))))))
-
-(defun intersection (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-intersection operation.
-The result list contains all items that appear in both LIST1 and LIST2.
-This is a non-destructive function; it makes a copy of the data if necessary
-to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (and cl-list1 cl-list2
- (if (equal cl-list1 cl-list2) cl-list1
- (cl-parsing-keywords (:key) (:test :test-not)
- (let ((cl-res nil))
- (or (>= (length cl-list1) (length cl-list2))
- (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
- (while cl-list2
- (if (if (or cl-keys (numberp (car cl-list2)))
- (apply 'member* (cl-check-key (car cl-list2))
- cl-list1 cl-keys)
- (memq (car cl-list2) cl-list1))
- (push (car cl-list2) cl-res))
- (pop cl-list2))
- cl-res)))))
-
-(defun nintersection (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-intersection operation.
-The result list contains all items that appear in both LIST1 and LIST2.
-This is a destructive function; it reuses the storage of LIST1 and LIST2
-whenever possible.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
+ (apply 'union cl-list1 cl-list2 :stable t cl-keys))
;; XEmacs addition: NOT IN COMMON LISP.
(defun stable-intersection (cl-list1 cl-list2 &rest cl-keys)
"Stably combine LIST1 and LIST2 using a set-intersection operation.
+
The result list contains all items that appear in both LIST1 and LIST2.
The result is \"stable\" in that it preserves the ordering of elements in
LIST1 that are also in LIST2.
+
This is a non-destructive function; it makes a copy of the data if necessary
to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
+
See `union' for the meaning of :test, :test-not and :key.
NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs
-extension."
+extension.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)"
;; The standard `intersection' doesn't produce a "stable" intersection --
;; it iterates over the second list instead of the first one, and returns
;; the values in backwards order. According to the CLTL2 documentation,
;; `intersection' is not required to preserve the ordering of elements in
- ;; any fashion, so we add a new function rather than changing the
- ;; semantics of `intersection'.
- (and cl-list1 cl-list2
- (if (equal cl-list1 cl-list2) cl-list1
- (cl-parsing-keywords (:key) (:test :test-not)
- (loop for cl-l in cl-list1
- if (if (or cl-keys (numberp cl-l))
- (apply 'member* (cl-check-key cl-l)
- cl-list2 cl-keys)
- (memq cl-l cl-list2))
- collect cl-l)))))
+ ;; any fashion, but it's trivial to implement a stable ordering in C,
+ ;; given that the order of arguments to the test function is specified.
+ (apply 'intersection cl-list1 cl-list2 :stable t cl-keys))
-(defun set-difference (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-difference operation.
-The result list contains all items that appear in LIST1 but not LIST2.
-This is a non-destructive function; it makes a copy of the data if necessary
-to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (if (or (null cl-list1) (null cl-list2)) cl-list1
- (cl-parsing-keywords (:key) (:test :test-not)
- (let ((cl-res nil))
- (while cl-list1
- (or (if (or cl-keys (numberp (car cl-list1)))
- (apply 'member* (cl-check-key (car cl-list1))
- cl-list2 cl-keys)
- (memq (car cl-list1) cl-list2))
- (push (car cl-list1) cl-res))
- (pop cl-list1))
- cl-res))))
+(defun subst-if (cl-new cl-predicate cl-tree &rest cl-keys)
+ "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
-(defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-difference operation.
-The result list contains all items that appear in LIST1 but not LIST2.
-This is a destructive function; it reuses the storage of LIST1 and LIST2
-whenever possible.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (if (or (null cl-list1) (null cl-list2)) cl-list1
- (apply 'set-difference cl-list1 cl-list2 cl-keys)))
+Return a copy of TREE with all matching elements replaced by NEW. If no
+element matches PREDICATE, return tree.
-(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-exclusive-or operation.
-The result list contains all items that appear in exactly one of LIST1, LIST2.
-This is a non-destructive function; it makes a copy of the data if necessary
-to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- ((equal cl-list1 cl-list2) nil)
- (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
- (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
+See `member*' for the meaning of :key.
-(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-exclusive-or operation.
-The result list contains all items that appear in exactly one of LIST1, LIST2.
-This is a destructive function; it reuses the storage of LIST1 and LIST2
-whenever possible.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- ((equal cl-list1 cl-list2) nil)
- (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
- (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
+arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
+ (apply 'subst cl-new 'subst cl-tree :if cl-predicate cl-keys))
-(defun subsetp (cl-list1 cl-list2 &rest cl-keys)
- "True if LIST1 is a subset of LIST2.
-I.e., if every element of LIST1 also appears in LIST2.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cond ((null cl-list1) t) ((null cl-list2) nil)
- ((equal cl-list1 cl-list2) t)
- (t (cl-parsing-keywords (:key) (:test :test-not)
- (while (and cl-list1
- (apply 'member* (cl-check-key (car cl-list1))
- cl-list2 cl-keys))
- (pop cl-list1))
- (null cl-list1)))))
+(defun subst-if-not (cl-new cl-predicate cl-tree &rest cl-keys)
+ "Substitute NEW for elements not matching PREDICATE in TREE.
-(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
- "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
-Return a copy of TREE with all matching elements replaced by NEW.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
+Return a copy of TREE with all matching elements replaced by NEW. If every
+element matches PREDICATE, return tree.
-(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
- "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
-Return a copy of TREE with all non-matching elements replaced by NEW.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
+See `member*' for the meaning of :key.
-(defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
- "Substitute NEW for OLD everywhere in TREE (destructively).
-Any element of TREE which is `eql' to OLD is changed to NEW (via a call
-to `setcar').
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
+arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
+ (apply 'subst cl-new 'subst cl-tree :if-not cl-predicate cl-keys))
-(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
+(defun nsubst-if (cl-new cl-predicate cl-tree &rest cl-keys)
"Substitute NEW for elements matching PREDICATE in TREE (destructively).
+
Any element of TREE which matches is changed to NEW (via a call to `setcar').
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
-(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
+See `member*' for the meaning of :key.
+
+arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
+ (apply 'nsubst cl-new 'nsubst cl-tree :if cl-predicate cl-keys))
+
+(defun nsubst-if-not (cl-new cl-predicate cl-tree &rest cl-keys)
"Substitute NEW for elements not matching PREDICATE in TREE (destructively).
+
Any element of TREE which matches is changed to NEW (via a call to `setcar').
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
-(defun sublis (cl-alist cl-tree &rest cl-keys)
- "Perform substitutions indicated by ALIST in TREE (non-destructively).
-Return a copy of TREE with all matching elements replaced.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (cl-sublis-rec cl-tree)))
+See `member*' for the meaning of :key.
-(defvar cl-alist)
-(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if*
- (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
- (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
- (setq cl-p (cdr cl-p)))
- (if cl-p (cdr (car cl-p))
- (if (consp cl-tree)
- (let ((cl-a (cl-sublis-rec (car cl-tree)))
- (cl-d (cl-sublis-rec (cdr cl-tree))))
- (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
- cl-tree
- (cons cl-a cl-d)))
- cl-tree))))
-
-(defun nsublis (cl-alist cl-tree &rest cl-keys)
- "Perform substitutions indicated by ALIST in TREE (destructively).
-Any matching element of TREE is changed via a call to `setcar'.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (let ((cl-hold (list cl-tree)))
- (cl-nsublis-rec cl-hold)
- (car cl-hold))))
-
-(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if*
- (while (consp cl-tree)
- (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
- (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
- (setq cl-p (cdr cl-p)))
- (if cl-p (setcar cl-tree (cdr (car cl-p)))
- (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
- (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
- (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
- (setq cl-p (cdr cl-p)))
- (if cl-p
- (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
- (setq cl-tree (cdr cl-tree))))))
-
-(defun tree-equal (cl-x cl-y &rest cl-keys)
- "Return t if trees X and Y have `eql' leaves.
-Atoms are compared by `eql'; cons cells are compared recursively.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cl-parsing-keywords (:test :test-not :key) ()
- (cl-tree-equal-rec cl-x cl-y)))
-
-(defun cl-tree-equal-rec (cl-x cl-y)
- (while (and (consp cl-x) (consp cl-y)
- (cl-tree-equal-rec (car cl-x) (car cl-y)))
- (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
- (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
-
-
-(run-hooks 'cl-seq-load-hook)
+arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
+ (apply 'nsubst cl-new 'nsubst cl-tree :if-not cl-predicate cl-keys))
;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c
;;; cl-seq.el ends here
diff -r f87bb35a6b94 -r d1b17a33450b lisp/cl.el
--- a/lisp/cl.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/cl.el Thu Dec 30 01:59:52 2010 +0000
＠＠ -557,36 +557,6 ＠＠
(defalias 'cl-round 'round*)
(defalias 'cl-mod 'mod*)
-(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs
- "Return ITEM consed onto the front of LIST only if it's not already there.
-Otherwise, return LIST unmodified.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (cond ((or (equal cl-keys '(:test eq))
- (and (null cl-keys) (not (numberp cl-item))))
- (if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
- ((or (equal cl-keys '(:test equal)) (null cl-keys))
- (if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
- (t (apply 'cl-adjoin cl-item cl-list cl-keys))))
-
-(defun subst (cl-new cl-old cl-tree &rest cl-keys)
- "Substitute NEW for OLD everywhere in TREE (non-destructively).
-Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (if (or cl-keys (and (numberp cl-old) (not (fixnump cl-old))))
- (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
- (cl-do-subst cl-new cl-old cl-tree)))
-
-(defun cl-do-subst (cl-new cl-old cl-tree)
- (cond ((eq cl-tree cl-old) cl-new)
- ((consp cl-tree)
- (let ((a (cl-do-subst cl-new cl-old (car cl-tree)))
- (d (cl-do-subst cl-new cl-old (cdr cl-tree))))
- (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
- cl-tree (cons a d))))
- (t cl-tree)))
-
(defun acons (key value alist)
"Return a new alist created by adding (KEY . VALUE) to ALIST."
(cons (cons key value) alist))
diff -r f87bb35a6b94 -r d1b17a33450b lisp/obsolete.el
--- a/lisp/obsolete.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/obsolete.el Thu Dec 30 01:59:52 2010 +0000
＠＠ -244,6 +244,15 ＠＠
(define-compatible-function-alias 'cl-mapc 'mapc)
+;; XEmacs; old compiler macros meant that this was called directly
+;; from compiled code, and we need to provide a version of it for a
+;; couple of years at least because of that. Aidan Kehoe, Mon Oct 4
+;; 12:06:41 IST 2010
+(defun cl-delete-duplicates (cl-seq cl-keys cl-copy)
+ (apply (if cl-copy #'remove-duplicates #'delete-duplicates) cl-seq cl-keys))
+
+(make-obsolete 'cl-delete-duplicates 'delete-duplicates)
+
; old names
(define-compatible-function-alias 'byte-code-function-p
'compiled-function-p) ;FSFmacs
＠＠ -433,5 +442,8 ＠＠
(define-compatible-function-alias 'process-plist 'object-plist)
(define-compatible-function-alias 'set-process-plist 'object-setplist)
+(define-function 'memql 'member*)
+(make-compatible 'memql "use the more full-featured `member*' instead.")
+
(provide 'obsolete)
;;; obsolete.el ends here
diff -r f87bb35a6b94 -r d1b17a33450b lisp/subr.el
--- a/lisp/subr.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/subr.el Thu Dec 30 01:59:52 2010 +0000
＠＠ -226,6 +226,9 ＠＠
;; XEmacs; this is in Lisp, its bytecode now taken by subseq.
(define-function 'substring 'subseq)
+
+(define-function 'sort 'sort*)
+(define-function 'fillarray 'fill)
;; XEmacs:
(defun local-variable-if-set-p (sym buffer)
＠＠ -1104,13 +1107,13 ＠＠
"Replace the variable names in MAP-PLIST-DEFINITION with uninterned
symbols, avoiding the risk of interference with variables in other functions
introduced by dynamic scope."
- (if-fboundp 'nsublis
- (nsublis
- '((mp-function . #:function)
- (plist . #:plist)
- (result . #:result))
- map-plist-definition)
- map-plist-definition)))
+ (nsublis '((mp-function . #:function)
+ (plist . #:plist)
+ (result . #:result))
+ ;; Need to specify #'eq as the test, otherwise we have a
+ ;; bootstrap issue, since #'eql is in cl.el, loaded after
+ ;; this file.
+ map-plist-definition :test #'eq)))
(defun map-plist (mp-function plist)
"Map FUNCTION (a function of two args) over each key/value pair in PLIST.
Return a list of the results."
diff -r f87bb35a6b94 -r d1b17a33450b src/ChangeLog
--- a/src/ChangeLog Thu Dec 30 01:14:13 2010 +0000
+++ b/src/ChangeLog Thu Dec 30 01:59:52 2010 +0000
＠＠ -1,3 +1,50 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Move the heavy lifting from cl-seq.el to C, finally making those
+ functions first-class XEmacs citizens, with circularity checking,
+ built-in support for tests other than #'eql, and as much
+ compatibility with current Common Lisp as Paul Dietz' tests require.
+
+ * fns.c (check_eq_nokey, check_eq_key, check_eql_nokey)
+ (check_eql_key, check_equal_nokey, check_equal_key)
+ (check_equalp_nokey, check_equalp_key, check_string_match_nokey)
+ (check_string_match_key, check_other_nokey, check_other_key)
+ (check_if_nokey, check_if_key, check_match_eq_key)
+ (check_match_eql_key, check_match_equal_key)
+ (check_match_equalp_key, check_match_other_key): New. These are
+ basically to provide function pointers to be used by Lisp
+ functions that take TEST, TEST-NOT and KEY arguments.
+
+ (get_check_match_function_1, get_check_test_function)
+ (get_check_match_function): These functions work out which of the
+ previous list of functions to use, given the keywords supplied by
+ the user.
+
+ (count_with_tail): New. This is the bones of #'count.
+ (list_count_from_end, string_count_from_end): Utility functions
+ for #'count.
+ (Fcount): New, moved from cl-seq.el.
+ (list_position_cons_before): New. The implementation of #'member*,
+ and important in implementing various other functions.
+
+ (FmemberX, Fadjoin, FassocX, FrassocX, Fposition, Ffind)
+ (FdeleteX, FremoveX, Fdelete_duplicates, Fremove_duplicates)
+ (Fnsubstitute, Fsubstitute, Fsublis, Fnsublis, Fsubst, Fnsubst)
+ (Ftree_equal, Fmismatch, Fsearch, Fintersection, Fnintersection)
+ (Fsubsetp, Fset_difference, Fnset_difference, Fnunion, Funion)
+ (Fset_exclusive_or, Fnset_exclusive_or): New, moved here from
+ cl-seq.el.
+
+ (position): New. The implementation of #'find and #'position.
+ (list_delete_duplicates_from_end, subst, sublis, nsublis)
+ (tree_equal, mismatch_from_end, mismatch_list_list)
+ (mismatch_list_string, mismatch_list_array)
+ (mismatch_string_array, mismatch_string_string)
+ (mismatch_array_array, get_mismatch_func): Helper C functions for
+ the Lisp-visible functions.
+ (venn, nvenn): New. The implementation of the main Lisp functions that
+ treat lists as sets.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* lisp.h (DECLARE_N_KEYWORDS_8, DECLARE_N_KEYWORDS_9)
diff -r f87bb35a6b94 -r d1b17a33450b src/fns.c
--- a/src/fns.c Thu Dec 30 01:14:13 2010 +0000
+++ b/src/fns.c Thu Dec 30 01:59:52 2010 +0000
＠＠ -54,17 +54,24 ＠＠
/* NOTE: This symbol is also used in lread.c */
#define FEATUREP_SYNTAX
-Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill, Qreplace;
-Lisp_Object Qidentity;
+Lisp_Object Qstring_lessp, Qmerge, Qfill, Qreplace, QassocX, QrassocX;
+Lisp_Object Qposition, Qfind, QdeleteX, QremoveX, Qidentity, Qadjoin;
Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value;
Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into;
-Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce;
-Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2;
+Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce, Qsubstitute;
+Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable;
+Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch;
+
+Lisp_Object Qintersection, Qnintersection, Qset_difference, Qnset_difference;
+Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qnset_difference;
Lisp_Object Qbase64_conversion_error;
Lisp_Object Vpath_separator;
+extern Fixnum max_lisp_eval_depth;
+extern int lisp_eval_depth;
+
static int internal_old_equal (Lisp_Object, Lisp_Object, int);
Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
＠＠ -199,6 +206,445 ＠＠
bit_vector_description,
size_bit_vector,
Lisp_Bit_Vector);
+
+/* Various test functions for #'member*, #'assoc* and the other functions
+ that take both TEST and KEY arguments. */
+
+typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt);
+
+static Boolint
+check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ return EQ (item, elt);
+}
+
+static Boolint
+check_eq_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
+ Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return EQ (item, elt);
+}
+
+/* The next two are not used by #'member* and #'assoc*, since we can decide
+ on #'eq vs. #'equal when we have the type of ITEM. */
+static Boolint
+check_eql_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ return EQ (elt1, elt2)
+ || (NON_FIXNUM_NUMBER_P (elt1) && internal_equal (elt1, elt2, 0));
+}
+
+static Boolint
+check_eql_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
+ Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return EQ (item, elt)
+ || (NON_FIXNUM_NUMBER_P (item) && internal_equal (item, elt, 0));
+}
+
+static Boolint
+check_equal_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ return internal_equal (item, elt, 0);
+}
+
+static Boolint
+check_equal_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
+ Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return internal_equal (item, elt, 0);
+}
+
+static Boolint
+check_equalp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ return internal_equalp (item, elt, 0);
+}
+
+static Boolint
+check_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return internal_equalp (item, elt, 0);
+}
+
+static Boolint
+check_string_match_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ return !NILP (Fstring_match (item, elt, Qnil, Qnil));
+}
+
+static Boolint
+check_string_match_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return !NILP (Fstring_match (item, elt, Qnil, Qnil));
+}
+
+static Boolint
+check_other_nokey (Lisp_Object test, Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ Lisp_Object args[] = { test, item, elt };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ UNGCPRO;
+
+ return !NILP (item);
+}
+
+static Boolint
+check_other_key (Lisp_Object test, Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt)
+{
+ Lisp_Object args[] = { item, key, elt };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args) - 1, args + 1));
+ args[1] = item;
+ args[0] = test;
+ item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ UNGCPRO;
+
+ return !NILP (item);
+}
+
+static Boolint
+check_if_nokey (Lisp_Object test, Lisp_Object UNUSED (key),
+ Lisp_Object UNUSED (item), Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (test, elt));
+ return !NILP (elt);
+}
+
+static Boolint
+check_if_key (Lisp_Object test, Lisp_Object key,
+ Lisp_Object UNUSED (item), Lisp_Object elt)
+{
+ Lisp_Object args[] = { key, elt };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ args[0] = test;
+ elt = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ UNGCPRO;
+
+ return !NILP (elt);
+}
+
+static Boolint
+check_match_eq_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return EQ (args[0], args[1]);
+}
+
+static Boolint
+check_match_eql_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return EQ (args[0], args[1]) ||
+ (NON_FIXNUM_NUMBER_P (args[0]) && internal_equal (args[0], args[1], 0));
+}
+
+static Boolint
+check_match_equal_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return internal_equal (args[0], args[1], 0);
+}
+
+static Boolint
+check_match_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return internal_equalp (args[0], args[1], 0);
+}
+
+static Boolint
+check_match_other_key (Lisp_Object test, Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ args[1] = args[0];
+ args[0] = test;
+
+ elt1 = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ UNGCPRO;
+
+ return !NILP (elt1);
+}
+
+static check_test_func_t
+get_check_match_function_1 (Lisp_Object item,
+ Lisp_Object *test_inout, Lisp_Object test_not,
+ Lisp_Object if_, Lisp_Object if_not,
+ Lisp_Object key, Boolint *test_not_unboundp_out,
+ check_test_func_t *test_func_out)
+{
+ Lisp_Object test = *test_inout;
+ check_test_func_t result = NULL, test_func = NULL;
+ Boolint force_if = 0;
+
+ if (!NILP (if_))
+ {
+ if (!(NILP (test) && NILP (test_not) && NILP (if_not)))
+ {
+ invalid_argument ("only one keyword among :test :test-not "
+ ":if :if-not allowed", if_);
+ }
+
+ test = *test_inout = if_;
+ force_if = 1;
+ }
+ else if (!NILP (if_not))
+ {
+ if (!(NILP (test) && NILP (test_not)))
+ {
+ invalid_argument ("only one keyword among :test :test-not "
+ ":if :if-not allowed", if_not);
+ }
+
+ test_not = if_not;
+ force_if = 1;
+ }
+
+ if (NILP (test))
+ {
+ if (!NILP (test_not))
+ {
+ test = *test_inout = test_not;
+ if (NULL != test_not_unboundp_out)
+ {
+ *test_not_unboundp_out = 0;
+ }
+ }
+ else
+ {
+ test = Qeql;
+ if (NULL != test_not_unboundp_out)
+ {
+ *test_not_unboundp_out = 1;
+ }
+ }
+ }
+ else if (!NILP (test_not))
+ {
+ invalid_argument_2 ("conflicting :test and :test-not keyword arguments",
+ test, test_not);
+ }
+
+ test = indirect_function (test, 1);
+
+ if (NILP (key) ||
+ EQ (indirect_function (key, 1), XSYMBOL_FUNCTION (Qidentity)))
+ {
+ key = Qidentity;
+ }
+
+ if (force_if)
+ {
+ result = EQ (key, Qidentity) ? check_if_nokey : check_if_key;
+
+ if (NULL != test_func_out)
+ {
+ *test_func_out = result;
+ }
+
+ return result;
+ }
+
+ if (!UNBOUNDP (item) && EQ (test, XSYMBOL_FUNCTION (Qeql)))
+ {
+ test = XSYMBOL_FUNCTION (NON_FIXNUM_NUMBER_P (item) ? Qequal : Qeq);
+ }
+
+#define FROB(known_test, eq_condition) \
+ if (EQ (test, XSYMBOL_FUNCTION (Q##known_test))) do \
+ { \
+ if (eq_condition) \
+ { \
+ test = XSYMBOL_FUNCTION (Qeq); \
+ goto force_eq_check; \
+ } \
+ \
+ if (!EQ (Qidentity, key)) \
+ { \
+ test_func = check_##known_test##_key; \
+ result = check_match_##known_test##_key; \
+ } \
+ else \
+ { \
+ result = test_func = check_##known_test##_nokey; \
+ } \
+ } while (0)
+
+ FROB (eql, 0);
+ else if (SUBRP (test))
+ {
+ force_eq_check:
+ FROB (eq, 0);
+ else FROB (equal, (SYMBOLP (item) || INTP (item) || CHARP (item)));
+ else FROB (equalp, (SYMBOLP (item)));
+ else if (EQ (test, XSYMBOL_FUNCTION (Qstring_match)))
+ {
+ if (EQ (Qidentity, key))
+ {
+ test_func = result = check_string_match_nokey;
+ }
+ else
+ {
+ test_func = check_string_match_key;
+ result = check_other_key;
+ }
+ }
+ }
+
+ if (NULL == result)
+ {
+ if (EQ (Qidentity, key))
+ {
+ test_func = result = check_other_nokey;
+ }
+ else
+ {
+ test_func = check_other_key;
+ result = check_match_other_key;
+ }
+ }
+
+ if (NULL != test_func_out)
+ {
+ *test_func_out = test_func;
+ }
+
+ return result;
+}
+#undef FROB
+
+/* Given TEST, TEST_NOT, IF, IF_NOT, KEY, and ITEM, return a C function
+ pointer appropriate for use in deciding whether a given element of a
+ sequence satisfies TEST.
+
+ Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero
+ if it was bound, and set *test_inout to the value it was bound to. If
+ TEST was not bound, leave *test_inout alone; the value is not used by
+ check_eq_*key() or check_equal_*key(), which are the defaults, depending
+ on the type of ITEM.
+
+ The returned function takes arguments (TEST, KEY, ITEM, ELT), where ITEM
+ is the item being searched for and ELT is the element of the sequence
+ being examined.
+
+ Error if both TEST and TEST_NOT were specified, which Common Lisp says is
+ undefined behaviour. */
+
+static check_test_func_t
+get_check_test_function (Lisp_Object item,
+ Lisp_Object *test_inout, Lisp_Object test_not,
+ Lisp_Object if_, Lisp_Object if_not,
+ Lisp_Object key, Boolint *test_not_unboundp_out)
+{
+ check_test_func_t result = NULL;
+ get_check_match_function_1 (item, test_inout, test_not, if_, if_not,
+ key, test_not_unboundp_out, &result);
+ return result;
+}
+
+/* Given TEST, TEST_NOT, IF, IF_NOT and KEY, return a C function pointer
+ appropriate for use in deciding whether two given elements of a sequence
+ satisfy TEST.
+
+ Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero
+ if it was bound, and set *test_inout to the value it was bound to. If
+ TEST was not bound, leave *test_inout alone; the value is not used by
+ check_eql_*key().
+
+ The returned function takes arguments (TEST, KEY, ELT1, ELT2), where ELT1
+ and ELT2 are elements of the sequence being examined.
+
+ The value that would be given by get_check_test_function() is returned in
+ *TEST_FUNC_OUT, which allows calling functions to do their own key checks
+ if they're processing one element at a time.
+
+ Error if both TEST and TEST_NOT were specified, which Common Lisp says is
+ undefined behaviour. */
+
+static check_test_func_t
+get_check_match_function (Lisp_Object *test_inout, Lisp_Object test_not,
+ Lisp_Object if_, Lisp_Object if_not,
+ Lisp_Object key, Boolint *test_not_unboundp_out,
+ check_test_func_t *test_func_out)
+{
+ return get_check_match_function_1 (Qunbound, test_inout, test_not,
+ if_, if_not, key,
+ test_not_unboundp_out, test_func_out);
+}
DEFUN ("identity", Fidentity, 1, 1, 0, /*
＠＠ -366,7 +812,316 ＠＠
return EQ (hare, tortoise) && len != 0 ? Qnil : make_int (len);
}
-
+
+static Lisp_Object string_count_from_end (Lisp_Object, Lisp_Object ,
+ check_test_func_t, Boolint,
+ Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object);
+
+static Lisp_Object list_count_from_end (Lisp_Object, Lisp_Object,
+ check_test_func_t, Boolint,
+ Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object);
+
+/* Count the number of occurrences of ITEM in SEQUENCE; if SEQUENCE is a
+ list, store the cons cell of which the car is the last ITEM in SEQUENCE,
+ at the address given by tail_out. */
+
+static Lisp_Object
+count_with_tail (Lisp_Object *tail_out, int nargs, Lisp_Object *args,
+ Lisp_Object caller)
+{
+ Lisp_Object item = args[0], sequence = args[1];
+ Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0;
+ Elemcount len, ii = 0, counting = EMACS_INT_MAX;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS_8 (caller, nargs, args, 9,
+ (test, key, start, end, from_end, test_not, count,
+ if_, if_not), (start = Qzero), 2, 0);
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ counting = BIGNUMP (count) ? EMACS_INT_MAX + 1 : XINT (count);
+
+ /* 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));
+ }
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ *tail_out = Qnil;
+
+ if (CONSP (sequence))
+ {
+ Lisp_Object elt, tail = Qnil;
+ struct gcpro gcpro1;
+
+ if (EQ (caller, Qcount) && !NILP (from_end)
+ && (!EQ (key, Qnil) ||
+ check_test == check_other_nokey || check_test == check_if_nokey))
+ {
+ /* #'count, #'count-if, and #'count-if-not are documented to have
+ a given traversal order if :from-end t is passed in, even
+ though forward traversal of the sequence has the same result
+ and is algorithmically less expensive for lists and strings.
+ This order isn't necessary for other callers, though. */
+ return list_count_from_end (item, sequence, check_test,
+ test_not_unboundp, test, key,
+ start, end);
+ }
+
+ GCPRO1 (tail);
+
+ /* If COUNT is non-nil and FROM-END is t, we can give the tail
+ containing the last match, since that's what #'remove* is
+ interested in (a zero or negative COUNT won't ever reach
+ count_with_tail(), our callers will return immediately on seeing
+ it). */
+ if (!NILP (count) && !NILP (from_end))
+ {
+ counting = EMACS_INT_MAX;
+ }
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (!(ii < ending))
+ {
+ break;
+ }
+
+ if (starting <= ii &&
+ check_test (test, key, item, elt) == test_not_unboundp)
+ {
+ encountered++;
+ *tail_out = tail;
+
+ if (encountered == counting)
+ {
+ break;
+ }
+ }
+
+ ii++;
+ }
+ }
+
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end))) &&
+ encountered != counting)
+ {
+ check_sequence_range (args[1], start, end, Flength (args[1]));
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
+ Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
+ Lisp_Object character = Qnil;
+
+ if (EQ (caller, Qcount) && !NILP (from_end)
+ && (!EQ (key, Qnil) ||
+ check_test == check_other_nokey || check_test == check_if_nokey))
+ {
+ /* See comment above in the list code. */
+ return string_count_from_end (item, sequence,
+ check_test, test_not_unboundp,
+ test, key, start, end);
+ }
+
+ while (cursor_offset < byte_len && ii < ending && encountered < counting)
+ {
+ if (ii >= starting)
+ {
+ character = make_char (itext_ichar (cursor));
+
+ if (check_test (test, key, item, character)
+ == test_not_unboundp)
+ {
+ encountered++;
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (caller, sequence);
+ }
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+ }
+ else
+ {
+ Lisp_Object object = Qnil;
+
+ len = XINT (Flength (sequence));
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ ending = min (ending, len);
+ if (0 == len)
+ {
+ /* Catches the case where we have nil. */
+ return make_integer (encountered);
+ }
+
+ if (NILP (from_end))
+ {
+ for (ii = starting; ii < ending && encountered < counting; ii++)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (check_test (test, key, item, object) == test_not_unboundp)
+ {
+ encountered++;
+ }
+ }
+ }
+ else
+ {
+ for (ii = ending - 1; ii >= starting && encountered < counting; ii--)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (check_test (test, key, item, object) == test_not_unboundp)
+ {
+ encountered++;
+ }
+ }
+ }
+ }
+
+ return make_integer (encountered);
+}
+
+static Lisp_Object
+list_count_from_end (Lisp_Object item, Lisp_Object sequence,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Lisp_Object start, Lisp_Object end)
+{
+ Elemcount length = XINT (Flength (sequence)), ii = 0, starting = XINT (start);
+ Elemcount ending = NILP (end) ? length : XINT (end), encountered = 0;
+ Lisp_Object *storage;
+ struct gcpro gcpro1;
+
+ check_sequence_range (sequence, start, end, make_integer (length));
+
+ storage = alloca_array (Lisp_Object, ending - starting);
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence)
+ {
+ if (starting <= ii && ii < ending)
+ {
+ storage[ii - starting] = elt;
+ }
+ ii++;
+ }
+ }
+
+ GCPRO1 (storage[0]);
+ gcpro1.nvars = ending - starting;
+
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ if (check_test (test, key, item, storage[ii - starting])
+ == test_not_unboundp)
+ {
+ encountered++;
+ }
+ }
+
+ UNGCPRO;
+
+ return make_integer (encountered);
+}
+
+static Lisp_Object
+string_count_from_end (Lisp_Object item, Lisp_Object sequence,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Lisp_Object start, Lisp_Object end)
+{
+ Elemcount length = string_char_length (sequence), ii = 0;
+ Elemcount starting = XINT (start), ending = NILP (end) ? length : XINT (end);
+ Elemcount encountered = 0;
+ Ibyte *cursor = XSTRING_DATA (sequence);
+ Ibyte *endp = cursor + XSTRING_LENGTH (sequence);
+ Ichar *storage;
+
+ check_sequence_range (sequence, start, end, make_integer (length));
+
+ storage = alloca_array (Ichar, ending - starting);
+
+ while (cursor < endp && ii < ending)
+ {
+ if (starting <= ii && ii < ending)
+ {
+ storage [ii - starting] = itext_ichar (cursor);
+ }
+
+ ii++;
+ INC_IBYTEPTR (cursor);
+ }
+
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ if (check_test (test, key, item, make_char (storage [ii - starting]))
+ == test_not_unboundp)
+ {
+ encountered++;
+ }
+ }
+
+ return make_integer (encountered);
+}
+
+DEFUN ("count", Fcount, 2, MANY, 0, /*
+Count the number of occurrences of ITEM in SEQUENCE.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object tail = Qnil;
+
+ /* count_with_tail() accepts more keywords than we do, check those we've
+ been given. */
+ PARSE_KEYWORDS (Fcount, nargs, args, 8,
+ (test, test_not, if_, if_not, key, start, end, from_end),
+ NULL);
+
+ return count_with_tail (&tail, nargs, args, Qcount);
+}
+
/*** string functions. ***/
DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
＠＠ -1002,7 +1757,7 ＠＠
Lisp_Object
safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
{
- if (depth > 200)
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
stack_overflow ("Stack overflow in copy-tree", arg);
if (CONSP (arg))
＠＠ -1742,978 +2497,116 ＠＠
return Qnil;
}
-DEFUN ("assoc", Fassoc, 2, 2, 0, /*
-Return non-nil if KEY is `equal' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car equals KEY.
-*/
- (key, alist))
-{
- /* This function can GC. */
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_equal (key, elt_car, 0))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
-Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car equals KEY.
-*/
- (key, alist))
-{
- /* This function can GC. */
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_old_equal (key, elt_car, 0))
- return elt;
- }
- return Qnil;
-}
-
-Lisp_Object
-assoc_no_quit (Lisp_Object key, Lisp_Object alist)
-{
- int speccount = specpdl_depth ();
- specbind (Qinhibit_quit, Qt);
- return unbind_to_1 (speccount, Fassoc (key, alist));
-}
-
-DEFUN ("assq", Fassq, 2, 2, 0, /*
-Return non-nil if KEY is `eq' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car is KEY.
-Elements of ALIST that are not conses are ignored.
-*/
- (key, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
-Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car is KEY.
-Elements of ALIST that are not conses are ignored.
-This function is provided only for byte-code compatibility with v19.
-Do not use it.
-*/
- (key, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (HACKEQ_UNSAFE (key, elt_car))
- return elt;
- }
- return Qnil;
-}
-
-/* Like Fassq but never report an error and do not allow quits.
- Use only on lists known never to be circular. */
-
-Lisp_Object
-assq_no_quit (Lisp_Object key, Lisp_Object alist)
-{
- /* This cannot GC. */
- LIST_LOOP_2 (elt, alist)
- {
- Lisp_Object elt_car = XCAR (elt);
- if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
-Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr equals VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_equal (value, elt_cdr, 0))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
-Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr equals VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_old_equal (value, elt_cdr, 0))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("rassq", Frassq, 2, 2, 0, /*
-Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr is VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
-Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr is VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (HACKEQ_UNSAFE (value, elt_cdr))
- return elt;
- }
- return Qnil;
-}
-
-/* Like Frassq, but caller must ensure that ALIST is properly
- nil-terminated and ebola-free. */
-Lisp_Object
-rassq_no_quit (Lisp_Object value, Lisp_Object alist)
-{
- LIST_LOOP_2 (elt, alist)
- {
- Lisp_Object elt_cdr = XCDR (elt);
- if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
- return elt;
- }
- return Qnil;
-}
-
-
-DEFUN ("delete", Fdelete, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `equal'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (delete element foo))' to be sure
-of changing the value of `foo'.
-Also see: `remove'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (internal_equal (elt, list_elt, 0)));
- return list;
-}
-
-DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `old-equal'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (old-delete element foo))' to be sure
-of changing the value of `foo'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (internal_old_equal (elt, list_elt, 0)));
- return list;
-}
-
-DEFUN ("delq", Fdelq, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `eq'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (delq element foo))' to be sure of
-changing the value of `foo'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
- return list;
-}
-
-DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `old-eq'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
-changing the value of `foo'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (HACKEQ_UNSAFE (elt, list_elt)));
- return list;
-}
-
-/* Like Fdelq, but caller must ensure that LIST is properly
- nil-terminated and ebola-free. */
-
-Lisp_Object
-delq_no_quit (Lisp_Object elt, Lisp_Object list)
-{
- LIST_LOOP_DELETE_IF (list_elt, list,
- (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
- return list;
-}
-
-/* Be VERY careful with this. This is like delq_no_quit() but
- also calls free_cons() on the removed conses. You must be SURE
- that no pointers to the freed conses remain around (e.g.
- someone else is pointing to part of the list). This function
- is useful on internal lists that are used frequently and where
- the actual list doesn't escape beyond known code bounds. */
-
-Lisp_Object
-delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
-{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- REGISTER Lisp_Object tem = XCAR (tail);
- if (EQ (elt, tem))
- {
- Lisp_Object cons_to_free = tail;
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- tail = XCDR (tail);
- free_cons (cons_to_free);
- }
- else
- {
- prev = tail;
- tail = XCDR (tail);
- }
- }
- return list;
-}
-
-DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
-Delete by side effect any elements of ALIST whose car is `equal' to KEY.
-The modified ALIST is returned. If the first member of ALIST has a car
-that is `equal' to KEY, there is no way to remove it by side effect;
-therefore, write `(setq foo (remassoc key foo))' to be sure of changing
-the value of `foo'.
-*/
- (key, alist))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- internal_equal (key, XCAR (elt), 0)));
- return alist;
-}
-
-Lisp_Object
-remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
-{
- int speccount = specpdl_depth ();
- specbind (Qinhibit_quit, Qt);
- return unbind_to_1 (speccount, Fremassoc (key, alist));
-}
-
-DEFUN ("remassq", Fremassq, 2, 2, 0, /*
-Delete by side effect any elements of ALIST whose car is `eq' to KEY.
-The modified ALIST is returned. If the first member of ALIST has a car
-that is `eq' to KEY, there is no way to remove it by side effect;
-therefore, write `(setq foo (remassq key foo))' to be sure of changing
-the value of `foo'.
-*/
- (key, alist))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
- return alist;
-}
-
-/* no quit, no errors; be careful */
-
-Lisp_Object
-remassq_no_quit (Lisp_Object key, Lisp_Object alist)
-{
- LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
- return alist;
-}
-
-DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
-Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
-The modified ALIST is returned. If the first member of ALIST has a car
-that is `equal' to VALUE, there is no way to remove it by side effect;
-therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
-the value of `foo'.
-*/
- (value, alist))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- internal_equal (value, XCDR (elt), 0)));
- return alist;
-}
-
-DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
-Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
-The modified ALIST is returned. If the first member of ALIST has a car
-that is `eq' to VALUE, there is no way to remove it by side effect;
-therefore, write `(setq foo (remrassq value foo))' to be sure of changing
-the value of `foo'.
-*/
- (value, alist))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
- return alist;
-}
-
-/* Like Fremrassq, fast and unsafe; be careful */
-Lisp_Object
-remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
-{
- LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
- return alist;
-}
-
-DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
-Reverse SEQUENCE, destructively.
-
-Return the beginning of the reversed sequence, which will be a distinct Lisp
-object if SEQUENCE is a list with length greater than one. See also
-`reverse', the non-destructive version of this function.
-*/
- (sequence))
-{
- CHECK_SEQUENCE (sequence);
-
- if (CONSP (sequence))
- {
- struct gcpro gcpro1, gcpro2;
- Lisp_Object prev = Qnil;
- Lisp_Object tail = sequence;
-
- /* We gcpro our args; see `nconc' */
- GCPRO2 (prev, tail);
- while (!NILP (tail))
- {
- REGISTER Lisp_Object next;
- CONCHECK_CONS (tail);
- next = XCDR (tail);
- XCDR (tail) = prev;
- prev = tail;
- tail = next;
- }
- UNGCPRO;
- return prev;
- }
- else if (VECTORP (sequence))
- {
- Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
- Elemcount half = length / 2;
- Lisp_Object swap = Qnil;
- CHECK_LISP_WRITEABLE (sequence);
-
- while (ii > half)
- {
- swap = XVECTOR_DATA (sequence) [length - ii];
- XVECTOR_DATA (sequence) [length - ii]
- = XVECTOR_DATA (sequence) [ii - 1];
- XVECTOR_DATA (sequence) [ii - 1] = swap;
- --ii;
- }
- }
- else if (STRINGP (sequence))
- {
- Elemcount length = XSTRING_LENGTH (sequence);
- Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
- Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
-
- CHECK_LISP_WRITEABLE (sequence);
- while (cursor < endp)
- {
- staging_end -= itext_ichar_len (cursor);
- itext_copy_ichar (cursor, staging_end);
- INC_IBYTEPTR (cursor);
- }
-
- assert (staging == staging_end);
-
- memcpy (XSTRING_DATA (sequence), staging, length);
- init_string_ascii_begin (sequence);
- bump_string_modiff (sequence);
- sledgehammer_check_ascii_begin (sequence);
- }
- else if (BIT_VECTORP (sequence))
- {
- Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
- Elemcount length = bit_vector_length (bv), ii = length;
- Elemcount half = length / 2;
- int swap = 0;
-
- CHECK_LISP_WRITEABLE (sequence);
- while (ii > half)
- {
- swap = bit_vector_bit (bv, length - ii);
- set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1));
- set_bit_vector_bit (bv, ii - 1, swap);
- --ii;
- }
- }
- else
- {
- assert (NILP (sequence));
- }
-
- return sequence;
-}
-
-DEFUN ("reverse", Freverse, 1, 1, 0, /*
-Reverse SEQUENCE, copying. Return the reversed sequence.
-See also the function `nreverse', which is used more often.
-*/
- (sequence))
-{
- Lisp_Object result = Qnil;
-
- CHECK_SEQUENCE (sequence);
-
- if (CONSP (sequence))
- {
- EXTERNAL_LIST_LOOP_2 (elt, sequence)
- {
- result = Fcons (elt, result);
- }
- }
- else if (VECTORP (sequence))
- {
- Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
- Lisp_Object *staging = alloca_array (Lisp_Object, length);
-
- while (ii > 0)
- {
- staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1];
- --ii;
- }
-
- result = Fvector (length, staging);
- }
- else if (STRINGP (sequence))
- {
- Elemcount length = XSTRING_LENGTH (sequence);
- Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
- Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
-
- while (cursor < endp)
- {
- staging_end -= itext_ichar_len (cursor);
- itext_copy_ichar (cursor, staging_end);
- INC_IBYTEPTR (cursor);
- }
-
- assert (staging == staging_end);
-
- result = make_string (staging, length);
- }
- else if (BIT_VECTORP (sequence))
- {
- Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res;
- Elemcount length = bit_vector_length (bv), ii = length;
-
- result = make_bit_vector (length, Qzero);
- res = XBIT_VECTOR (result);
-
- while (ii > 0)
- {
- set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1));
- --ii;
- }
- }
- else
- {
- assert (NILP (sequence));
- }
-
- return result;
-}
-
-static Lisp_Object
-c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object key_func)
-{
- struct gcpro gcpro1;
- Lisp_Object args[3];
-
- /* We could use call2() and call3() here, but we're called O(nlogn) times
- for a sequence of length n, it make some sense to inline them. */
- args[0] = key_func;
- args[1] = obj1;
- args[2] = Qnil;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = countof (args);
-
- obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
-
- args[1] = obj2;
- obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
-
- args[0] = pred;
- args[1] = obj1;
- args[2] = obj2;
-
- RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
-}
-
-static Lisp_Object
-c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object UNUSED (key_func))
-{
- struct gcpro gcpro1;
- Lisp_Object args[3];
-
- /* This is (almost) the implementation of call2, it makes some sense to
- inline it here. */
- args[0] = pred;
- args[1] = obj1;
- args[2] = obj2;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = countof (args);
-
- RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
-}
-
-Lisp_Object
-list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
-{
- Lisp_Object value;
- Lisp_Object tail;
- Lisp_Object tem;
- Lisp_Object l1, l2;
- Lisp_Object tortoises[2];
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
- int l1_count = 0, l2_count = 0;
-
- l1 = org_l1;
- l2 = org_l2;
- tail = Qnil;
- value = Qnil;
- tortoises[0] = org_l1;
- tortoises[1] = org_l2;
-
- if (NULL == c_predicate)
- {
- c_predicate = EQ (key_func, Qidentity) ?
- c_merge_predicate_nokey : c_merge_predicate_key;
- }
-
- /* It is sufficient to protect org_l1 and org_l2.
- When l1 and l2 are updated, we copy the new values
- back into the org_ vars. */
-
- GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
- gcpro5.nvars = 2;
-
- while (1)
- {
- if (NILP (l1))
- {
- UNGCPRO;
- if (NILP (tail))
- return l2;
- Fsetcdr (tail, l2);
- return value;
- }
- if (NILP (l2))
- {
- UNGCPRO;
- if (NILP (tail))
- return l1;
- Fsetcdr (tail, l1);
- return value;
- }
-
- if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func)))
- {
- tem = l1;
- l1 = Fcdr (l1);
- org_l1 = l1;
-
- if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
- {
- if (l1_count & 1)
- {
- if (!CONSP (tortoises[0]))
- {
- mapping_interaction_error (Qmerge, tortoises[0]);
- }
-
- tortoises[0] = XCDR (tortoises[0]);
- }
-
- if (EQ (org_l1, tortoises[0]))
- {
- signal_circular_list_error (org_l1);
- }
- }
- }
- else
- {
- tem = l2;
- l2 = Fcdr (l2);
- org_l2 = l2;
-
- if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
- {
- if (l2_count & 1)
- {
- if (!CONSP (tortoises[1]))
- {
- mapping_interaction_error (Qmerge, tortoises[1]);
- }
-
- tortoises[1] = XCDR (tortoises[1]);
- }
-
- if (EQ (org_l2, tortoises[1]))
- {
- signal_circular_list_error (org_l2);
- }
- }
- }
-
- if (NILP (tail))
- value = tem;
- else
- Fsetcdr (tail, tem);
-
- tail = tem;
- }
-}
-
-static void
-array_merge (Lisp_Object *dest, Elemcount dest_len,
- Lisp_Object *front, Elemcount front_len,
- Lisp_Object *back, Elemcount back_len,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
-{
- Elemcount ii, fronting, backing;
- Lisp_Object *front_staging = front;
- Lisp_Object *back_staging = back;
+/* Return the first index of ITEM in LIST. In CONS_OUT, return the cons cell
+ before that containing the element. If the element is in the first cons
+ cell, return Qnil in CONS_OUT. TEST, KEY, START, END are as in
+ #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should have been initialized
+ with get_check_match_function() or get_check_test_function(). A non-zero
+ REVERSE_TEST_ORDER means call TEST with the element from LIST as its
+ first argument and ITEM as its second. Error if LIST is ill-formed, or
+ circular. */
+static Lisp_Object
+list_position_cons_before (Lisp_Object *cons_out,
+ Lisp_Object item, Lisp_Object list,
+ check_test_func_t check_test,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint reverse_test_order,
+ Lisp_Object start, Lisp_Object end)
+{
struct gcpro gcpro1, gcpro2;
-
- assert (dest_len == (back_len + front_len));
-
- if (0 == dest_len)
- {
- return;
- }
-
- if (front >= dest && front < (dest + dest_len))
- {
- front_staging = alloca_array (Lisp_Object, front_len);
-
- for (ii = 0; ii < front_len; ++ii)
- {
- front_staging[ii] = front[ii];
- }
- }
-
- if (back >= dest && back < (dest + dest_len))
- {
- back_staging = alloca_array (Lisp_Object, back_len);
-
- for (ii = 0; ii < back_len; ++ii)
- {
- back_staging[ii] = back[ii];
- }
- }
-
- GCPRO2 (front_staging[0], back_staging[0]);
- gcpro1.nvars = front_len;
- gcpro2.nvars = back_len;
-
- for (ii = fronting = backing = 0; ii < dest_len; ++ii)
- {
- if (fronting >= front_len)
- {
- while (ii < dest_len)
- {
- dest[ii] = back_staging[backing];
- ++ii, ++backing;
- }
- UNGCPRO;
- return;
- }
-
- if (backing >= back_len)
- {
- while (ii < dest_len)
- {
- dest[ii] = front_staging[fronting];
- ++ii, ++fronting;
- }
- UNGCPRO;
- return;
- }
-
- if (NILP (c_predicate (back_staging[backing], front_staging[fronting],
- predicate, key_func)))
- {
- dest[ii] = front_staging[fronting];
- ++fronting;
- }
- else
- {
- dest[ii] = back_staging[backing];
- ++backing;
- }
- }
-
- UNGCPRO;
-}
-
-static Lisp_Object
-list_array_merge_into_list (Lisp_Object list,
- Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func,
- Boolint reverse_order)
-{
- Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
- Elemcount array_index = 0;
- int looped = 0;
-
- GCPRO4 (list, tail, value, tortoise);
-
- while (1)
- {
- if (NILP (list))
- {
- UNGCPRO;
-
- if (NILP (tail))
- {
- return Flist (array_len, array);
- }
-
- Fsetcdr (tail, Flist (array_len - array_index, array + array_index));
- return value;
- }
-
- if (array_index >= array_len)
- {
- UNGCPRO;
- if (NILP (tail))
- {
- return list;
- }
-
- Fsetcdr (tail, list);
- return value;
- }
-
-
- if (reverse_order ?
- !NILP (c_predicate (Fcar (list), array [array_index], predicate,
- key_func)) :
- NILP (c_predicate (array [array_index], Fcar (list), predicate,
- key_func)))
- {
- if (NILP (tail))
- {
- value = tail = list;
- }
- else
- {
- Fsetcdr (tail, list);
- tail = XCDR (tail);
- }
-
- list = Fcdr (list);
- }
- else
- {
- if (NILP (tail))
- {
- value = tail = Fcons (array [array_index], Qnil);
- }
- else
- {
- Fsetcdr (tail, Fcons (array [array_index], tail));
- tail = XCDR (tail);
- }
- ++array_index;
- }
-
- if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH)
- {
- if (looped & 1)
- {
- tortoise = XCDR (tortoise);
- }
-
- if (EQ (list, tortoise))
- {
- signal_circular_list_error (list);
- }
- }
- }
-}
-
-static void
-list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
- Lisp_Object list_one, Lisp_Object list_two,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
-{
- Elemcount output_index = 0;
-
- while (output_index < output_len)
- {
- if (NILP (list_one))
- {
- while (output_index < output_len)
- {
- output [output_index] = Fcar (list_two);
- list_two = Fcdr (list_two), ++output_index;
- }
- return;
- }
-
- if (NILP (list_two))
- {
- while (output_index < output_len)
- {
- output [output_index] = Fcar (list_one);
- list_one = Fcdr (list_one), ++output_index;
- }
- return;
- }
-
- if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate,
- key_func)))
- {
- output [output_index] = XCAR (list_one);
- list_one = XCDR (list_one);
- }
- else
- {
- output [output_index] = XCAR (list_two);
- list_two = XCDR (list_two);
- }
-
- ++output_index;
-
- /* No need to check for circularity. */
- }
-}
-
-static void
-list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
- Lisp_Object list,
- Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func,
- Boolint reverse_order)
-{
- Elemcount output_index = 0, array_index = 0;
-
- while (output_index < output_len)
- {
- if (NILP (list))
- {
- if (array_len - array_index != output_len - output_index)
- {
- mapping_interaction_error (Qmerge, list);
- }
-
- while (array_index < array_len)
- {
- output [output_index++] = array [array_index++];
- }
-
- return;
- }
-
- if (array_index >= array_len)
- {
- while (output_index < output_len)
- {
- output [output_index++] = Fcar (list);
- list = Fcdr (list);
- }
-
- return;
- }
-
- if (reverse_order ?
- !NILP (c_predicate (Fcar (list), array [array_index], predicate,
- key_func)) :
- NILP (c_predicate (array [array_index], Fcar (list), predicate,
- key_func)))
- {
- output [output_index] = XCAR (list);
- list = XCDR (list);
- }
- else
- {
- output [output_index] = array [array_index];
- ++array_index;
- }
-
- ++output_index;
- }
-}
-
-#define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \
- do { \
- c_array = alloca_array (Lisp_Object, len); \
- for (counter = 0; counter < len; ++counter) \
- { \
- c_array[counter] = make_char (itext_ichar (strdata)); \
- INC_IBYTEPTR (strdata); \
- } \
- } while (0)
-
-#define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \
- c_array = alloca_array (Lisp_Object, len); \
- for (counter = 0; counter < len; ++counter) \
- { \
- c_array[counter] = make_int (bit_vector_bit (v, counter)); \
- } \
- } while (0)
+ Lisp_Object elt = Qnil, tail = list, tail_before = Qnil;
+ Elemcount len, ii = 0, starting = XINT (start);
+ Elemcount ending = NILP (end) ? EMACS_INT_MAX : XINT (end);
+
+ GCPRO2 (elt, tail);
+
+ if (check_test == check_eq_nokey)
+ {
+ /* TEST is #'eq, no need to call any C functions, and the test order
+ won't be visible. */
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len)
+ {
+ if (starting <= ii && ii < ending &&
+ EQ (item, elt) == test_not_unboundp)
+ {
+ *cons_out = tail_before;
+ RETURN_UNGCPRO (make_integer (ii));
+ }
+ else
+ {
+ if (ii >= ending)
+ {
+ break;
+ }
+ }
+ ii++;
+ tail_before = tail;
+ }
+ }
+ else
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len)
+ {
+ if (starting <= ii && ii < ending &&
+ (reverse_test_order ?
+ check_test (test, key, elt, item) :
+ check_test (test, key, item, elt)) == test_not_unboundp)
+ {
+ *cons_out = tail_before;
+ RETURN_UNGCPRO (make_integer (ii));
+ }
+ else
+ {
+ if (ii >= ending)
+ {
+ break;
+ }
+ }
+ ii++;
+ tail_before = tail;
+ }
+ }
+
+ RETURN_UNGCPRO (Qnil);
+}
+
+DEFUN ("member*", FmemberX, 2, MANY, 0, /*
+Return the first sublist of LIST with car ITEM, or nil if no such sublist.
+
+The keyword :test specifies a two-argument function that is used to compare
+ITEM with elements in LIST; if omitted, it defaults to `eql'.
+
+The keyword :test-not is similar, but specifies a negated function. That
+is, ITEM is considered equal to an element in LIST if the given function
+returns nil. Common Lisp deprecates :test-not, and if both are specified,
+XEmacs signals an error.
+
+:key specifies a one-argument function that transforms elements of LIST into
+\"comparison keys\" before the test predicate is applied. For example,
+if:key is #'car, then ITEM is compared with the car of elements from LIST.
+The:key function, however, is not applied to ITEM, and does not affect the
+elements in the returned list, which are taken directly from the elements in
+LIST.
+
+arguments: (ITEM LIST &key (TEST #'eql) TEST-NOT (KEY #'identity))
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], list = args[1], result = Qnil, position0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (FmemberX, nargs, args, 5, (test, if_not, if_, test_not, key),
+ NULL);
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+ position0
+ = list_position_cons_before (&result, item, list, check_test,
+ test_not_unboundp, test, key, 0, Qzero, Qnil);
+
+ return CONSP (result) ? XCDR (result) : ZEROP (position0) ? list : Qnil;
+}
/* This macro might eventually find a better home than here. */
＠＠ -2727,9 +2620,2568 ＠＠
if (!EQ (key, Qidentity)) \
{ \
key = indirect_function (key, 1); \
+ if (EQ (key, XSYMBOL_FUNCTION (Qidentity))) \
+ { \
+ key = Qidentity; \
+ } \
} \
} while (0)
+#define KEY(key, item) (EQ (Qidentity, key) ? item : \
+ IGNORE_MULTIPLE_VALUES (call1 (key, item)))
+
+DEFUN ("adjoin", Fadjoin, 2, MANY, 0, /*
+Return ITEM consed onto the front of LIST, if not already in LIST.
+
+Otherwise, return LIST unmodified.
+
+See `member*' for the meaning of the keywords.
+
+arguments: (ITEM LIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], list = args[1], keyed = Qnil, ignore = Qnil;
+ struct gcpro gcpro1;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fadjoin, nargs, args, 3, (test, key, test_not),
+ NULL);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ keyed = KEY (key, item);
+
+ GCPRO1 (keyed);
+ check_test = get_check_test_function (keyed, &test, test_not, Qnil, Qnil,
+ key, &test_not_unboundp);
+ if (NILP (list_position_cons_before (&ignore, keyed, list, check_test,
+ test_not_unboundp, test, key, 0, Qzero,
+ Qnil)))
+ {
+ RETURN_UNGCPRO (Fcons (item, list));
+ }
+
+ RETURN_UNGCPRO (list);
+}
+
+DEFUN ("assoc", Fassoc, 2, 2, 0, /*
+Return non-nil if KEY is `equal' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car equals KEY.
+*/
+ (key, alist))
+{
+ /* This function can GC. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_equal (key, elt_car, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
+Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car equals KEY.
+*/
+ (key, alist))
+{
+ /* This function can GC. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_old_equal (key, elt_car, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+Lisp_Object
+assoc_no_quit (Lisp_Object key, Lisp_Object alist)
+{
+ int speccount = specpdl_depth ();
+ specbind (Qinhibit_quit, Qt);
+ return unbind_to_1 (speccount, Fassoc (key, alist));
+}
+
+DEFUN ("assq", Fassq, 2, 2, 0, /*
+Return non-nil if KEY is `eq' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car is KEY.
+Elements of ALIST that are not conses are ignored.
+*/
+ (key, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
+Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car is KEY.
+Elements of ALIST that are not conses are ignored.
+This function is provided only for byte-code compatibility with v19.
+Do not use it.
+*/
+ (key, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (HACKEQ_UNSAFE (key, elt_car))
+ return elt;
+ }
+ return Qnil;
+}
+
+/* Like Fassq but never report an error and do not allow quits.
+ Use only on lists known never to be circular. */
+
+Lisp_Object
+assq_no_quit (Lisp_Object key, Lisp_Object alist)
+{
+ /* This cannot GC. */
+ LIST_LOOP_2 (elt, alist)
+ {
+ Lisp_Object elt_car = XCAR (elt);
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("assoc*", FassocX, 2, MANY, 0, /*
+Find the first item whose car matches ITEM in ALIST.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], alist = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (FassocX, nargs, args, 5, (test, if_, if_not, test_not, key),
+ NULL);
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ if (check_test == check_eq_nokey)
+ {
+ /* TEST is #'eq, no need to call any C functions. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (EQ (item, elt_car) == test_not_unboundp)
+ {
+ return elt;
+ }
+ }
+ }
+ else
+ {
+ Lisp_Object tailed = alist;
+ struct gcpro gcpro1;
+
+ GCPRO1 (tailed);
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, item, elt_car) == test_not_unboundp)
+ {
+ RETURN_UNGCPRO (elt);
+ }
+ }
+ }
+ UNGCPRO;
+ }
+
+ return Qnil;
+}
+
+DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
+Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr equals VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_equal (value, elt_cdr, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
+Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr equals VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_old_equal (value, elt_cdr, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("rassq", Frassq, 2, 2, 0, /*
+Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr is VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
+Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr is VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (HACKEQ_UNSAFE (value, elt_cdr))
+ return elt;
+ }
+ return Qnil;
+}
+
+/* Like Frassq, but caller must ensure that ALIST is properly
+ nil-terminated and ebola-free. */
+Lisp_Object
+rassq_no_quit (Lisp_Object value, Lisp_Object alist)
+{
+ LIST_LOOP_2 (elt, alist)
+ {
+ Lisp_Object elt_cdr = XCDR (elt);
+ if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("rassoc*", FrassocX, 2, MANY, 0, /*
+Find the first item whose cdr matches ITEM in ALIST.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], alist = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (FrassocX, nargs, args, 5, (test, if_, if_not, test_not, key),
+ NULL);
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ if (check_test == check_eq_nokey)
+ {
+ /* TEST is #'eq, no need to call any C functions. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (EQ (item, elt_cdr) == test_not_unboundp)
+ {
+ return elt;
+ }
+ }
+ }
+ else
+ {
+ struct gcpro gcpro1;
+ Lisp_Object tailed = alist;
+
+ GCPRO1 (tailed);
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, item, elt_cdr) == test_not_unboundp)
+ {
+ RETURN_UNGCPRO (elt);
+ }
+ }
+ }
+ UNGCPRO;
+ }
+
+ return Qnil;
+}
+
+/* This is the implementation of both #'find and #'position. */
+static Lisp_Object
+position (Lisp_Object *object_out, Lisp_Object item, Lisp_Object sequence,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key, Lisp_Object start, Lisp_Object end,
+ Lisp_Object from_end, Lisp_Object default_, Lisp_Object caller)
+{
+ Lisp_Object result = Qnil;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0;
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = INTP (start) ? XINT (start) : 1 + EMACS_INT_MAX;
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = INTP (end) ? XINT (end) : 1 + EMACS_INT_MAX;
+ }
+
+ *object_out = default_;
+
+ if (CONSP (sequence))
+ {
+ Lisp_Object elt, tail = Qnil;
+ struct gcpro gcpro1;
+
+ if (!(starting < ending))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ /* starting could be equal to ending, in which case nil is what
+ we want to return. */
+ return Qnil;
+ }
+
+ GCPRO1 (tail);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (starting <= ii && ii < ending
+ && check_test (test, key, item, elt) == test_not_unboundp)
+ {
+ result = make_integer (ii);
+ *object_out = elt;
+
+ if (NILP (from_end))
+ {
+ UNGCPRO;
+ return result;
+ }
+ }
+ else if (ii == ending)
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+
+ UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
+ Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
+ Lisp_Object character = Qnil;
+
+ while (cursor_offset < byte_len && ii < ending)
+ {
+ if (ii >= starting)
+ {
+ character = make_char (itext_ichar (cursor));
+
+ if (check_test (test, key, item, character) == test_not_unboundp)
+ {
+ result = make_integer (ii);
+ *object_out = character;
+
+ if (NILP (from_end))
+ {
+ return result;
+ }
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (caller, sequence);
+ }
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+ }
+ else
+ {
+ Lisp_Object object = Qnil;
+ len = XINT (Flength (sequence));
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ ending = min (ending, len);
+ if (0 == len)
+ {
+ /* Catches the case where we have nil. */
+ return result;
+ }
+
+ if (NILP (from_end))
+ {
+ for (ii = starting; ii < ending; ii++)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (check_test (test, key, item, object) == test_not_unboundp)
+ {
+ result = make_integer (ii);
+ *object_out = object;
+ return result;
+ }
+ }
+ }
+ else
+ {
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (check_test (test, key, item, object) == test_not_unboundp)
+ {
+ result = make_integer (ii);
+ *object_out = object;
+ return result;
+ }
+ }
+ }
+ }
+
+ return result;
+}
+
+DEFUN ("position", Fposition, 2, MANY, 0, /*
+Return the index of the first occurrence of ITEM in SEQUENCE.
+
+Return nil if not found. See `remove*' for the meaning of the keywords.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object object = Qnil, item = args[0], sequence = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fposition, nargs, args, 8,
+ (test, if_, test_not, if_not, key, start, end, from_end),
+ (start = Qzero));
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ return position (&object, item, sequence, check_test, test_not_unboundp,
+ test, key, start, end, from_end, Qnil, Qposition);
+}
+
+DEFUN ("find", Ffind, 2, MANY, 0, /*
+Find the first occurrence of ITEM in SEQUENCE.
+
+Return the matching ITEM, or nil if not found. See `remove*' for the
+meaning of the keywords.
+
+The keyword :default, not specified by Common Lisp, designates an object to
+return instead of nil if ITEM is not found.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) DEFAULT FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object object = Qnil, item = args[0], sequence = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fposition, nargs, args, 9,
+ (test, if_, test_not, if_not, key, start, end, from_end,
+ default_),
+ (start = Qzero));
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ position (&object, item, sequence, check_test, test_not_unboundp,
+ test, key, start, end, from_end, Qnil, Qposition);
+
+ return object;
+}
+
+DEFUN ("delete", Fdelete, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `equal'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (delete element foo))' to be sure
+of changing the value of `foo'.
+Also see: `remove'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_equal (elt, list_elt, 0)));
+ return list;
+}
+
+DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `old-equal'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (old-delete element foo))' to be sure
+of changing the value of `foo'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_old_equal (elt, list_elt, 0)));
+ return list;
+}
+
+DEFUN ("delq", Fdelq, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `eq'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (delq element foo))' to be sure of
+changing the value of `foo'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
+ return list;
+}
+
+DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `old-eq'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
+changing the value of `foo'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (HACKEQ_UNSAFE (elt, list_elt)));
+ return list;
+}
+
+/* Like Fdelq, but caller must ensure that LIST is properly
+ nil-terminated and ebola-free. */
+
+Lisp_Object
+delq_no_quit (Lisp_Object elt, Lisp_Object list)
+{
+ LIST_LOOP_DELETE_IF (list_elt, list,
+ (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
+ return list;
+}
+
+/* Be VERY careful with this. This is like delq_no_quit() but
+ also calls free_cons() on the removed conses. You must be SURE
+ that no pointers to the freed conses remain around (e.g.
+ someone else is pointing to part of the list). This function
+ is useful on internal lists that are used frequently and where
+ the actual list doesn't escape beyond known code bounds. */
+
+Lisp_Object
+delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
+{
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object tem = XCAR (tail);
+ if (EQ (elt, tem))
+ {
+ Lisp_Object cons_to_free = tail;
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ tail = XCDR (tail);
+ free_cons (cons_to_free);
+ }
+ else
+ {
+ prev = tail;
+ tail = XCDR (tail);
+ }
+ }
+ return list;
+}
+
+DEFUN ("delete*", FdeleteX, 2, MANY, 0, /*
+Remove all occurrences of ITEM in SEQUENCE, destructively.
+
+If SEQUENCE is a non-nil list, this modifies the list directly. A non-list
+SEQUENCE will not be destructively modified, rather, if ITEM occurs in it, a
+new SEQUENCE of the same type without ITEM will be returned.
+
+See `remove*' for a non-destructive alternative, and for explanation of the
+keyword arguments.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], sequence = args[1], tail = sequence;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, counting = EMACS_INT_MAX;
+ Elemcount len, ii = 0, encountered = 0, presenting = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1;
+
+ PARSE_KEYWORDS (FdeleteX, nargs, args, 9,
+ (test, if_not, if_, test_not, key, start, end, from_end,
+ count), (start = Qzero, count = Qunbound));
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (!UNBOUNDP (count))
+ {
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ if (BIGNUMP (count))
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + EMACS_INT_MAX : EMACS_INT_MIN - 1;
+ }
+ else
+ {
+ counting = XINT (count);
+ }
+
+ if (counting < 1)
+ {
+ return sequence;
+ }
+ }
+ }
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ if (CONSP (sequence))
+ {
+ Lisp_Object prev_tail_list_elt = Qnil, list_elt = Qnil;
+ Elemcount list_len = 0, deleted = 0;
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ /* Both COUNT and FROM-END were specified; we need to traverse the
+ list twice. */
+ Lisp_Object present = count_with_tail (&list_elt, nargs, args,
+ QdeleteX);
+
+ if (ZEROP (present))
+ {
+ return sequence;
+ }
+
+ presenting = XINT (present);
+
+ /* If there are fewer items in the list than we have permission to
+ delete, we don't need to differentiate between the :from-end
+ nil and :from-end t cases. Otherwise, presenting is the number
+ of matching items we need to ignore before we start to
+ delete. */
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ GCPRO1 (tail);
+ ii = -1;
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (list_elt, sequence, tail, list_len)
+ {
+ ii++;
+
+ if (starting <= ii && ii < ending &&
+ (check_test (test, key, item, list_elt) == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting
+: encountered++ < counting))
+ {
+ if (NILP (prev_tail_list_elt))
+ {
+ sequence = XCDR (tail);
+ }
+ else
+ {
+ XSETCDR (prev_tail_list_elt, XCDR (tail));
+ }
+
+ /* Keep tortoise from ever passing hare. */
+ list_len = 0;
+ deleted++;
+ }
+ else
+ {
+ prev_tail_list_elt = tail;
+ if (ii >= ending || (!presenting && encountered > counting))
+ {
+ break;
+ }
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end))) &&
+ !(presenting ? encountered == presenting : encountered == counting))
+ {
+ check_sequence_range (args[1], start, end,
+ make_int (deleted + XINT (Flength (args[1]))));
+ }
+
+ return sequence;
+ }
+ else if (STRINGP (sequence))
+ {
+ Ibyte *staging = alloca_ibytes (XSTRING_LENGTH (sequence));
+ Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence);
+ Ibyte *cursor = startp;
+ Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence);
+ Lisp_Object character, result = sequence;
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ Lisp_Object present = count_with_tail (&character, nargs, args,
+ QdeleteX);
+
+ if (ZEROP (present))
+ {
+ return sequence;
+ }
+
+ presenting = XINT (present);
+
+ /* If there are fewer items in the list than we have permission to
+ delete, we don't need to differentiate between the :from-end
+ nil and :from-end t cases. Otherwise, presenting is the number
+ of matching items we need to ignore before we start to
+ delete. */
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ ii = 0;
+ while (cursor_offset < byte_len)
+ {
+ if (ii >= starting && ii < ending)
+ {
+ character = make_char (itext_ichar (cursor));
+
+ if ((check_test (test, key, item, character)
+ == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting :
+ encountered++ < counting))
+ {
+ DO_NOTHING;
+ }
+ else
+ {
+ staging_cursor
+ += set_itext_ichar (staging_cursor, XCHAR (character));
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (QdeleteX, sequence);
+ }
+ }
+ else
+ {
+ staging_cursor += itext_copy_ichar (cursor, staging_cursor);
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+
+ if (0 != encountered)
+ {
+ result = make_string (staging, staging_cursor - staging);
+ copy_string_extents (result, sequence, 0, 0,
+ staging_cursor - staging);
+ sequence = result;
+ }
+
+ return sequence;
+ }
+ else
+ {
+ Lisp_Object position0 = Qnil, object = Qnil;
+ Lisp_Object *staging = NULL, *staging_cursor, *staging_limit;
+ Elemcount positioning;
+
+ len = XINT (Flength (sequence));
+
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ position0 = position (&object, item, sequence, check_test,
+ test_not_unboundp, test, key, start, end,
+ from_end, Qnil, QdeleteX);
+ if (NILP (position0))
+ {
+ return sequence;
+ }
+
+ ending = min (ending, len);
+ positioning = XINT (position0);
+ encountered = 1;
+
+ if (NILP (from_end))
+ {
+ staging = alloca_array (Lisp_Object, len - 1);
+ staging_cursor = staging;
+
+ ii = 0;
+ while (ii < positioning)
+ {
+ *staging_cursor++ = Faref (sequence, make_int (ii));
+ ii++;
+ }
+
+ ii = positioning + 1;
+ while (ii < ending)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (encountered < counting
+ && (check_test (test, key, item, object)
+ == test_not_unboundp))
+ {
+ encountered++;
+ }
+ else
+ {
+ *staging_cursor++ = object;
+ }
+ ii++;
+ }
+
+ while (ii < len)
+ {
+ *staging_cursor++ = Faref (sequence, make_int (ii));
+ ii++;
+ }
+ }
+ else
+ {
+ staging = alloca_array (Lisp_Object, len - 1);
+ staging_cursor = staging_limit = staging + len - 1;
+
+ ii = len - 1;
+ while (ii > positioning)
+ {
+ *--staging_cursor = Faref (sequence, make_int (ii));
+ ii--;
+ }
+
+ ii = positioning - 1;
+ while (ii >= starting)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (encountered < counting
+ && (check_test (test, key, item, object) ==
+ test_not_unboundp))
+ {
+ encountered++;
+ }
+ else
+ {
+ *--staging_cursor = object;
+ }
+
+ ii--;
+ }
+
+ while (ii >= 0)
+ {
+ *--staging_cursor = Faref (sequence, make_int (ii));
+ ii--;
+ }
+
+ staging = staging_cursor;
+ staging_cursor = staging_limit;
+ }
+
+ if (VECTORP (sequence))
+ {
+ return Fvector (staging_cursor - staging, staging);
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ return Fbit_vector (staging_cursor - staging, staging);
+ }
+
+ /* A nil sequence will have given us a nil #'position,
+ above. */
+ ABORT ();
+
+ return Qnil;
+ }
+}
+
+DEFUN ("remove*", FremoveX, 2, MANY, 0, /*
+Remove all occurrences of ITEM in SEQUENCE, non-destructively.
+
+If SEQUENCE is a list, `remove*' makes a copy if that is necessary to avoid
+corrupting the original SEQUENCE.
+
+The keywords :test and :test-not specify two-argument test and negated-test
+predicates, respectively; :test defaults to `eql'. :key specifies a
+one-argument function that transforms elements of SEQUENCE into \"comparison
+keys\" before the test predicate is applied. See `member*' for more
+information on these keywords.
+
+:start and :end, if given, specify indices of a subsequence of SEQUENCE to
+be processed. Indices are 0-based and processing involves the subsequence
+starting at the index given by :start and ending just before the index given
+by:end.
+
+:count, if given, limits the number of items removed to the number
+specified.:from-end, if given, causes processing to proceed starting from
+the end instead of the beginning; in this case, this matters only if :count
+is given.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], sequence = args[1], matched_count = Qnil,
+ tail = Qnil;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, counting = EMACS_INT_MAX;
+ Elemcount len, ii = 0, encountered = 0, presenting = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1;
+
+ PARSE_KEYWORDS (FremoveX, nargs, args, 9,
+ (test, if_not, if_, test_not, key, start, end, from_end,
+ count), (start = Qzero));
+
+ if (!CONSP (sequence))
+ {
+ return FdeleteX (nargs, args);
+ }
+
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ if (BIGNUMP (count))
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
+ }
+ else
+ {
+ counting = XINT (count);
+ }
+
+ if (counting <= 0)
+ {
+ return sequence;
+ }
+ }
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ matched_count = count_with_tail (&tail, nargs, args, QremoveX);
+
+ if (!ZEROP (matched_count))
+ {
+ Lisp_Object elt, tailing = Qnil, result = Qnil, result_tail = Qnil;
+ GCPRO1 (tailing);
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ presenting = XINT (matched_count);
+
+ /* If there are fewer matching elements in the list than we have
+ permission to delete, we don't need to differentiate between
+ the :from-end nil and :from-end t cases. Otherwise, presenting
+ is the number of matching items we need to ignore before we
+ start to delete. */
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tailing, len)
+ {
+ if (EQ (tail, tailing))
+ {
+ if (NILP (result))
+ {
+ RETURN_UNGCPRO (XCDR (tail));
+ }
+
+ XSETCDR (result_tail, XCDR (tail));
+ RETURN_UNGCPRO (result);
+ }
+ else if (starting <= ii && ii < ending &&
+ (check_test (test, key, item, elt) == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting
+: encountered++ < counting))
+ {
+ DO_NOTHING;
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+
+ if (ii == ending)
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+
+ UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
+ }
+
+ return result;
+ }
+
+ return sequence;
+}
+
+DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
+Delete by side effect any elements of ALIST whose car is `equal' to KEY.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `equal' to KEY, there is no way to remove it by side effect;
+therefore, write `(setq foo (remassoc key foo))' to be sure of changing
+the value of `foo'.
+*/
+ (key, alist))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ internal_equal (key, XCAR (elt), 0)));
+ return alist;
+}
+
+Lisp_Object
+remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
+{
+ int speccount = specpdl_depth ();
+ specbind (Qinhibit_quit, Qt);
+ return unbind_to_1 (speccount, Fremassoc (key, alist));
+}
+
+DEFUN ("remassq", Fremassq, 2, 2, 0, /*
+Delete by side effect any elements of ALIST whose car is `eq' to KEY.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `eq' to KEY, there is no way to remove it by side effect;
+therefore, write `(setq foo (remassq key foo))' to be sure of changing
+the value of `foo'.
+*/
+ (key, alist))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
+ return alist;
+}
+
+/* no quit, no errors; be careful */
+
+Lisp_Object
+remassq_no_quit (Lisp_Object key, Lisp_Object alist)
+{
+ LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
+ return alist;
+}
+
+DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
+Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `equal' to VALUE, there is no way to remove it by side effect;
+therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
+the value of `foo'.
+*/
+ (value, alist))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ internal_equal (value, XCDR (elt), 0)));
+ return alist;
+}
+
+DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
+Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `eq' to VALUE, there is no way to remove it by side effect;
+therefore, write `(setq foo (remrassq value foo))' to be sure of changing
+the value of `foo'.
+*/
+ (value, alist))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
+ return alist;
+}
+
+/* Like Fremrassq, fast and unsafe; be careful */
+Lisp_Object
+remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
+{
+ LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
+ return alist;
+}
+
+/* Remove duplicate elements between START and END from LIST, a non-nil
+ list; if COPY is zero, do so destructively. Items to delete are selected
+ according to the algorithm used when :from-end t is passed to
+ #'delete-duplicates. Error if LIST is ill-formed or circular.
+
+ TEST and KEY are as in #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should
+ reflect them, having been initialised with get_check_match_function() or
+ get_check_test_function(). */
+static Lisp_Object
+list_delete_duplicates_from_end (Lisp_Object list,
+ check_test_func_t check_test,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Lisp_Object start,
+ Lisp_Object end, Boolint copy)
+{
+ Lisp_Object checking = Qnil, elt, tail, result = list;
+ Lisp_Object keyed, positioned, position_cons = Qnil, result_tail;
+ Elemcount len = XINT (Flength (list)), pos, starting = XINT (start);
+ Elemcount ending = (NILP (end) ? len : XINT (end)), greatest_pos_seen = -1;
+ Elemcount ii = 0;
+ struct gcpro gcpro1, gcpro2;
+
+ /* We can't delete (or remove) as we go, because that breaks START and
+ END. We could if END were nil, and that would change an ON(N + 2)
+ algorithm to an ON^2 algorithm; list_position_cons_before() would need to
+ be modified to return the cons *before* the one containing the item for
+ that. Here and now it doesn't matter, though, #'delete-duplicates is
+ relatively expensive no matter what. */
+ struct Lisp_Bit_Vector *deleting
+ = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ + (sizeof (long)
+ * (BIT_VECTOR_LONG_STORAGE (len)
+ - 1)));
+
+ check_sequence_range (list, start, end, make_integer (len));
+
+ deleting->size = len;
+ memset (&(deleting->bits), 0,
+ sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
+
+ GCPRO2 (tail, keyed);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len)
+ {
+ if (!(starting <= ii && ii <= ending) || bit_vector_bit (deleting, ii))
+ {
+ ii++;
+ continue;
+ }
+
+ keyed = KEY (key, elt);
+ checking = XCDR (tail);
+ pos = ii + 1;
+
+ while (!NILP ((positioned = list_position_cons_before
+ (&position_cons, keyed, checking, check_test,
+ test_not_unboundp, test, key, 0,
+ make_int (max (starting - pos, 0)),
+ make_int (ending - pos)))))
+ {
+ pos = XINT (positioned) + pos;
+ set_bit_vector_bit (deleting, pos, 1);
+ greatest_pos_seen = max (greatest_pos_seen, pos);
+ checking = NILP (position_cons) ?
+ XCDR (checking) : XCDR (XCDR (position_cons));
+ pos += 1;
+ }
+ ii++;
+ }
+ }
+
+ UNGCPRO;
+
+ ii = 0;
+
+ if (greatest_pos_seen > -1)
+ {
+ if (copy)
+ {
+ result = result_tail = Fcons (XCAR (list), Qnil);
+ list = XCDR (list);
+ ii = 1;
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len)
+ {
+ if (ii == greatest_pos_seen)
+ {
+ XSETCDR (result_tail, XCDR (tail));
+ break;
+ }
+ else if (!bit_vector_bit (deleting, ii))
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ ii++;
+ }
+ }
+ }
+ else
+ {
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt0, list,
+ bit_vector_bit (deleting, ii++));
+ }
+ }
+
+ return result;
+}
+
+DEFUN ("delete-duplicates", Fdelete_duplicates, 1, MANY, 0, /*
+Remove all duplicate elements from SEQUENCE, destructively.
+
+If SEQUENCE is a list and has duplicates, modify and return it. Note that
+SEQUENCE may start with an element to be deleted; because of this, if
+modifying a variable, be sure to write `(setq VARIABLE (delete-duplicates
+VARIABLE))' to be certain to have a list without duplicate elements.
+
+If SEQUENCE is an array and has duplicates, return a newly-allocated array
+of the same type comprising all unique elements of SEQUENCE.
+
+If there are no duplicate elements in SEQUENCE, return it unmodified.
+
+See `remove*' for the meaning of the keywords. See `remove-duplicates' for
+a non-destructive version of this function.
+
+arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence = args[0], tail = sequence, keyed = Qnil, elt = Qnil;
+ Lisp_Object elt0 = Qnil, positioned = Qnil, ignore = Qnil;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0, jj = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2;
+
+ PARSE_KEYWORDS (Fdelete_duplicates, nargs, args, 6,
+ (test, key, test_not, start, end, from_end),
+ (start = Qzero));
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ CHECK_KEY_ARGUMENT (key);
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ if (CONSP (sequence))
+ {
+ if (NILP (from_end))
+ {
+ Lisp_Object prev_tail = Qnil;
+ Elemcount deleted = 0;
+
+ GCPRO2 (tail, keyed);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (starting <= ii && ii < ending)
+ {
+ keyed = KEY (key, elt);
+ positioned
+ = list_position_cons_before (&ignore, keyed,
+ XCDR (tail), check_test,
+ test_not_unboundp, test, key,
+ 0, make_int (max (starting
+ - (ii + 1),
+ 0)),
+ make_int (ending
+ - (ii + 1)));
+ if (!NILP (positioned))
+ {
+ sequence = XCDR (tail);
+ deleted++;
+ }
+ else
+ {
+ break;
+ }
+ }
+ else
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt0, sequence, tail, len)
+ {
+ if (!(starting <= ii && ii <= ending))
+ {
+ prev_tail = tail;
+ ii++;
+ continue;
+ }
+
+ keyed = KEY (key, elt0);
+ positioned
+ = list_position_cons_before (&ignore, keyed, XCDR (tail),
+ check_test, test_not_unboundp,
+ test, key, 0,
+ make_int (max (starting
+ - (ii + 1), 0)),
+ make_int (ending - (ii + 1)));
+ if (!NILP (positioned))
+ {
+ /* We know this isn't the first iteration of the loop,
+ because we advanced above to the point where we have at
+ least one non-duplicate entry at the head of the
+ list. */
+ XSETCDR (prev_tail, XCDR (tail));
+ len = 0;
+ deleted++;
+ }
+ else
+ {
+ prev_tail = tail;
+ if (ii >= ending)
+ {
+ break;
+ }
+ }
+
+ ii++;
+ }
+ }
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end))))
+ {
+ check_sequence_range (args[0], start, end,
+ make_int (deleted
+ + XINT (Flength (args[0]))));
+ }
+ }
+ else
+ {
+ sequence = list_delete_duplicates_from_end (sequence, check_test,
+ test_not_unboundp,
+ test, key, start, end,
+ 0);
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ if (EQ (Qidentity, key))
+ {
+ /* We know all the elements will be characters; set check_test to
+ reflect that. This isn't useful if KEY is not #'identity, since
+ it may return non-characters for the elements. */
+ check_test = get_check_test_function (make_char ('a'),
+ &test, test_not,
+ Qnil, Qnil, key,
+ &test_not_unboundp);
+ }
+
+ if (NILP (from_end))
+ {
+ Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
+ Ibyte *staging = alloca_ibytes (byte_len), *staging_cursor = staging;
+ Ibyte *cursor = XSTRING_DATA (sequence), *startp = cursor;
+ Elemcount deleted = 0;
+
+ elt = Qnil;
+ GCPRO1 (elt);
+
+ while (cursor_offset < byte_len)
+ {
+ if (starting <= ii && ii < ending)
+ {
+ Ibyte *cursor0 = cursor;
+ Bytecount cursor0_offset;
+ Boolint delete_this = 0;
+
+ elt = KEY (key, make_char (itext_ichar (cursor)));
+ INC_IBYTEPTR (cursor0);
+ cursor0_offset = cursor0 - startp;
+
+ for (jj = ii + 1; jj < ending && cursor0_offset < byte_len;
+ jj++)
+ {
+ if (check_test (test, key, elt,
+ make_char (itext_ichar (cursor0)))
+ == test_not_unboundp)
+ {
+ delete_this = 1;
+ deleted++;
+ break;
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor0 = startp + cursor0_offset;
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor0))
+ {
+ mapping_interaction_error (Qdelete_duplicates,
+ sequence);
+ }
+
+ INC_IBYTEPTR (cursor0);
+ cursor0_offset = cursor0 - startp;
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (Qdelete_duplicates, sequence);
+ }
+
+ if (!delete_this)
+ {
+ staging_cursor
+ += itext_copy_ichar (cursor, staging_cursor);
+
+ }
+ }
+ else
+ {
+ staging_cursor += itext_copy_ichar (cursor, staging_cursor);
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+
+ if (0 != deleted)
+ {
+ sequence = make_string (staging, staging_cursor - staging);
+ }
+ }
+ else
+ {
+ Elemcount deleted = 0;
+ Ibyte *staging = alloca_ibytes ((len = string_char_length (sequence))
+ * MAX_ICHAR_LEN);
+ Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence);
+ Ibyte *endp = startp + XSTRING_LENGTH (sequence);
+ struct Lisp_Bit_Vector *deleting
+ = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ + (sizeof (long)
+ * (BIT_VECTOR_LONG_STORAGE (len)
+ - 1)));
+
+ check_sequence_range (sequence, start, end, make_integer (len));
+
+ /* For the from_end t case; transform contents to an array with
+ elements addressable in constant time, use the same algorithm
+ as for vectors. */
+ deleting->size = len;
+ memset (&(deleting->bits), 0,
+ sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
+
+ while (startp < endp)
+ {
+ itext_copy_ichar (startp, staging + (ii * MAX_ICHAR_LEN));
+ INC_IBYTEPTR (startp);
+ ii++;
+ }
+
+ GCPRO1 (elt);
+
+ ending = min (ending, len);
+
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ elt = KEY (key, make_char (itext_ichar (staging +
+ (ii * MAX_ICHAR_LEN))));
+ for (jj = ii - 1; jj >= starting; jj--)
+ {
+ if (check_test (test, key, elt,
+ make_char (itext_ichar
+ (staging + (jj * MAX_ICHAR_LEN))))
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if (0 != deleted)
+ {
+ startp = XSTRING_DATA (sequence);
+
+ for (ii = 0; ii < len; ii++)
+ {
+ if (!bit_vector_bit (deleting, ii))
+ {
+ staging_cursor
+ += itext_copy_ichar (startp, staging_cursor);
+ }
+
+ INC_IBYTEPTR (startp);
+ }
+
+ sequence = make_string (staging, staging_cursor - staging);
+ }
+ }
+ }
+ else if (VECTORP (sequence))
+ {
+ Elemcount deleted = 0;
+ Lisp_Object *content = XVECTOR_DATA (sequence);
+ struct Lisp_Bit_Vector *deleting;
+
+ len = XVECTOR_LENGTH (sequence);
+ check_sequence_range (sequence, start, end, make_integer (len));
+
+ deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ + (sizeof (long)
+ * (BIT_VECTOR_LONG_STORAGE (len)
+ - 1)));
+ deleting->size = len;
+ memset (&(deleting->bits), 0,
+ sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
+
+ GCPRO1 (elt);
+
+ ending = min (ending, len);
+
+ if (NILP (from_end))
+ {
+ for (ii = starting; ii < ending; ii++)
+ {
+ elt = KEY (key, content[ii]);
+
+ for (jj = ii + 1; jj < ending; jj++)
+ {
+ if (check_test (test, key, elt, content[jj])
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+ }
+ else
+ {
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ elt = KEY (key, content[ii]);
+
+ for (jj = ii - 1; jj >= starting; jj--)
+ {
+ if (check_test (test, key, elt, content[jj])
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if (deleted)
+ {
+ Lisp_Object res = make_vector (len - deleted, Qnil),
+ *res_content = XVECTOR_DATA (res);
+
+ for (ii = jj = 0; ii < len; ii++)
+ {
+ if (!bit_vector_bit (deleting, ii))
+ {
+ res_content[jj++] = content[ii];
+ }
+ }
+
+ sequence = res;
+ }
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
+ Elemcount deleted = 0;
+ /* I'm a little irritated at this. Basically, the only reasonable
+ thing delete-duplicates should do if handed a bit vector is return
+ something of maximum length two and minimum length 0 (because
+ that's the possible number of distinct elements if EQ is regarded
+ as identity, which it should be). But to support arbitrary TEST
+ and KEY arguments, which may be non-deterministic from our
+ perspective, we need the same algorithm as for vectors. */
+ struct Lisp_Bit_Vector *deleting;
+
+ len = bit_vector_length (bv);
+
+ if (EQ (Qidentity, key))
+ {
+ /* We know all the elements will be bits; set check_test to
+ reflect that. This isn't useful if KEY is not #'identity, since
+ it may return non-bits for the elements. */
+ check_test = get_check_test_function (Qzero, &test, test_not,
+ Qnil, Qnil, key,
+ &test_not_unboundp);
+ }
+
+ check_sequence_range (sequence, start, end, make_integer (len));
+
+ deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ + (sizeof (long)
+ * (BIT_VECTOR_LONG_STORAGE (len)
+ - 1)));
+ deleting->size = len;
+ memset (&(deleting->bits), 0,
+ sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
+
+ ending = min (ending, len);
+
+ GCPRO1 (elt);
+
+ if (NILP (from_end))
+ {
+ for (ii = starting; ii < ending; ii++)
+ {
+ elt = KEY (key, make_int (bit_vector_bit (bv, ii)));
+
+ for (jj = ii + 1; jj < ending; jj++)
+ {
+ if (check_test (test, key, elt,
+ make_int (bit_vector_bit (bv, jj)))
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+ }
+ else
+ {
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ elt = KEY (key, make_int (bit_vector_bit (bv, ii)));
+
+ for (jj = ii - 1; jj >= starting; jj--)
+ {
+ if (check_test (test, key, elt,
+ make_int (bit_vector_bit (bv, jj)))
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if (deleted)
+ {
+ Lisp_Object res = make_bit_vector (len - deleted, Qzero);
+ Lisp_Bit_Vector *resbv = XBIT_VECTOR (res);
+
+ for (ii = jj = 0; ii < len; ii++)
+ {
+ if (!bit_vector_bit (deleting, ii))
+ {
+ set_bit_vector_bit (resbv, jj++, bit_vector_bit (bv, ii));
+ }
+ }
+
+ sequence = res;
+ }
+ }
+
+ return sequence;
+}
+
+DEFUN ("remove-duplicates", Fremove_duplicates, 1, MANY, 0, /*
+Remove duplicate elements from SEQUENCE, non-destructively.
+
+If there are no duplicate elements in SEQUENCE, return it unmodified;
+otherwise, return a new object. If SEQUENCE is a list, the new object may
+share list structure with SEQUENCE.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence = args[0], tail = sequence, keyed, positioned = Qnil;
+ Lisp_Object result = sequence, result_tail = result, cursor = Qnil;
+ Lisp_Object cons_with_shared_tail = Qnil, elt, elt0;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS (Fremove_duplicates, nargs, args, 6,
+ (test, key, test_not, start, end, from_end),
+ (start = Qzero));
+
+ CHECK_SEQUENCE (sequence);
+
+ if (!CONSP (sequence))
+ {
+ return Fdelete_duplicates (nargs, args);
+ }
+
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (NILP (key))
+ {
+ key = Qidentity;
+ }
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ if (NILP (from_end))
+ {
+ Lisp_Object ignore = Qnil;
+
+ GCPRO3 (tail, keyed, result);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (starting <= ii && ii <= ending)
+ {
+ keyed = KEY (key, elt);
+ positioned
+ = list_position_cons_before (&ignore, keyed, XCDR (tail),
+ check_test, test_not_unboundp,
+ test, key, 0,
+ make_int (max (starting
+ - (ii + 1), 0)),
+ make_int (ending - (ii + 1)));
+ if (!NILP (positioned))
+ {
+ sequence = result = result_tail = XCDR (tail);
+ }
+ else
+ {
+ break;
+ }
+ }
+ else
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt0, sequence, tail, len)
+ {
+ if (!(starting <= ii && ii <= ending))
+ {
+ ii++;
+ continue;
+ }
+
+ /* For this algorithm, each time we encounter an object to be
+ removed, copy the output list from the tail beyond the last
+ removed cons to this one. Otherwise, the tail of the output list
+ is shared with the input list, which is OK. */
+
+ keyed = KEY (key, elt0);
+ positioned
+ = list_position_cons_before (&ignore, keyed, XCDR (tail),
+ check_test, test_not_unboundp,
+ test, key, 0,
+ make_int (max (starting - (ii + 1),
+ 0)),
+ make_int (ending - (ii + 1)));
+ if (!NILP (positioned))
+ {
+ if (EQ (result, sequence))
+ {
+ result = cons_with_shared_tail
+ = Fcons (XCAR (sequence), XCDR (sequence));
+ }
+
+ result_tail = cons_with_shared_tail;
+ cursor = XCDR (cons_with_shared_tail);
+
+ while (!EQ (cursor, tail) && !NILP (cursor))
+ {
+ XSETCDR (result_tail, Fcons (XCAR (cursor), Qnil));
+ result_tail = XCDR (result_tail);
+ cursor = XCDR (cursor);
+ }
+
+ XSETCDR (result_tail, XCDR (tail));
+ cons_with_shared_tail = result_tail;
+ }
+
+ ii++;
+ }
+ }
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end))))
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
+ }
+ }
+ else
+ {
+ result = list_delete_duplicates_from_end (sequence, check_test,
+ test_not_unboundp, test, key,
+ start, end, 1);
+ }
+
+ return result;
+}
+#undef KEY
+
+DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
+Reverse SEQUENCE, destructively.
+
+Return the beginning of the reversed sequence, which will be a distinct Lisp
+object if SEQUENCE is a list with length greater than one. See also
+`reverse', the non-destructive version of this function.
+*/
+ (sequence))
+{
+ CHECK_SEQUENCE (sequence);
+
+ if (CONSP (sequence))
+ {
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object prev = Qnil;
+ Lisp_Object tail = sequence;
+
+ /* We gcpro our args; see `nconc' */
+ GCPRO2 (prev, tail);
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object next;
+ CONCHECK_CONS (tail);
+ next = XCDR (tail);
+ XCDR (tail) = prev;
+ prev = tail;
+ tail = next;
+ }
+ UNGCPRO;
+ return prev;
+ }
+ else if (VECTORP (sequence))
+ {
+ Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
+ Elemcount half = length / 2;
+ Lisp_Object swap = Qnil;
+ CHECK_LISP_WRITEABLE (sequence);
+
+ while (ii > half)
+ {
+ swap = XVECTOR_DATA (sequence) [length - ii];
+ XVECTOR_DATA (sequence) [length - ii]
+ = XVECTOR_DATA (sequence) [ii - 1];
+ XVECTOR_DATA (sequence) [ii - 1] = swap;
+ --ii;
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ Elemcount length = XSTRING_LENGTH (sequence);
+ Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
+ Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
+
+ CHECK_LISP_WRITEABLE (sequence);
+ while (cursor < endp)
+ {
+ staging_end -= itext_ichar_len (cursor);
+ itext_copy_ichar (cursor, staging_end);
+ INC_IBYTEPTR (cursor);
+ }
+
+ assert (staging == staging_end);
+
+ memcpy (XSTRING_DATA (sequence), staging, length);
+ init_string_ascii_begin (sequence);
+ bump_string_modiff (sequence);
+ sledgehammer_check_ascii_begin (sequence);
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
+ Elemcount length = bit_vector_length (bv), ii = length;
+ Elemcount half = length / 2;
+ int swap = 0;
+
+ CHECK_LISP_WRITEABLE (sequence);
+ while (ii > half)
+ {
+ swap = bit_vector_bit (bv, length - ii);
+ set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1));
+ set_bit_vector_bit (bv, ii - 1, swap);
+ --ii;
+ }
+ }
+ else
+ {
+ assert (NILP (sequence));
+ }
+
+ return sequence;
+}
+
+DEFUN ("reverse", Freverse, 1, 1, 0, /*
+Reverse SEQUENCE, copying. Return the reversed sequence.
+See also the function `nreverse', which is used more often.
+*/
+ (sequence))
+{
+ Lisp_Object result = Qnil;
+
+ CHECK_SEQUENCE (sequence);
+
+ if (CONSP (sequence))
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence)
+ {
+ result = Fcons (elt, result);
+ }
+ }
+ else if (VECTORP (sequence))
+ {
+ Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
+ Lisp_Object *staging = alloca_array (Lisp_Object, length);
+
+ while (ii > 0)
+ {
+ staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1];
+ --ii;
+ }
+
+ result = Fvector (length, staging);
+ }
+ else if (STRINGP (sequence))
+ {
+ Elemcount length = XSTRING_LENGTH (sequence);
+ Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
+ Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
+
+ while (cursor < endp)
+ {
+ staging_end -= itext_ichar_len (cursor);
+ itext_copy_ichar (cursor, staging_end);
+ INC_IBYTEPTR (cursor);
+ }
+
+ assert (staging == staging_end);
+
+ result = make_string (staging, length);
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res;
+ Elemcount length = bit_vector_length (bv), ii = length;
+
+ result = make_bit_vector (length, Qzero);
+ res = XBIT_VECTOR (result);
+
+ while (ii > 0)
+ {
+ set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1));
+ --ii;
+ }
+ }
+ else
+ {
+ assert (NILP (sequence));
+ }
+
+ return result;
+}
+
+static Lisp_Object
+c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
+ Lisp_Object pred, Lisp_Object key_func)
+{
+ struct gcpro gcpro1;
+ Lisp_Object args[3];
+
+ /* We could use call2() and call3() here, but we're called O(nlogn) times
+ for a sequence of length n, it make some sense to inline them. */
+ args[0] = key_func;
+ args[1] = obj1;
+ args[2] = Qnil;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+
+ obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+
+ args[1] = obj2;
+ obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+
+ args[0] = pred;
+ args[1] = obj1;
+ args[2] = obj2;
+
+ RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
+}
+
+static Lisp_Object
+c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
+ Lisp_Object pred, Lisp_Object UNUSED (key_func))
+{
+ struct gcpro gcpro1;
+ Lisp_Object args[3];
+
+ /* This is (almost) the implementation of call2, it makes some sense to
+ inline it here. */
+ args[0] = pred;
+ args[1] = obj1;
+ args[2] = obj2;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+
+ RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
+}
+
+Lisp_Object
+list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
+ Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func)
+{
+ Lisp_Object value;
+ Lisp_Object tail;
+ Lisp_Object tem;
+ Lisp_Object l1, l2;
+ Lisp_Object tortoises[2];
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
+ int l1_count = 0, l2_count = 0;
+
+ l1 = org_l1;
+ l2 = org_l2;
+ tail = Qnil;
+ value = Qnil;
+ tortoises[0] = org_l1;
+ tortoises[1] = org_l2;
+
+ if (NULL == c_predicate)
+ {
+ c_predicate = EQ (key_func, Qidentity) ?
+ c_merge_predicate_nokey : c_merge_predicate_key;
+ }
+
+ /* It is sufficient to protect org_l1 and org_l2.
+ When l1 and l2 are updated, we copy the new values
+ back into the org_ vars. */
+
+ GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
+ gcpro5.nvars = 2;
+
+ while (1)
+ {
+ if (NILP (l1))
+ {
+ UNGCPRO;
+ if (NILP (tail))
+ return l2;
+ Fsetcdr (tail, l2);
+ return value;
+ }
+ if (NILP (l2))
+ {
+ UNGCPRO;
+ if (NILP (tail))
+ return l1;
+ Fsetcdr (tail, l1);
+ return value;
+ }
+
+ if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func)))
+ {
+ tem = l1;
+ l1 = Fcdr (l1);
+ org_l1 = l1;
+
+ if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (l1_count & 1)
+ {
+ if (!CONSP (tortoises[0]))
+ {
+ mapping_interaction_error (Qmerge, tortoises[0]);
+ }
+
+ tortoises[0] = XCDR (tortoises[0]);
+ }
+
+ if (EQ (org_l1, tortoises[0]))
+ {
+ signal_circular_list_error (org_l1);
+ }
+ }
+ }
+ else
+ {
+ tem = l2;
+ l2 = Fcdr (l2);
+ org_l2 = l2;
+
+ if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (l2_count & 1)
+ {
+ if (!CONSP (tortoises[1]))
+ {
+ mapping_interaction_error (Qmerge, tortoises[1]);
+ }
+
+ tortoises[1] = XCDR (tortoises[1]);
+ }
+
+ if (EQ (org_l2, tortoises[1]))
+ {
+ signal_circular_list_error (org_l2);
+ }
+ }
+ }
+
+ if (NILP (tail))
+ value = tem;
+ else
+ Fsetcdr (tail, tem);
+
+ tail = tem;
+ }
+}
+
+static void
+array_merge (Lisp_Object *dest, Elemcount dest_len,
+ Lisp_Object *front, Elemcount front_len,
+ Lisp_Object *back, Elemcount back_len,
+ Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func)
+{
+ Elemcount ii, fronting, backing;
+ Lisp_Object *front_staging = front;
+ Lisp_Object *back_staging = back;
+ struct gcpro gcpro1, gcpro2;
+
+ assert (dest_len == (back_len + front_len));
+
+ if (0 == dest_len)
+ {
+ return;
+ }
+
+ if (front >= dest && front < (dest + dest_len))
+ {
+ front_staging = alloca_array (Lisp_Object, front_len);
+
+ for (ii = 0; ii < front_len; ++ii)
+ {
+ front_staging[ii] = front[ii];
+ }
+ }
+
+ if (back >= dest && back < (dest + dest_len))
+ {
+ back_staging = alloca_array (Lisp_Object, back_len);
+
+ for (ii = 0; ii < back_len; ++ii)
+ {
+ back_staging[ii] = back[ii];
+ }
+ }
+
+ GCPRO2 (front_staging[0], back_staging[0]);
+ gcpro1.nvars = front_len;
+ gcpro2.nvars = back_len;
+
+ for (ii = fronting = backing = 0; ii < dest_len; ++ii)
+ {
+ if (fronting >= front_len)
+ {
+ while (ii < dest_len)
+ {
+ dest[ii] = back_staging[backing];
+ ++ii, ++backing;
+ }
+ UNGCPRO;
+ return;
+ }
+
+ if (backing >= back_len)
+ {
+ while (ii < dest_len)
+ {
+ dest[ii] = front_staging[fronting];
+ ++ii, ++fronting;
+ }
+ UNGCPRO;
+ return;
+ }
+
+ if (NILP (c_predicate (back_staging[backing], front_staging[fronting],
+ predicate, key_func)))
+ {
+ dest[ii] = front_staging[fronting];
+ ++fronting;
+ }
+ else
+ {
+ dest[ii] = back_staging[backing];
+ ++backing;
+ }
+ }
+
+ UNGCPRO;
+}
+
+static Lisp_Object
+list_array_merge_into_list (Lisp_Object list,
+ Lisp_Object *array, Elemcount array_len,
+ Lisp_Object (*c_predicate) (Lisp_Object,
+ Lisp_Object,
+ Lisp_Object,
+ Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func,
+ Boolint reverse_order)
+{
+ Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
+ Elemcount array_index = 0;
+ int looped = 0;
+
+ GCPRO4 (list, tail, value, tortoise);
+
+ while (1)
+ {
+ if (NILP (list))
+ {
+ UNGCPRO;
+
+ if (NILP (tail))
+ {
+ return Flist (array_len, array);
+ }
+
+ Fsetcdr (tail, Flist (array_len - array_index, array + array_index));
+ return value;
+ }
+
+ if (array_index >= array_len)
+ {
+ UNGCPRO;
+ if (NILP (tail))
+ {
+ return list;
+ }
+
+ Fsetcdr (tail, list);
+ return value;
+ }
+
+
+ if (reverse_order ?
+ !NILP (c_predicate (Fcar (list), array [array_index], predicate,
+ key_func)) :
+ NILP (c_predicate (array [array_index], Fcar (list), predicate,
+ key_func)))
+ {
+ if (NILP (tail))
+ {
+ value = tail = list;
+ }
+ else
+ {
+ Fsetcdr (tail, list);
+ tail = XCDR (tail);
+ }
+
+ list = Fcdr (list);
+ }
+ else
+ {
+ if (NILP (tail))
+ {
+ value = tail = Fcons (array [array_index], Qnil);
+ }
+ else
+ {
+ Fsetcdr (tail, Fcons (array [array_index], tail));
+ tail = XCDR (tail);
+ }
+ ++array_index;
+ }
+
+ if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (looped & 1)
+ {
+ tortoise = XCDR (tortoise);
+ }
+
+ if (EQ (list, tortoise))
+ {
+ signal_circular_list_error (list);
+ }
+ }
+ }
+}
+
+static void
+list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
+ Lisp_Object list_one, Lisp_Object list_two,
+ Lisp_Object (*c_predicate) (Lisp_Object,
+ Lisp_Object,
+ Lisp_Object,
+ Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func)
+{
+ Elemcount output_index = 0;
+
+ while (output_index < output_len)
+ {
+ if (NILP (list_one))
+ {
+ while (output_index < output_len)
+ {
+ output [output_index] = Fcar (list_two);
+ list_two = Fcdr (list_two), ++output_index;
+ }
+ return;
+ }
+
+ if (NILP (list_two))
+ {
+ while (output_index < output_len)
+ {
+ output [output_index] = Fcar (list_one);
+ list_one = Fcdr (list_one), ++output_index;
+ }
+ return;
+ }
+
+ if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate,
+ key_func)))
+ {
+ output [output_index] = XCAR (list_one);
+ list_one = XCDR (list_one);
+ }
+ else
+ {
+ output [output_index] = XCAR (list_two);
+ list_two = XCDR (list_two);
+ }
+
+ ++output_index;
+
+ /* No need to check for circularity. */
+ }
+}
+
+static void
+list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
+ Lisp_Object list,
+ Lisp_Object *array, Elemcount array_len,
+ Lisp_Object (*c_predicate) (Lisp_Object,
+ Lisp_Object,
+ Lisp_Object,
+ Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func,
+ Boolint reverse_order)
+{
+ Elemcount output_index = 0, array_index = 0;
+
+ while (output_index < output_len)
+ {
+ if (NILP (list))
+ {
+ if (array_len - array_index != output_len - output_index)
+ {
+ mapping_interaction_error (Qmerge, list);
+ }
+
+ while (array_index < array_len)
+ {
+ output [output_index++] = array [array_index++];
+ }
+
+ return;
+ }
+
+ if (array_index >= array_len)
+ {
+ while (output_index < output_len)
+ {
+ output [output_index++] = Fcar (list);
+ list = Fcdr (list);
+ }
+
+ return;
+ }
+
+ if (reverse_order ?
+ !NILP (c_predicate (Fcar (list), array [array_index], predicate,
+ key_func)) :
+ NILP (c_predicate (array [array_index], Fcar (list), predicate,
+ key_func)))
+ {
+ output [output_index] = XCAR (list);
+ list = XCDR (list);
+ }
+ else
+ {
+ output [output_index] = array [array_index];
+ ++array_index;
+ }
+
+ ++output_index;
+ }
+}
+
+#define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \
+ do { \
+ c_array = alloca_array (Lisp_Object, len); \
+ for (counter = 0; counter < len; ++counter) \
+ { \
+ c_array[counter] = make_char (itext_ichar (strdata)); \
+ INC_IBYTEPTR (strdata); \
+ } \
+ } while (0)
+
+#define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \
+ c_array = alloca_array (Lisp_Object, len); \
+ for (counter = 0; counter < len; ++counter) \
+ { \
+ c_array[counter] = make_int (bit_vector_bit (v, counter)); \
+ } \
+ } while (0)
+
DEFUN ("merge", Fmerge, 4, MANY, 0, /*
Destructively merge SEQUENCE-ONE and SEQUENCE-TWO, producing a new sequence.
＠＠ -3944,7 +6396,7 ＠＠
int
internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- if (depth > 200)
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
stack_overflow ("Stack overflow in equal", Qunbound);
QUIT;
if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
＠＠ -3989,7 +6441,7 ＠＠
int
internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- if (depth > 200)
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
stack_overflow ("Stack overflow in equalp", Qunbound);
QUIT;
＠＠ -4065,7 +6517,7 ＠＠
static int
internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- if (depth > 200)
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
stack_overflow ("Stack overflow in equal", Qunbound);
QUIT;
if (HACKEQ_UNSAFE (obj1, obj2))
＠＠ -4231,21 +6683,23 ＠＠
{
Elemcount counting = 0;
- EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
- {
- if (counting >= starting)
- {
- if (counting < ending)
- {
- XSETCAR (tail, item);
- }
- else if (counting == ending)
- {
- break;
- }
- }
- ++counting;
- }
+ {
+ EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
+ {
+ if (counting >= starting)
+ {
+ if (counting < ending)
+ {
+ XSETCAR (tail, item);
+ }
+ else if (counting == ending)
+ {
+ break;
+ }
+ }
+ ++counting;
+ }
+ }
if (counting < starting || (counting != ending && !NILP (end)))
{
＠＠ -6079,6 +8533,8 ＠＠
*p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor;
Charcount ii = 0, len1 = string_char_length (sequence1);
+ check_sequence_range (sequence1, start1, end1, make_int (len1));
+
while (ii < starting2 && p2 < p2end)
{
INC_IBYTEPTR (p2);
＠＠ -6188,6 +8644,2414 ＠＠
return result;
}
+DEFUN ("nsubstitute", Fnsubstitute, 3, MANY, 0, /*
+Substitute NEW for OLD in SEQUENCE.
+
+This is a destructive function; it reuses the storage of SEQUENCE whenever
+possible. See `remove*' for the meaning of the keywords.
+
+arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil;
+ Lisp_Object object_, position0;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0;
+ Elemcount len, ii = 0, counting = EMACS_INT_MAX, presenting = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1;
+
+ PARSE_KEYWORDS (Fnsubstitute, nargs, args, 9,
+ (test, if_, if_not, test_not, key, start, end, count,
+ from_end), (start = Qzero));
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ if (BIGNUMP (count))
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
+ }
+ else
+ {
+ counting = XINT (count);
+ }
+
+ if (counting <= 0)
+ {
+ return sequence;
+ }
+ }
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ if (CONSP (sequence))
+ {
+ Lisp_Object elt;
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ Lisp_Object present = count_with_tail (&elt, nargs - 1, args + 1,
+ Qnsubstitute);
+
+ if (ZEROP (present))
+ {
+ return sequence;
+ }
+
+ presenting = XINT (present);
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ GCPRO1 (tail);
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (!(ii < ending))
+ {
+ break;
+ }
+
+ if (starting <= ii &&
+ check_test (test, key, item, elt) == test_not_unboundp
+ && (presenting ? encountered++ >= presenting
+: encountered++ < counting))
+ {
+ CHECK_LISP_WRITEABLE (tail);
+ XSETCAR (tail, new_);
+ }
+ else if (!presenting && encountered >= counting)
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end)))
+ && encountered < counting)
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ Ibyte *staging, new_bytes[MAX_ICHAR_LEN], *staging_cursor;
+ Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
+ Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence);
+ Bytecount new_len;
+ Lisp_Object character;
+
+ CHECK_CHAR_COERCE_INT (new_);
+
+ new_len = set_itext_ichar (new_bytes, XCHAR (new_));
+
+ /* Worst case scenario; new char is four octets long, all the old ones
+ were one octet long, all the old ones match. */
+ staging = alloca_ibytes (XSTRING_LENGTH (sequence) * new_len);
+ staging_cursor = staging;
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ Lisp_Object present = count_with_tail (&character, nargs - 1,
+ args + 1, Qnsubstitute);
+
+ if (ZEROP (present))
+ {
+ return sequence;
+ }
+
+ presenting = XINT (present);
+
+ /* If there are fewer items in the string than we have
+ permission to change, we don't need to differentiate
+ between the :from-end nil and :from-end t
+ cases. Otherwise, presenting is the number of matching
+ items we need to ignore before we start to change. */
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ ii = 0;
+ while (cursor_offset < byte_len && ii < ending)
+ {
+ if (ii >= starting)
+ {
+ character = make_char (itext_ichar (cursor));
+
+ if ((check_test (test, key, item, character)
+ == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting :
+ encountered++ < counting))
+ {
+ staging_cursor
+ += itext_copy_ichar (new_bytes, staging_cursor);
+ }
+ else
+ {
+ staging_cursor
+ += itext_copy_ichar (cursor, staging_cursor);
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (Qnsubstitute, sequence);
+ }
+ }
+ else
+ {
+ staging_cursor += itext_copy_ichar (cursor, staging_cursor);
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+
+ if (0 != encountered)
+ {
+ CHECK_LISP_WRITEABLE (sequence);
+ replace_string_range (sequence, Qzero, make_int (ii),
+ staging, staging_cursor);
+ }
+ }
+ else
+ {
+ Elemcount positioning;
+ Lisp_Object object = Qnil;
+
+ len = XINT (Flength (sequence));
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ position0 = position (&object, item, sequence, check_test,
+ test_not_unboundp, test, key, start, end, from_end,
+ Qnil, Qnsubstitute);
+
+ if (NILP (position0))
+ {
+ return sequence;
+ }
+
+ positioning = XINT (position0);
+ ending = min (len, ending);
+
+ Faset (sequence, position0, new_);
+ encountered = 1;
+
+ if (NILP (from_end))
+ {
+ for (ii = positioning + 1; ii < ending; ii++)
+ {
+ object_ = Faref (sequence, make_int (ii));
+
+ if (check_test (test, key, item, object_) == test_not_unboundp
+ && encountered++ < counting)
+ {
+ Faset (sequence, make_int (ii), new_);
+ }
+ else if (encountered == counting)
+ {
+ break;
+ }
+ }
+ }
+ else
+ {
+ for (ii = positioning - 1; ii >= starting; ii--)
+ {
+ object_ = Faref (sequence, make_int (ii));
+
+ if (check_test (test, key, item, object_) == test_not_unboundp
+ && encountered++ < counting)
+ {
+ Faset (sequence, make_int (ii), new_);
+ }
+ else if (encountered == counting)
+ {
+ break;
+ }
+ }
+ }
+ }
+
+ return sequence;
+}
+
+DEFUN ("substitute", Fsubstitute, 3, MANY, 0, /*
+Substitute NEW for OLD in SEQUENCE.
+
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) COUNT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil;
+ Lisp_Object elt, tailing = Qnil, result = Qnil, result_tail = Qnil;
+ Lisp_Object object, position0, matched_count;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0;
+ Elemcount len, ii = 0, counting = EMACS_INT_MAX, presenting = 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));
+
+ CHECK_SEQUENCE (sequence);
+
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ 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 (BIGNUMP (count))
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
+ }
+ else
+ {
+ counting = XINT (count);
+ }
+
+ if (counting <= 0)
+ {
+ return sequence;
+ }
+ }
+ }
+
+ if (!CONSP (sequence))
+ {
+ position0 = position (&object, item, sequence, check_test,
+ test_not_unboundp, test, key, start, end, from_end,
+ Qnil, Qsubstitute);
+
+ if (NILP (position0))
+ {
+ return sequence;
+ }
+ else
+ {
+ args[2] = Fcopy_sequence (sequence);
+ return Fnsubstitute (nargs, args);
+ }
+ }
+
+ matched_count = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute);
+
+ if (ZEROP (matched_count))
+ {
+ return sequence;
+ }
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ presenting = XINT (matched_count);
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ GCPRO1 (tailing);
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tailing, len)
+ {
+ if (EQ (tail, tailing))
+ {
+ if (NILP (result))
+ {
+ RETURN_UNGCPRO (XCDR (tail));
+ }
+
+ XSETCDR (result_tail, XCDR (tail));
+ RETURN_UNGCPRO (result);
+ }
+ else if (starting <= ii && ii < ending &&
+ (check_test (test, key, item, elt) == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting
+: encountered++ < counting))
+ {
+ if (NILP (result))
+ {
+ result = result_tail = Fcons (new_, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (new_, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+
+ if (ii == ending)
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+ UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
+ }
+
+ return result;
+}
+
+static Lisp_Object
+subst (Lisp_Object new_, Lisp_Object old, Lisp_Object tree, int depth)
+{
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
+ {
+ stack_overflow ("Stack overflow in subst", tree);
+ }
+
+ if (EQ (tree, old))
+ {
+ return new_;
+ }
+ else if (CONSP (tree))
+ {
+ Lisp_Object aa = subst (new_, old, XCAR (tree), depth + 1);
+ Lisp_Object dd = subst (new_, old, XCDR (tree), depth + 1);
+
+ if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree)))
+ {
+ return tree;
+ }
+ else
+ {
+ return Fcons (aa, dd);
+ }
+ }
+ else
+ {
+ return tree;
+ }
+}
+
+static Lisp_Object
+sublis (Lisp_Object alist, Lisp_Object tree,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key, int depth)
+{
+ Lisp_Object keyed = KEY (key, tree), tailed = alist, aa, dd;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
+ {
+ stack_overflow ("Stack overflow in sublis", tree);
+ }
+
+ GCPRO3 (tailed, alist, tree);
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, elt_car, keyed) == test_not_unboundp)
+ {
+ /* Don't use elt_cdr, it is helpful to allow TEST or KEY to
+ modify the alist while it executes. */
+ RETURN_UNGCPRO (XCDR (elt));
+ }
+ }
+ }
+ if (!CONSP (tree))
+ {
+ RETURN_UNGCPRO (tree);
+ }
+
+ aa = sublis (alist, XCAR (tree), check_test, test_not_unboundp, test, key,
+ depth + 1);
+ dd = sublis (alist, XCDR (tree), check_test, test_not_unboundp, test, key,
+ depth + 1);
+
+ if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree)))
+ {
+ RETURN_UNGCPRO (tree);
+ }
+
+ RETURN_UNGCPRO (Fcons (aa, dd));
+}
+
+DEFUN ("sublis", Fsublis, 2, MANY, 0, /*
+Perform substitutions indicated by ALIST in TREE (non-destructively).
+Return a copy of TREE with all matching elements replaced.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object alist = args[0], tree = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fsublis, nargs, args, 5, (test, if_, test_not, if_not, key),
+ (key = Qidentity));
+
+ if (NILP (key))
+ {
+ key = Qidentity;
+ }
+
+ get_check_match_function (&test, test_not, if_, if_not,
+ /* sublis() is going to apply the key, don't ask
+ for a match function that will do it for
+ us. */
+ Qidentity, &test_not_unboundp, &check_test);
+
+ if (CONSP (alist) && NILP (XCDR (alist)) && CONSP (XCAR (alist))
+ && EQ (key, Qidentity) && 1 == test_not_unboundp
+ && (check_eq_nokey == check_test ||
+ (check_eql_nokey == check_test &&
+ !NON_FIXNUM_NUMBER_P (XCAR (XCAR (alist))))))
+ {
+ /* #'subst with #'eq is very cheap indeed; call it. */
+ return subst (XCDR (XCAR (alist)), XCAR (XCAR (alist)), tree, 0);
+ }
+
+ return sublis (alist, tree, check_test, test_not_unboundp, test, key, 0);
+}
+
+static Lisp_Object
+nsublis (Lisp_Object alist, Lisp_Object tree,
+ check_test_func_t check_test,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key, int depth)
+{
+ Lisp_Object tree_saved = tree, tailed = alist, tortoise = tree, keyed = Qnil;
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
+ int count = 0;
+
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
+ {
+ stack_overflow ("Stack overflow in nsublis", tree);
+ }
+
+ GCPRO4 (tailed, alist, tree_saved, keyed);
+
+ while (CONSP (tree))
+ {
+ Boolint replaced = 0;
+ keyed = KEY (key, XCAR (tree));
+
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, elt_car, keyed) == test_not_unboundp)
+ {
+ CHECK_LISP_WRITEABLE (tree);
+ /* See comment in sublis() on using elt_cdr. */
+ XSETCAR (tree, XCDR (elt));
+ replaced = 1;
+ break;
+ }
+ }
+ }
+
+ if (!replaced)
+ {
+ if (CONSP (XCAR (tree)))
+ {
+ nsublis (alist, XCAR (tree), check_test, test_not_unboundp,
+ test, key, depth + 1);
+ }
+ }
+
+ keyed = KEY (key, XCDR (tree));
+ replaced = 0;
+
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, elt_car, keyed) == test_not_unboundp)
+ {
+ CHECK_LISP_WRITEABLE (tree);
+ /* See comment in sublis() on using elt_cdr. */
+ XSETCDR (tree, XCDR (elt));
+ tree = Qnil;
+ break;
+ }
+ }
+ }
+
+ if (!NILP (tree))
+ {
+ tree = XCDR (tree);
+ }
+
+ if (++count > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (count & 1)
+ {
+ tortoise = XCDR (tortoise);
+ }
+
+ if (EQ (tortoise, tree))
+ {
+ signal_circular_list_error (tree);
+ }
+ }
+ }
+
+ RETURN_UNGCPRO (tree_saved);
+}
+
+DEFUN ("nsublis", Fnsublis, 2, MANY, 0, /*
+Perform substitutions indicated by ALIST in TREE (destructively).
+Any matching element of TREE is changed via a call to `setcar'.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object alist = args[0], tree = args[1], tailed = Qnil, keyed = Qnil;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2;
+
+ PARSE_KEYWORDS (Fnsublis, nargs, args, 5, (test, if_, test_not, if_not, key),
+ (key = Qidentity));
+
+ if (NILP (key))
+ {
+ key = Qidentity;
+ }
+
+ get_check_match_function (&test, test_not, if_, if_not,
+ /* nsublis() is going to apply the key, don't ask
+ for a match function that will do it for
+ us. */
+ Qidentity, &test_not_unboundp, &check_test);
+
+ GCPRO2 (tailed, keyed);
+
+ keyed = KEY (key, tree);
+
+ {
+ /* nsublis() won't attempt to replace a cons handed to it, do that
+ ourselves. */
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, elt_car, keyed) == test_not_unboundp)
+ {
+ /* See comment in sublis() on using elt_cdr. */
+ RETURN_UNGCPRO (XCDR (elt));
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ return nsublis (alist, tree, check_test, test_not_unboundp, test, key, 0);
+}
+
+DEFUN ("subst", Fsubst, 3, MANY, 0, /*
+Substitute NEW for OLD everywhere in TREE (non-destructively).
+
+Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]),
+ Qnil);
+ args[1] = alist;
+ result = Fsublis (nargs - 1, args + 1);
+ free_cons (XCAR (alist));
+ free_cons (alist);
+
+ return result;
+}
+
+DEFUN ("nsubst", Fnsubst, 3, MANY, 0, /*
+Substitute NEW for OLD everywhere in TREE (destructively).
+
+Any element of TREE which is `eql' to OLD is changed to NEW (via a call to
+`setcar').
+
+See `member*' for the meaning of the keywords.
+
+arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]),
+ Qnil);
+ args[1] = alist;
+ result = Fnsublis (nargs - 1, args + 1);
+ free_cons (XCAR (alist));
+ free_cons (alist);
+
+ return result;
+}
+
+static Boolint
+tree_equal (Lisp_Object tree1, Lisp_Object tree2,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key, int depth)
+{
+ Lisp_Object tortoise1 = tree1, tortoise2 = tree2;
+ struct gcpro gcpro1, gcpro2;
+ int count = 0;
+ Boolint result;
+
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
+ {
+ stack_overflow ("Stack overflow in tree-equal", tree1);
+ }
+
+ GCPRO2 (tree1, tree2);
+
+ while (CONSP (tree1) && CONSP (tree2)
+ && tree_equal (XCAR (tree1), XCAR (tree2), check_test,
+ test_not_unboundp, test, key, depth + 1))
+ {
+ tree1 = XCDR (tree1);
+ tree2 = XCDR (tree2);
+
+ if (++count > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (count & 1)
+ {
+ tortoise1 = XCDR (tortoise1);
+ tortoise2 = XCDR (tortoise2);
+ }
+
+ if (EQ (tortoise1, tree1))
+ {
+ signal_circular_list_error (tree1);
+ }
+
+ if (EQ (tortoise2, tree2))
+ {
+ signal_circular_list_error (tree2);
+ }
+ }
+ }
+
+ if (CONSP (tree1) || CONSP (tree2))
+ {
+ UNGCPRO;
+ return 0;
+ }
+
+ result = check_test (test, key, tree1, tree2) == test_not_unboundp;
+ UNGCPRO;
+
+ return result;
+}
+
+DEFUN ("tree-equal", Ftree_equal, 2, MANY, 0, /*
+Return t if TREE1 and TREE2 have `eql' leaves.
+
+Atoms are compared by `eql', unless another test is specified using
+:test; cons cells are compared recursively.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+arguments: (TREE1 TREE2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object tree1 = args[0], tree2 = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Ftree_equal, nargs, args, 3, (test, key, test_not),
+ (key = Qidentity));
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ return tree_equal (tree1, tree2, check_test, test_not_unboundp, test, key,
+ 0) ? Qt : Qnil;
+}
+
+static Lisp_Object
+mismatch_from_end (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
+ Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint UNUSED (return_sequence1_index))
+{
+ Elemcount sequence1_len = XINT (Flength (sequence1));
+ Elemcount sequence2_len = XINT (Flength (sequence2)), ii = 0;
+ Elemcount starting1, ending1, starting2, ending2;
+ Lisp_Object *sequence1_storage = NULL, *sequence2_storage = NULL;
+ struct gcpro gcpro1, gcpro2;
+
+ check_sequence_range (sequence1, start1, end1, make_int (sequence1_len));
+ starting1 = XINT (start1);
+ ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX;
+ ending1 = min (ending1, sequence1_len);
+
+ check_sequence_range (sequence2, start2, end2, make_int (sequence2_len));
+ starting2 = XINT (start2);
+ ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX;
+ ending2 = min (ending2, sequence2_len);
+
+ if (LISTP (sequence1))
+ {
+ Lisp_Object *saving;
+ sequence1_storage = saving
+ = alloca_array (Lisp_Object, ending1 - starting1);
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence1)
+ {
+ if (starting1 <= ii && ii < ending1)
+ {
+ *saving++ = elt;
+ }
+ else if (ii == ending1)
+ {
+ break;
+ }
+
+ ++ii;
+ }
+ }
+ }
+ else if (STRINGP (sequence1))
+ {
+ const Ibyte *cursor = string_char_addr (sequence1, starting1);
+
+ STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence1_storage, ii,
+ ending1 - starting1);
+
+ }
+ else if (BIT_VECTORP (sequence1))
+ {
+ Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence1);
+ sequence1_storage = alloca_array (Lisp_Object, ending1 - starting1);
+ for (ii = starting1; ii < ending1; ++ii)
+ {
+ sequence1_storage[ii - starting1]
+ = make_int (bit_vector_bit (vv, ii));
+ }
+ }
+ else
+ {
+ sequence1_storage = XVECTOR_DATA (sequence1) + starting1;
+ }
+
+ ii = 0;
+
+ if (LISTP (sequence2))
+ {
+ Lisp_Object *saving;
+ sequence2_storage = saving
+ = alloca_array (Lisp_Object, ending2 - starting2);
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence2)
+ {
+ if (starting2 <= ii && ii < ending2)
+ {
+ *saving++ = elt;
+ }
+ else if (ii == ending2)
+ {
+ break;
+ }
+
+ ++ii;
+ }
+ }
+ }
+ else if (STRINGP (sequence2))
+ {
+ const Ibyte *cursor = string_char_addr (sequence2, starting2);
+
+ STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence2_storage, ii,
+ ending2 - starting2);
+
+ }
+ else if (BIT_VECTORP (sequence2))
+ {
+ Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence2);
+ sequence2_storage = alloca_array (Lisp_Object, ending2 - starting2);
+ for (ii = starting2; ii < ending2; ++ii)
+ {
+ sequence2_storage[ii - starting2]
+ = make_int (bit_vector_bit (vv, ii));
+ }
+ }
+ else
+ {
+ sequence2_storage = XVECTOR_DATA (sequence2) + starting2;
+ }
+
+ GCPRO2 (sequence1_storage[0], sequence2_storage[0]);
+ gcpro1.nvars = ending1 - starting1;
+ gcpro2.nvars = ending2 - starting2;
+
+ while (ending1 > starting1 && ending2 > starting2)
+ {
+ --ending1;
+ --ending2;
+
+ if (check_match (test, key, sequence1_storage[ending1 - starting1],
+ sequence2_storage[ending2 - starting2])
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (ending1 + 1);
+ }
+ }
+
+ UNGCPRO;
+
+ if (ending1 > starting1 || ending2 > starting2)
+ {
+ return make_integer (ending1);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_list_list (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
+ Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint UNUSED (return_list_index))
+{
+ Lisp_Object sequence1_tortoise = sequence1, sequence2_tortoise = sequence2;
+ Lisp_Object orig_sequence1 = sequence1, orig_sequence2 = sequence2;
+ Elemcount ending1 = EMACS_INT_MAX, ending2 = EMACS_INT_MAX;
+ Elemcount starting1, starting2, counting, startcounting;
+ Elemcount shortest_len = 0;
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
+
+ starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX;
+ starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX;
+
+ if (!NILP (end1))
+ {
+ ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX;
+ }
+
+ if (!NILP (end2))
+ {
+ ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX;
+ }
+
+ if (!ZEROP (start1))
+ {
+ sequence1 = Fnthcdr (start1, sequence1);
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (sequence1_tortoise, start1, end1,
+ Flength (sequence1_tortoise));
+ /* Give up early here. */
+ return Qnil;
+ }
+
+ ending1 -= starting1;
+ starting1 = 0;
+ sequence1_tortoise = sequence1;
+ }
+
+ if (!ZEROP (start2))
+ {
+ sequence2 = Fnthcdr (start2, sequence2);
+
+ if (NILP (sequence2))
+ {
+ check_sequence_range (sequence2_tortoise, start2, end2,
+ Flength (sequence2_tortoise));
+ return Qnil;
+ }
+
+ ending2 -= starting2;
+ starting2 = 0;
+ sequence2_tortoise = sequence2;
+ }
+
+ GCPRO4 (sequence1, sequence2, sequence1_tortoise, sequence2_tortoise);
+
+ counting = startcounting = min (ending1, ending2);
+
+ while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2))
+ {
+ if (check_match (test, key,
+ CONSP (sequence1) ? XCAR (sequence1)
+: Fcar (sequence1),
+ CONSP (sequence2) ? XCAR (sequence2)
+: Fcar (sequence2) ) != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (XINT (start1) + shortest_len);
+ }
+
+ sequence1 = CONSP (sequence1) ? XCDR (sequence1) : Fcdr (sequence1);
+ sequence2 = CONSP (sequence2) ? XCDR (sequence2) : Fcdr (sequence2);
+
+ shortest_len++;
+
+ if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (counting & 1)
+ {
+ sequence1_tortoise = XCDR (sequence1_tortoise);
+ sequence2_tortoise = XCDR (sequence2_tortoise);
+ }
+
+ if (EQ (sequence1, sequence1_tortoise))
+ {
+ signal_circular_list_error (sequence1);
+ }
+
+ if (EQ (sequence2, sequence2_tortoise))
+ {
+ signal_circular_list_error (sequence2);
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if (NILP (sequence1))
+ {
+ Lisp_Object args[] = { start1, make_int (shortest_len) };
+ check_sequence_range (orig_sequence1, start1, end1,
+ Fplus (countof (args), args));
+ }
+
+ if (NILP (sequence2))
+ {
+ Lisp_Object args[] = { start2, make_int (shortest_len) };
+ check_sequence_range (orig_sequence2, start2, end2,
+ Fplus (countof (args), args));
+ }
+
+ if ((!NILP (end1) && shortest_len != ending1 - starting1) ||
+ (!NILP (end2) && shortest_len != ending2 - starting2))
+ {
+ return make_integer (XINT (start1) + shortest_len);
+ }
+
+ if ((NILP (end1) && CONSP (sequence1)) || (NILP (end2) && CONSP (sequence2)))
+ {
+ return make_integer (XINT (start1) + shortest_len);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_list_string (Lisp_Object list, Lisp_Object list_start,
+ Lisp_Object list_end,
+ Lisp_Object string, Lisp_Object string_start,
+ Lisp_Object string_end,
+ check_test_func_t check_match,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint return_list_index)
+{
+ Ibyte *string_data = XSTRING_DATA (string), *startp = string_data;
+ Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string);
+ Elemcount char_count = 0, list_starting, list_ending;
+ Elemcount string_starting, string_ending;
+ Lisp_Object character, orig_list = list;
+ struct gcpro gcpro1;
+
+ list_ending = INTP (list_end) ? XINT (list_end) : 1 + EMACS_INT_MAX;
+ list_starting = INTP (list_start) ? XINT (list_start) : 1 + EMACS_INT_MAX;
+
+ string_ending = INTP (string_end) ? XINT (string_end) : 1 + EMACS_INT_MAX;
+ string_starting
+ = INTP (string_start) ? XINT (string_start) : 1 + EMACS_INT_MAX;
+
+ while (char_count < string_starting && string_offset < string_len)
+ {
+ INC_IBYTEPTR (string_data);
+ string_offset = string_data - startp;
+ char_count++;
+ }
+
+ if (!ZEROP (list_start))
+ {
+ list = Fnthcdr (list_start, list);
+ if (NILP (list))
+ {
+ check_sequence_range (orig_list, list_start, list_end,
+ Flength (orig_list));
+ return Qnil;
+ }
+
+ list_ending -= list_starting;
+ list_starting = 0;
+ }
+
+ GCPRO1 (list);
+
+ while (list_starting < list_ending && string_starting < string_ending
+ && string_offset < string_len && !NILP (list))
+ {
+ character = make_char (itext_ichar (string_data));
+
+ if (return_list_index)
+ {
+ if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list),
+ character)
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (XINT (list_start) + char_count);
+ }
+ }
+ else
+ {
+ if (check_match (test, key, character,
+ CONSP (list) ? XCAR (list) : Fcar (list))
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (char_count);
+ }
+ }
+
+ list = CONSP (list) ? XCDR (list) : Fcdr (list);
+
+ startp = XSTRING_DATA (string);
+ string_data = startp + string_offset;
+ if (string_len != XSTRING_LENGTH (string)
+ || !valid_ibyteptr_p (string_data))
+ {
+ mapping_interaction_error (Qmismatch, string);
+ }
+
+ list_starting++;
+ string_starting++;
+ char_count++;
+ INC_IBYTEPTR (string_data);
+ string_offset = string_data - startp;
+ }
+
+ UNGCPRO;
+
+ if (NILP (list))
+ {
+ Lisp_Object args[] = { list_start, make_int (char_count) };
+ check_sequence_range (orig_list, list_start, list_end,
+ Fplus (countof (args), args));
+ }
+
+ if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string))
+ {
+ check_sequence_range (string, string_start, string_end,
+ make_int (char_count));
+ }
+
+ if ((NILP (string_end) ?
+ string_offset < string_len : string_starting < string_ending) ||
+ (NILP (list_end) ? !NILP (list) : list_starting < list_ending))
+ {
+ return make_integer (return_list_index ? XINT (list_start) + char_count :
+ char_count);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_list_array (Lisp_Object list, Lisp_Object list_start,
+ Lisp_Object list_end,
+ Lisp_Object array, Lisp_Object array_start,
+ Lisp_Object array_end,
+ check_test_func_t check_match,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint return_list_index)
+{
+ Elemcount ii = 0, list_starting, list_ending;
+ Elemcount array_starting, array_ending, array_len;
+ Lisp_Object orig_list = list;
+ struct gcpro gcpro1;
+
+ list_ending = INTP (list_end) ? XINT (list_end) : 1 + EMACS_INT_MAX;
+ list_starting = INTP (list_start) ? XINT (list_start) : 1 + EMACS_INT_MAX;
+
+ array_ending = INTP (array_end) ? XINT (array_end) : 1 + EMACS_INT_MAX;
+ array_starting = INTP (array_start) ? XINT (array_start) : 1 + EMACS_INT_MAX;
+ array_len = XINT (Flength (array));
+
+ array_ending = min (array_ending, array_len);
+
+ check_sequence_range (array, array_start, array_end, make_int (array_len));
+
+ if (!ZEROP (list_start))
+ {
+ list = Fnthcdr (list_start, list);
+ if (NILP (list))
+ {
+ check_sequence_range (orig_list, list_start, list_end,
+ Flength (orig_list));
+ return Qnil;
+ }
+
+ list_ending -= list_starting;
+ list_starting = 0;
+ }
+
+ GCPRO1 (list);
+
+ while (list_starting < list_ending && array_starting < array_ending
+ && !NILP (list))
+ {
+ if (return_list_index)
+ {
+ if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list),
+ Faref (array, make_int (array_starting)))
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (XINT (list_start) + ii);
+ }
+ }
+ else
+ {
+ if (check_match (test, key, Faref (array, make_int (array_starting)),
+ CONSP (list) ? XCAR (list) : Fcar (list))
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (array_starting);
+ }
+ }
+
+ list = CONSP (list) ? XCDR (list) : Fcdr (list);
+ list_starting++;
+ array_starting++;
+ ii++;
+ }
+
+ UNGCPRO;
+
+ if (NILP (list))
+ {
+ Lisp_Object args[] = { list_start, make_int (ii) };
+ check_sequence_range (orig_list, list_start, list_end,
+ Fplus (countof (args), args));
+ }
+
+ if (array_starting < array_ending ||
+ (NILP (list_end) ? !NILP (list) : list_starting < list_ending))
+ {
+ return make_integer (return_list_index ? XINT (list_start) + ii :
+ array_starting);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_string_array (Lisp_Object string, Lisp_Object string_start,
+ Lisp_Object string_end,
+ Lisp_Object array, Lisp_Object array_start,
+ Lisp_Object array_end,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint return_string_index)
+{
+ Ibyte *string_data = XSTRING_DATA (string), *startp = string_data;
+ Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string);
+ Elemcount char_count = 0, array_starting, array_ending, array_length;
+ Elemcount string_starting, string_ending;
+ Lisp_Object character;
+
+ array_starting = INTP (array_start) ? XINT (array_start) : 1 + EMACS_INT_MAX;
+ array_ending = INTP (array_end) ? XINT (array_end) : 1 + EMACS_INT_MAX;
+ array_length = XINT (Flength (array));
+ check_sequence_range (array, array_start, array_end, make_int (array_length));
+ array_ending = min (array_ending, array_length);
+
+ string_ending = INTP (string_end) ? XINT (string_end) : 1 + EMACS_INT_MAX;
+ string_starting
+ = INTP (string_start) ? XINT (string_start) : 1 + EMACS_INT_MAX;
+
+ while (char_count < string_starting && string_offset < string_len)
+ {
+ INC_IBYTEPTR (string_data);
+ string_offset = string_data - startp;
+ char_count++;
+ }
+
+ while (array_starting < array_ending && string_starting < string_ending
+ && string_offset < string_len)
+ {
+ character = make_char (itext_ichar (string_data));
+
+ if (return_string_index)
+ {
+ if (check_match (test, key, character,
+ Faref (array, make_int (array_starting)))
+ != test_not_unboundp)
+ {
+ return make_integer (char_count);
+ }
+ }
+ else
+ {
+ if (check_match (test, key,
+ Faref (array, make_int (array_starting)),
+ character)
+ != test_not_unboundp)
+ {
+ return make_integer (XINT (array_start) + char_count);
+ }
+ }
+
+ startp = XSTRING_DATA (string);
+ string_data = startp + string_offset;
+ if (string_len != XSTRING_LENGTH (string)
+ || !valid_ibyteptr_p (string_data))
+ {
+ mapping_interaction_error (Qmismatch, string);
+ }
+
+ array_starting++;
+ string_starting++;
+ char_count++;
+ INC_IBYTEPTR (string_data);
+ string_offset = string_data - startp;
+ }
+
+ if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string))
+ {
+ check_sequence_range (string, string_start, string_end,
+ make_int (char_count));
+ }
+
+ if ((NILP (string_end) ?
+ string_offset < string_len : string_starting < string_ending) ||
+ (NILP (array_end) ? !NILP (array) : array_starting < array_ending))
+ {
+ return make_integer (return_string_index ? char_count :
+ XINT (array_start) + char_count);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_string_string (Lisp_Object string1,
+ Lisp_Object string1_start, Lisp_Object string1_end,
+ Lisp_Object string2, Lisp_Object string2_start,
+ Lisp_Object string2_end,
+ check_test_func_t check_match,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint UNUSED (return_string1_index))
+{
+ Ibyte *string1_data = XSTRING_DATA (string1), *startp1 = string1_data;
+ Bytecount string1_offset = 0, string1_len = XSTRING_LENGTH (string1);
+ Ibyte *string2_data = XSTRING_DATA (string2), *startp2 = string2_data;
+ Bytecount string2_offset = 0, string2_len = XSTRING_LENGTH (string2);
+ Elemcount char_count1 = 0, string1_starting, string1_ending;
+ Elemcount char_count2 = 0, string2_starting, string2_ending;
+ Lisp_Object character1, character2;
+
+ string1_ending = INTP (string1_end) ? XINT (string1_end) : 1 + EMACS_INT_MAX;
+ string1_starting
+ = INTP (string1_start) ? XINT (string1_start) : 1 + EMACS_INT_MAX;
+
+ string2_starting
+ = INTP (string2_start) ? XINT (string2_start) : 1 + EMACS_INT_MAX;
+ string2_ending = INTP (string2_end) ? XINT (string2_end) : 1 + EMACS_INT_MAX;
+
+ while (char_count1 < string1_starting && string1_offset < string1_len)
+ {
+ INC_IBYTEPTR (string1_data);
+ string1_offset = string1_data - startp1;
+ char_count1++;
+ }
+
+ while (char_count2 < string2_starting && string2_offset < string2_len)
+ {
+ INC_IBYTEPTR (string2_data);
+ string2_offset = string2_data - startp2;
+ char_count2++;
+ }
+
+ while (string2_starting < string2_ending && string1_starting < string1_ending
+ && string1_offset < string1_len && string2_offset < string2_len)
+ {
+ character1 = make_char (itext_ichar (string1_data));
+ character2 = make_char (itext_ichar (string2_data));
+
+ if (check_match (test, key, character1, character2)
+ != test_not_unboundp)
+ {
+ return make_integer (char_count1);
+ }
+
+ startp1 = XSTRING_DATA (string1);
+ string1_data = startp1 + string1_offset;
+ if (string1_len != XSTRING_LENGTH (string1)
+ || !valid_ibyteptr_p (string1_data))
+ {
+ mapping_interaction_error (Qmismatch, string1);
+ }
+
+ startp2 = XSTRING_DATA (string2);
+ string2_data = startp2 + string2_offset;
+ if (string2_len != XSTRING_LENGTH (string2)
+ || !valid_ibyteptr_p (string2_data))
+ {
+ mapping_interaction_error (Qmismatch, string2);
+ }
+
+ string2_starting++;
+ string1_starting++;
+ char_count1++;
+ char_count2++;
+ INC_IBYTEPTR (string1_data);
+ string1_offset = string1_data - startp1;
+ INC_IBYTEPTR (string2_data);
+ string2_offset = string2_data - startp2;
+ }
+
+ if (string1_data == XSTRING_DATA (string1) + XSTRING_LENGTH (string1))
+ {
+ check_sequence_range (string1, string1_start, string1_end,
+ make_int (char_count1));
+ }
+
+ if (string2_data == XSTRING_DATA (string2) + XSTRING_LENGTH (string2))
+ {
+ check_sequence_range (string2, string2_start, string2_end,
+ make_int (char_count2));
+ }
+
+ if ((!NILP (string1_end) && string1_starting < string1_ending) ||
+ (!NILP (string2_end) && string2_starting < string2_ending))
+ {
+ return make_integer (char_count1);
+ }
+
+ if ((NILP (string1_end) && string1_data
+ < (XSTRING_DATA (string1) + XSTRING_LENGTH (string1))) ||
+ (NILP (string2_end) && string2_data
+ < (XSTRING_DATA (string2) + XSTRING_LENGTH (string2))))
+ {
+ return make_integer (char_count1);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_array_array (Lisp_Object array1, Lisp_Object start1, Lisp_Object end1,
+ Lisp_Object array2, Lisp_Object start2, Lisp_Object end2,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint UNUSED (return_array1_index))
+{
+ Elemcount len1 = XINT (Flength (array1)), len2 = XINT (Flength (array2));
+ Elemcount ending1 = EMACS_INT_MAX, ending2 = EMACS_INT_MAX;
+ Elemcount starting1, starting2;
+
+ check_sequence_range (array1, start1, end1, make_int (len1));
+ check_sequence_range (array2, start2, end2, make_int (len2));
+
+ starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX;
+ starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX;
+
+ if (!NILP (end1))
+ {
+ ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX;
+ }
+
+ if (!NILP (end2))
+ {
+ ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX;
+ }
+
+ ending1 = min (ending1, len1);
+ ending2 = min (ending2, len2);
+
+ while (starting1 < ending1 && starting2 < ending2)
+ {
+ if (check_match (test, key, Faref (array1, make_int (starting1)),
+ Faref (array2, make_int (starting2)))
+ != test_not_unboundp)
+ {
+ return make_integer (starting1);
+ }
+ starting1++;
+ starting2++;
+ }
+
+ if (starting1 < ending1 || starting2 < ending2)
+ {
+ return make_integer (starting1);
+ }
+
+ return Qnil;
+}
+
+typedef Lisp_Object
+(*mismatch_func_t) (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
+ Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint return_list_index);
+
+static mismatch_func_t
+get_mismatch_func (Lisp_Object sequence1, Lisp_Object sequence2,
+ Lisp_Object from_end, Boolint *return_sequence1_index_out)
+{
+ CHECK_SEQUENCE (sequence1);
+ CHECK_SEQUENCE (sequence2);
+
+ if (!NILP (from_end))
+ {
+ *return_sequence1_index_out = 1;
+ return mismatch_from_end;
+ }
+
+ if (LISTP (sequence1))
+ {
+ if (LISTP (sequence2))
+ {
+ *return_sequence1_index_out = 1;
+ return mismatch_list_list;
+ }
+
+ if (STRINGP (sequence2))
+ {
+ *return_sequence1_index_out = 1;
+ return mismatch_list_string;
+ }
+
+ *return_sequence1_index_out = 1;
+ return mismatch_list_array;
+ }
+
+ if (STRINGP (sequence1))
+ {
+ if (STRINGP (sequence2))
+ {
+ *return_sequence1_index_out = 1;
+ return mismatch_string_string;
+ }
+
+ if (LISTP (sequence2))
+ {
+ *return_sequence1_index_out = 0;
+ return mismatch_list_string;
+ }
+
+ *return_sequence1_index_out = 1;
+ return mismatch_string_array;
+ }
+
+ if (ARRAYP (sequence1))
+ {
+ if (STRINGP (sequence2))
+ {
+ *return_sequence1_index_out = 0;
+ return mismatch_string_array;
+ }
+
+ if (LISTP (sequence2))
+ {
+ *return_sequence1_index_out = 0;
+ return mismatch_list_array;
+ }
+
+ *return_sequence1_index_out = 1;
+ return mismatch_array_array;
+ }
+
+ RETURN_NOT_REACHED (NULL);
+ return NULL;
+}
+
+DEFUN ("mismatch", Fmismatch, 2, MANY, 0, /*
+Compare SEQUENCE1 with SEQUENCE2, return index of first mismatching element.
+
+Return nil if the sequences match. If one sequence is a prefix of the
+other, the return value indicates the end of the shorter sequence. A
+non-nil return value always reflects an index into SEQUENCE1.
+
+See `search' for the meaning of the keywords."
+
+arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence1 = args[0], sequence2 = args[1];
+ Boolint test_not_unboundp = 1, return_first_index = 0;
+ check_test_func_t check_match = NULL;
+ mismatch_func_t mismatch = NULL;
+
+ PARSE_KEYWORDS (Fmismatch, nargs, args, 8,
+ (test, key, from_end, start1, end1, start2, end2, test_not),
+ (start1 = start2 = Qzero));
+
+ CHECK_SEQUENCE (sequence1);
+ CHECK_SEQUENCE (sequence2);
+
+ CHECK_NATNUM (start1);
+ CHECK_NATNUM (start2);
+
+ if (!NILP (end1))
+ {
+ CHECK_NATNUM (end1);
+ }
+
+ if (!NILP (end2))
+ {
+ CHECK_NATNUM (end2);
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, NULL);
+ mismatch = get_mismatch_func (sequence1, sequence2, from_end,
+ &return_first_index);
+
+ if (return_first_index)
+ {
+ return mismatch (sequence1, start1, end1, sequence2, start2, end2,
+ check_match, test_not_unboundp, test, key, 1);
+ }
+
+ return mismatch (sequence2, start2, end2, sequence1, start1, end1,
+ check_match, test_not_unboundp, test, key, 0);
+}
+
+DEFUN ("search", Fsearch, 2, MANY, 0, /*
+Search for SEQUENCE1 as a subsequence of SEQUENCE2.
+
+Return the index of the leftmost element of the first match found; return
+nil if there are no matches.
+
+In this function, :start1 and :end1 specify a subsequence of SEQUENCE1, and
+:start2 and :end2 specify a subsequence of SEQUENCE2. See `remove*' for
+details of the other keywords.
+
+arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence1 = args[0], sequence2 = args[1], position0 = Qnil;
+ Boolint test_not_unboundp = 1, return_first = 0;
+ check_test_func_t check_test = NULL, check_match = NULL;
+ mismatch_func_t mismatch = NULL;
+ Elemcount starting1 = 0, ending1 = 1 + EMACS_INT_MAX, starting2 = 0;
+ Elemcount ending2 = 1 + EMACS_INT_MAX, ii = 0;
+ Elemcount length1;
+ Lisp_Object object = Qnil;
+ struct gcpro gcpro1, gcpro2;
+
+ PARSE_KEYWORDS (Fsearch, nargs, args, 8,
+ (test, key, from_end, start1, end1, start2, end2, test_not),
+ (start1 = start2 = Qzero));
+
+ CHECK_SEQUENCE (sequence1);
+ CHECK_SEQUENCE (sequence2);
+ CHECK_KEY_ARGUMENT (key);
+
+ CHECK_NATNUM (start1);
+ starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX;
+ CHECK_NATNUM (start2);
+ starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX;
+
+ if (!NILP (end1))
+ {
+ Lisp_Object len1 = Flength (sequence1);
+
+ CHECK_NATNUM (end1);
+ check_sequence_range (sequence1, start1, end1, len1);
+ ending1 = min (XINT (end1), XINT (len1));
+ }
+ else
+ {
+ end1 = Flength (sequence1);
+ check_sequence_range (sequence1, start1, end1, end1);
+ ending1 = XINT (end1);
+ }
+
+ length1 = ending1 - starting1;
+
+ if (!NILP (end2))
+ {
+ Lisp_Object len2 = Flength (sequence2);
+
+ CHECK_NATNUM (end2);
+ check_sequence_range (sequence2, start2, end2, len2);
+ ending2 = min (XINT (end2), XINT (len2));
+ }
+ else
+ {
+ end2 = Flength (sequence2);
+ check_sequence_range (sequence2, start2, end2, end2);
+ ending2 = XINT (end2);
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+ mismatch = get_mismatch_func (sequence1, sequence2, from_end, &return_first);
+
+ if (bytecode_arithcompare (start1, make_integer (ending1)) >= 0)
+ {
+ if (NILP (from_end))
+ {
+ return start2;
+ }
+
+ if (NILP (end2))
+ {
+ return Flength (sequence2);
+ }
+
+ return end2;
+ }
+
+ if (NILP (from_end))
+ {
+ Lisp_Object mismatch_start1 = Fadd1 (start1);
+ Lisp_Object first = KEY (key, Felt (sequence1, start1));
+ GCPRO2 (first, mismatch_start1);
+
+ ii = starting2;
+ while (ii < ending2)
+ {
+ position0 = position (&object, first, sequence2, check_test,
+ test_not_unboundp, test, key, make_int (ii),
+ end2, Qnil, Qnil, Qsearch);
+ if (NILP (position0))
+ {
+ UNGCPRO;
+ return Qnil;
+ }
+
+ if (length1 + XINT (position0) <= ending2 &&
+ (return_first ?
+ NILP (mismatch (sequence1, mismatch_start1, end1,
+ sequence2,
+ make_int (1 + XINT (position0)),
+ make_int (length1 + XINT (position0)),
+ check_match, test_not_unboundp, test, key, 1)) :
+ NILP (mismatch (sequence2,
+ make_int (1 + XINT (position0)),
+ make_int (length1 + XINT (position0)),
+ sequence1, mismatch_start1, end1,
+ check_match, test_not_unboundp, test, key, 0))))
+
+
+ {
+ UNGCPRO;
+ return position0;
+ }
+
+ ii = XINT (position0) + 1;
+ }
+
+ UNGCPRO;
+ }
+ else
+ {
+ Lisp_Object mismatch_end1 = make_integer (ending1 - 1);
+ Lisp_Object last = KEY (key, Felt (sequence1, mismatch_end1));
+ GCPRO2 (last, mismatch_end1);
+
+ ii = ending2;
+ while (ii > starting2)
+ {
+ position0 = position (&object, last, sequence2, check_test,
+ test_not_unboundp, test, key, start2,
+ make_int (ii), Qt, Qnil, Qsearch);
+
+ if (NILP (position0))
+ {
+ UNGCPRO;
+ return Qnil;
+ }
+
+ if (XINT (position0) - length1 + 1 >= starting2 &&
+ (return_first ?
+ NILP (mismatch (sequence1, start1, mismatch_end1,
+ sequence2,
+ make_int (XINT (position0) - length1 + 1),
+ make_int (XINT (position0)),
+ check_match, test_not_unboundp, test, key, 1)) :
+ NILP (mismatch (sequence2,
+ make_int (XINT (position0) - length1 + 1),
+ make_int (XINT (position0)),
+ sequence1, start1, mismatch_end1,
+ check_match, test_not_unboundp, test, key, 0))))
+ {
+ UNGCPRO;
+ return make_int (XINT (position0) - length1 + 1);
+ }
+
+ ii = XINT (position0);
+ }
+
+ UNGCPRO;
+ }
+
+ return Qnil;
+}
+
+/* These two functions do set operations, those that can be visualised with
+ Venn diagrams. */
+static Lisp_Object
+venn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp)
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil;
+ Lisp_Object result = EQ (caller, Qsubsetp) ? Qt : Qnil, result_tail = Qnil;
+ Lisp_Object keyed = Qnil, ignore = Qnil;
+ Elemcount len;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS_8 (caller, nargs, args, 4, (test, key, test_not, stable),
+ NULL, 2, 0);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt1) && intersectionp)
+ {
+ return Qnil;
+ }
+
+ if (NILP (liszt2))
+ {
+ return intersectionp ? Qnil : liszt1;
+ }
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, result);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len)
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil))
+ != intersectionp)
+ {
+ if (EQ (Qsubsetp, caller))
+ {
+ result = Qnil;
+ break;
+ }
+ else if (NILP (stable))
+ {
+ result = Fcons (elt, result);
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ return result;
+}
+
+static Lisp_Object
+nvenn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp)
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], tortoise_elt, ignore = Qnil;
+ Lisp_Object elt = Qnil, tail = Qnil, keyed = Qnil, prev_tail = Qnil;
+ Elemcount count;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS_8 (caller, nargs, args, 3, (test, key, test_not),
+ NULL, 2, 0);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt1) && intersectionp)
+ {
+ return Qnil;
+ }
+
+ if (NILP (liszt2))
+ {
+ return intersectionp ? Qnil : liszt1;
+ }
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, liszt1);
+
+ tortoise_elt = tail = liszt1, count = 0;
+
+ while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
+ (signal_malformed_list_error (liszt1), 0))
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil))
+ == intersectionp)
+ {
+ if (NILP (prev_tail))
+ {
+ liszt1 = XCDR (tail);
+ }
+ else
+ {
+ XSETCDR (prev_tail, XCDR (tail));
+ }
+
+ tail = XCDR (tail);
+ /* List is definitely not circular now! */
+ count = 0;
+ }
+ else
+ {
+ prev_tail = tail;
+ tail = XCDR (tail);
+ }
+
+ if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ {
+ tortoise_elt = XCDR (tortoise_elt);
+ }
+
+ if (EQ (elt, tortoise_elt))
+ {
+ signal_circular_list_error (liszt1);
+ }
+ }
+
+ UNGCPRO;
+
+ return liszt1;
+}
+
+DEFUN ("intersection", Fintersection, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-intersection operation.
+
+The result list contains all items that appear in both LIST1 and LIST2.
+This is a non-destructive function; it makes a copy of the data if necessary
+to avoid corrupting the original LIST1 and LIST2.
+
+A non-nil value for the :stable keyword, not specified by Common Lisp, means
+return the items in the order they appear in LIST1.
+
+See `union' for the meaning of :test, :test-not and :key."
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return venn (Qintersection, nargs, args, 1);
+}
+
+DEFUN ("nintersection", Fnintersection, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-intersection operation.
+
+The result list contains all items that appear in both LIST1 and LIST2.
+This is a destructive function; it reuses the storage of LIST1 whenever
+possible.
+
+See `union' for the meaning of :test, :test-not and :key."
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return nvenn (Qnintersection, nargs, args, 1);
+}
+
+DEFUN ("subsetp", Fsubsetp, 2, MANY, 0, /*
+Return non-nil if every element of LIST1 also appears in LIST2.
+
+See `union' for the meaning of the keyword arguments.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return venn (Qsubsetp, nargs, args, 0);
+}
+
+DEFUN ("set-difference", Fset_difference, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-difference operation.
+
+The result list contains all items that appear in LIST1 but not LIST2. This
+is a non-destructive function; it makes a copy of the data if necessary to
+avoid corrupting the original LIST1 and LIST2.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+A non-nil value for the :stable keyword, not specified by Common Lisp, means
+return the items in the order they appear in LIST1.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return venn (Qset_difference, nargs, args, 0);
+}
+
+DEFUN ("nset-difference", Fnset_difference, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-difference operation.
+
+The result list contains all items that appear in LIST1 but not LIST2. This
+is a destructive function; it reuses the storage of LIST1 whenever possible.
+
+See `union' for the meaning of :test, :test-not and :key."
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return nvenn (Qnset_difference, nargs, args, 0);
+}
+
+DEFUN ("nunion", Fnunion, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-union operation.
+The result list contains all items that appear in either LIST1 or LIST2.
+
+This is a destructive function, it reuses the storage of LIST1 whenever
+possible.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ args[0] = nvenn (Qnunion, nargs, args, 0);
+ return bytecode_nconc2 (args);
+}
+
+DEFUN ("union", Funion, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-union operation.
+The result list contains all items that appear in either LIST1 or LIST2.
+This is a non-destructive function; it makes a copy of the data if necessary
+to avoid corrupting the original LIST1 and LIST2.
+
+The keywords :test and :test-not specify two-argument test and negated-test
+predicates, respectively; :test defaults to `eql'. See `member*' for more
+information.
+
+:key specifies a one-argument function that transforms elements of LIST1
+and LIST2 into \"comparison keys\" before the test predicate is applied.
+For example, if :key is #'car, then the car of elements from LIST1 is
+compared with the car of elements from LIST2. The :key function, however,
+does not affect the elements in the returned list, which are taken directly
+from the elements in LIST1 and LIST2.
+
+A non-nil value for the :stable keyword, not specified by Common Lisp, means
+return the items of LIST1 in order, followed by the remaining items of LIST2
+in the order they occur in LIST2.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], ignore = Qnil;
+ Lisp_Object elt = Qnil, tail = Qnil, keyed = Qnil, result, result_tail;
+ Elemcount len;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL, check_match = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS (Funion, nargs, args, 4, (test, key, test_not, stable), NULL);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt1))
+ {
+ return liszt2;
+ }
+
+ if (NILP (liszt2))
+ {
+ return liszt1;
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, result);
+
+ if (NILP (stable))
+ {
+ result = liszt2;
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len)
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil)))
+ {
+ /* The Lisp version of #'union used to check which list was
+ longer, and use that as the tail of the constructed
+ list. That fails when the order of arguments to TEST is
+ specified, as is the case for these functions. We could
+ pass the reverse_check argument to
+ list_position_cons_before, but that means any key argument
+ is called an awful lot more, so it's a space win but not
+ a time win. */
+ result = Fcons (elt, result);
+ }
+ }
+ }
+ }
+ else
+ {
+ result = result_tail = Qnil;
+
+ /* The standard `union' doesn't produce a "stable" union -- it
+ iterates over the second list instead of the first one, and returns
+ the values in backwards order. According to the CLTL2
+ documentation, `union' is not required to preserve the ordering of
+ elements in any fashion; providing the functionality for a stable
+ union is an XEmacs extension. */
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt2, tail, len)
+ {
+ if (NILP (list_position_cons_before (&ignore, elt, liszt1,
+ check_match, test_not_unboundp,
+ test, key, 1, Qzero, Qnil)))
+ {
+ if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ }
+ }
+
+ result = NILP (result) ? liszt1 : nconc2 (Fcopy_list (liszt1), result);
+ }
+
+ UNGCPRO;
+
+ return result;
+}
+
+DEFUN ("set-exclusive-or", Fset_exclusive_or, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-exclusive-or operation.
+
+The result list contains all items that appear in exactly one of LIST1, LIST2.
+This is a non-destructive function; it makes a copy of the data if necessary
+to avoid corrupting the original LIST1 and LIST2.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+A non-nil value for the :stable keyword, not specified by Common Lisp, means
+return the items in the order they appear in LIST1, followed by the
+remaining items in the order they appear in LIST2.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil;
+ Lisp_Object result = Qnil, result_tail = Qnil, keyed = Qnil, ignore = Qnil;
+ Elemcount len;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_match = NULL, check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS (Fset_exclusive_or, nargs, args, 4,
+ (test, key, test_not, stable), NULL);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt2))
+ {
+ return liszt1;
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, result);
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len)
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil)))
+ {
+ if (NILP (stable))
+ {
+ result = Fcons (elt, result);
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ }
+ }
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt2, tail, len)
+ {
+ if (NILP (list_position_cons_before (&ignore, elt, liszt1,
+ check_match, test_not_unboundp,
+ test, key, 1, Qzero, Qnil)))
+ {
+ if (NILP (stable))
+ {
+ result = Fcons (elt, result);
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ }
+ }
+ UNGCPRO;
+
+ return result;
+}
+
+DEFUN ("nset-exclusive-or", Fnset_exclusive_or, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-exclusive-or operation.
+
+The result list contains all items that appear in exactly one of LIST1 and
+LIST2. This is a destructive function; it reuses the storage of LIST1 and
+LIST2 whenever possible.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil;
+ Lisp_Object result = Qnil, tortoise_elt = Qnil, keyed = Qnil, swap;
+ Lisp_Object prev_tail = Qnil, ignore = Qnil;
+ Elemcount count;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_match = NULL, check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS (Fnset_exclusive_or, nargs, args, 4,
+ (test, key, test_not, stable), NULL);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt2))
+ {
+ return liszt1;
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, result);
+
+ tortoise_elt = tail = liszt1, count = 0;
+
+ while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
+ (signal_malformed_list_error (liszt1), 0))
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil)))
+ {
+ swap = XCDR (tail);
+
+ if (NILP (prev_tail))
+ {
+ liszt1 = XCDR (tail);
+ }
+ else
+ {
+ XSETCDR (prev_tail, swap);
+ }
+
+ XSETCDR (tail, result);
+ result = tail;
+ tail = swap;
+
+ /* List is definitely not circular now! */
+ count = 0;
+ }
+ else
+ {
+ prev_tail = tail;
+ tail = XCDR (tail);
+ }
+
+ if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ {
+ tortoise_elt = XCDR (tortoise_elt);
+ }
+
+ if (EQ (elt, tortoise_elt))
+ {
+ signal_circular_list_error (liszt1);
+ }
+ }
+
+ tortoise_elt = tail = liszt2, count = 0;
+
+ while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
+ (signal_malformed_list_error (liszt2), 0))
+ {
+ /* Need to leave the key calculation to list_position_cons_before(). */
+ if (NILP (list_position_cons_before (&ignore, elt, liszt1,
+ check_match, test_not_unboundp,
+ test, key, 1, Qzero, Qnil)))
+ {
+ swap = XCDR (tail);
+ XSETCDR (tail, result);
+ result = tail;
+ tail = swap;
+ count = 0;
+ }
+ else
+ {
+ tail = XCDR (tail);
+ }
+
+ if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ {
+ tortoise_elt = XCDR (tortoise_elt);
+ }
+
+ if (EQ (elt, tortoise_elt))
+ {
+ signal_circular_list_error (liszt1);
+ }
+ }
+
+ UNGCPRO;
+
+ return result;
+}
+
+
Lisp_Object
add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string)
{
＠＠ -6203,7 +11067,6 ＠＠
Fsymbol_name (symbol)),
Qnil);
}
-
/* #### this function doesn't belong in this file! */
＠＠ -6821,7 +11684,6 ＠＠
INIT_LISP_OBJECT (bit_vector);
DEFSYMBOL (Qstring_lessp);
- DEFSYMBOL (Qsort);
DEFSYMBOL (Qmerge);
DEFSYMBOL (Qfill);
DEFSYMBOL (Qidentity);
＠＠ -6833,6 +11695,10 ＠＠
defsymbol (&QsortX, "sort*");
DEFSYMBOL (Qreduce);
DEFSYMBOL (Qreplace);
+ DEFSYMBOL (Qposition);
+ DEFSYMBOL (Qfind);
+ defsymbol (&QdeleteX, "delete*");
+ defsymbol (&QremoveX, "remove*");
DEFSYMBOL (Qmapconcat);
defsymbol (&QmapcarX, "mapcar*");
＠＠ -6846,6 +11712,19 ＠＠
DEFSYMBOL (Qmaplist);
DEFSYMBOL (Qmapl);
DEFSYMBOL (Qmapcon);
+ DEFSYMBOL (Qnsubstitute);
+ DEFSYMBOL (Qdelete_duplicates);
+ DEFSYMBOL (Qsubstitute);
+ DEFSYMBOL (Qmismatch);
+ DEFSYMBOL (Qintersection);
+ DEFSYMBOL (Qnintersection);
+ DEFSYMBOL (Qsubsetp);
+ DEFSYMBOL (Qset_difference);
+ DEFSYMBOL (Qnset_difference);
+ DEFSYMBOL (Qnunion);
+ DEFSYMBOL (Qnintersection);
+ DEFSYMBOL (Qset_difference);
+ DEFSYMBOL (Qnset_difference);
DEFKEYWORD (Q_from_end);
DEFKEYWORD (Q_initial_value);
＠＠ -6853,6 +11732,11 ＠＠
DEFKEYWORD (Q_start2);
DEFKEYWORD (Q_end1);
DEFKEYWORD (Q_end2);
+ defkeyword (&Q_if_, ":if");
+ DEFKEYWORD (Q_if_not);
+ DEFKEYWORD (Q_test_not);
+ DEFKEYWORD (Q_count);
+ DEFKEYWORD (Q_stable);
DEFSYMBOL (Qyes_or_no_p);
＠＠ -6863,6 +11747,7 ＠＠
DEFSUBR (Flength);
DEFSUBR (Fsafe_length);
DEFSUBR (Flist_length);
+ DEFSUBR (Fcount);
DEFSUBR (Fstring_equal);
DEFSUBR (Fcompare_strings);
DEFSUBR (Fstring_lessp);
＠＠ -6886,6 +11771,8 ＠＠
DEFSUBR (Fold_member);
DEFSUBR (Fmemq);
DEFSUBR (Fold_memq);
+ DEFSUBR (FmemberX);
+ DEFSUBR (Fadjoin);
DEFSUBR (Fassoc);
DEFSUBR (Fold_assoc);
DEFSUBR (Fassq);
＠＠ -6894,18 +11781,25 ＠＠
DEFSUBR (Fold_rassoc);
DEFSUBR (Frassq);
DEFSUBR (Fold_rassq);
+
+ DEFSUBR (Fposition);
+ DEFSUBR (Ffind);
+
DEFSUBR (Fdelete);
DEFSUBR (Fold_delete);
DEFSUBR (Fdelq);
DEFSUBR (Fold_delq);
+ DEFSUBR (FdeleteX);
+ DEFSUBR (FremoveX);
DEFSUBR (Fremassoc);
DEFSUBR (Fremassq);
DEFSUBR (Fremrassoc);
DEFSUBR (Fremrassq);
+ DEFSUBR (Fdelete_duplicates);
+ DEFSUBR (Fremove_duplicates);
DEFSUBR (Fnreverse);
DEFSUBR (Freverse);
DEFSUBR (FsortX);
- Ffset (intern ("sort"), QsortX);
DEFSUBR (Fmerge);
DEFSUBR (Fplists_eq);
DEFSUBR (Fplists_equal);
＠＠ -6933,7 +11827,9 ＠＠
DEFSUBR (Fequalp);
DEFSUBR (Fold_equal);
DEFSUBR (Ffill);
- Ffset (intern ("fillarray"), Qfill);
+
+ DEFSUBR (FassocX);
+ DEFSUBR (FrassocX);
DEFSUBR (Fnconc);
DEFSUBR (FmapcarX);
＠＠ -6945,8 +11841,8 ＠＠
DEFSUBR (Fmap_into);
DEFSUBR (Fsome);
DEFSUBR (Fevery);
- Ffset (intern ("mapc-internal"), Fsymbol_function (intern ("mapc")));
- Ffset (intern ("mapcar"), Fsymbol_function (intern ("mapcar*")));
+ Ffset (intern ("mapc-internal"), Qmapc);
+ Ffset (intern ("mapcar"), QmapcarX);
DEFSUBR (Fmaplist);
DEFSUBR (Fmapl);
DEFSUBR (Fmapcon);
＠＠ -6954,6 +11850,25 ＠＠
DEFSUBR (Freduce);
DEFSUBR (Freplace_list);
DEFSUBR (Freplace);
+ DEFSUBR (Fsubsetp);
+ DEFSUBR (Fnsubstitute);
+ DEFSUBR (Fsubstitute);
+ DEFSUBR (Fsublis);
+ DEFSUBR (Fnsublis);
+ DEFSUBR (Fsubst);
+ DEFSUBR (Fnsubst);
+ DEFSUBR (Ftree_equal);
+ DEFSUBR (Fmismatch);
+ DEFSUBR (Fsearch);
+ DEFSUBR (Funion);
+ DEFSUBR (Fnunion);
+ DEFSUBR (Fintersection);
+ DEFSUBR (Fnintersection);
+ DEFSUBR (Fset_difference);
+ DEFSUBR (Fnset_difference);
+ DEFSUBR (Fset_exclusive_or);
+ DEFSUBR (Fnset_exclusive_or);
+
DEFSUBR (Fload_average);
DEFSUBR (Ffeaturep);
DEFSUBR (Frequire);
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 1 comments
commit: Merge.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5328:dae3d95cf319
tag: tip
parent: 5326:60ba780f9078
parent: 5327:d1b17a33450b
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jan 02 02:32:59 2011 +0000
files: lisp/ChangeLog src/ChangeLog
description:
Merge.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Move the heavy lifting from cl-seq.el to C.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 5327:d1b17a33450b
parent: 5323:f87bb35a6b94
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Dec 30 01:59:52 2010 +0000
files: lisp/ChangeLog lisp/cl-seq.el lisp/cl.el lisp/obsolete.el lisp/subr.el src/ChangeLog src/fns.c
description:
Move the heavy lifting from cl-seq.el to C.
src/ChangeLog addition:
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
Move the heavy lifting from cl-seq.el to C, finally making those
functions first-class XEmacs citizens, with circularity checking,
built-in support for tests other than #'eql, and as much
compatibility with current Common Lisp as Paul Dietz' tests require.
* fns.c (check_eq_nokey, check_eq_key, check_eql_nokey)
(check_eql_key, check_equal_nokey, check_equal_key)
(check_equalp_nokey, check_equalp_key, check_string_match_nokey)
(check_string_match_key, check_other_nokey, check_other_key)
(check_if_nokey, check_if_key, check_match_eq_key)
(check_match_eql_key, check_match_equal_key)
(check_match_equalp_key, check_match_other_key): New. These are
basically to provide function pointers to be used by Lisp
functions that take TEST, TEST-NOT and KEY arguments.
(get_check_match_function_1, get_check_test_function)
(get_check_match_function): These functions work out which of the
previous list of functions to use, given the keywords supplied by
the user.
(count_with_tail): New. This is the bones of #'count.
(list_count_from_end, string_count_from_end): Utility functions
for #'count.
(Fcount): New, moved from cl-seq.el.
(list_position_cons_before): New. The implementation of #'member*,
and important in implementing various other functions.
(FmemberX, Fadjoin, FassocX, FrassocX, Fposition, Ffind)
(FdeleteX, FremoveX, Fdelete_duplicates, Fremove_duplicates)
(Fnsubstitute, Fsubstitute, Fsublis, Fnsublis, Fsubst, Fnsubst)
(Ftree_equal, Fmismatch, Fsearch, Fintersection, Fnintersection)
(Fsubsetp, Fset_difference, Fnset_difference, Fnunion, Funion)
(Fset_exclusive_or, Fnset_exclusive_or): New, moved here from
cl-seq.el.
(position): New. The implementation of #'find and #'position.
(list_delete_duplicates_from_end, subst, sublis, nsublis)
(tree_equal, mismatch_from_end, mismatch_list_list)
(mismatch_list_string, mismatch_list_array)
(mismatch_string_array, mismatch_string_string)
(mismatch_array_array, get_mismatch_func): Helper C functions for
the Lisp-visible functions.
(venn, nvenn): New. The implementation of the main Lisp functions that
treat lists as sets.
lisp/ChangeLog addition:
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
diff -r f87bb35a6b94 -r d1b17a33450b lisp/ChangeLog
--- a/lisp/ChangeLog Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/ChangeLog Thu Dec 30 01:59:52 2010 +0000
＠＠ -1,3 +1,18 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-seq.el:
+ Move the heavy lifting from this file to C. Dump the
+ cl-parsing-keywords macro, but don't use defun* for the functions
+ we define that do take keywords, dynamic scope lossage makes that
+ not practical.
+ * subr.el (sort, fillarray): Move these aliases here.
+ (map-plist): #'nsublis is now built-in, but at this point #'eql
+ isn't necessarily available as a test; use #'eq.
+ * obsolete.el (cl-delete-duplicates): Make this available for old
+ compiler macros and old code.
+ (memql): Document that this is equivalent to #'member*, and worse.
+ * cl.el (adjoin, subst): Removed. These are in C.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
diff -r f87bb35a6b94 -r d1b17a33450b lisp/cl-seq.el
--- a/lisp/cl-seq.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/cl-seq.el Thu Dec 30 01:59:52 2010 +0000
＠＠ -47,541 +47,189 ＠＠
;; See cl.el for Change Log.
-
;;; Code:
-;;; Keyword parsing. This is special-cased here so that we can compile
-;;; this file independent from cl-macs.
+;; XEmacs; all the heavy lifting of this file is now in C. There's no need
+;; for the cl-parsing-keywords macro. We could use defun* for the
+;; keyword-parsing code, which would avoid the necessity of the arguments:
+;; () lists in the docstrings, but that often breaks because of dynamic
+;; scope (e.g. a variable called start bound in this file and one in a
+;; user-supplied test predicate may well interfere with each other).
-(defmacro cl-parsing-keywords (kwords other-keys &rest body)
- "Helper macro for functions with keyword arguments.
-This is a temporary solution, until keyword arguments are natively supported.
-Declare your function ending with (... &rest cl-keys), then wrap the
-function body in a call to `cl-parsing-keywords'.
+;; XEmacs change: these two are in subr.el in GNU Emacs.
+(defun remove (cl-item cl-seq)
+ "Remove all occurrences of ITEM in SEQUENCE, testing with `equal'.
-KWORDS is a list of keyword definitions. Each definition should be
-either a keyword or a list (KEYWORD DEFAULT-VALUE). In the former case,
-the default value is nil. The keywords are available in BODY as the name
-of the keyword, minus its initial colon and prepended with `cl-'.
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE.
+Also see: `remove*', `delete', `delete*'
-OTHER-KEYS specifies other keywords that are accepted but ignored. It
-is either the value 't' (ignore all other keys, equivalent to the
-&allow-other-keys argument declaration in Common Lisp) or a list in the
-same format as KWORDS. If keywords are given that are not in KWORDS
-and not allowed by OTHER-KEYS, an error will normally be signalled; but
-the caller can override this by specifying a non-nil value for the
-keyword:allow-other-keys (which defaults to t)."
- (cons
- 'let*
- (cons (mapcar
- (function
- (lambda (x)
- (let* ((var (if (consp x) (car x) x))
- (mem (list 'car (list 'cdr (list 'memq (list 'quote var)
- 'cl-keys)))))
- (if (eq var :test-not)
- (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
- (if (eq var :if-not)
- (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
- (list (intern
- (format "cl-%s" (substring (symbol-name var) 1)))
- (if (consp x) (list 'or mem (car (cdr x))) mem)))))
- kwords)
- (append
- (and (not (eq other-keys t))
- (list
- (list 'let '((cl-keys-temp cl-keys))
- (list 'while 'cl-keys-temp
- (list 'or (list 'memq '(car cl-keys-temp)
- (list 'quote
- (mapcar
- (function
- (lambda (x)
- (if (consp x)
- (car x) x)))
- (append kwords
- other-keys))))
- '(car (cdr (memq (quote :allow-other-keys)
- cl-keys)))
- '(error 'invalid-keyword-argument
- (car cl-keys-temp)))
- '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
- body))))
-(put 'cl-parsing-keywords 'lisp-indent-function 2)
-(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
+arguments: (ITEM SEQUENCE)"
+ (remove* cl-item cl-seq :test #'equal))
-(defmacro cl-check-key (x)
- (list 'if 'cl-key (list 'funcall 'cl-key x) x))
+(defun remq (cl-item cl-seq)
+ "Remove all occurrences of ITEM in SEQUENCE, comparing with `eq'.
-(defmacro cl-check-test-nokey (item x)
- (list 'cond
- (list 'cl-test
- (list 'eq (list 'not (list 'funcall 'cl-test item x))
- 'cl-test-not))
- (list 'cl-if
- (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
- (list 't (list 'if (list 'numberp item)
- (list 'equal item x) (list 'eq item x)))))
+This is a non-destructive function; it makes a copy of SEQUENCE to avoid
+corrupting the original LIST. See also the more general `remove*'.
-(defmacro cl-check-test (item x)
- (list 'cl-check-test-nokey item (list 'cl-check-key x)))
+arguments: (ITEM SEQUENCE)"
+ (remove* cl-item cl-seq :test #'eq))
-(defmacro cl-check-match (x y)
- (setq x (list 'cl-check-key x) y (list 'cl-check-key y))
- (list 'if 'cl-test
- (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
- (list 'if (list 'numberp x)
- (list 'equal x y) (list 'eq x y))))
+(defun remove-if (cl-predicate cl-seq &rest cl-keys)
+ "Remove all items satisfying PREDICATE in SEQUENCE.
-(put 'cl-check-key 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-test 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-match 'edebug-form-spec 'edebug-forms)
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE. If SEQUENCE is a list, the copy
+may share list structure with SEQUENCE. If no item satisfies PREDICATE,
+SEQUENCE itself is returned, unmodified.
-(defvar cl-test) (defvar cl-test-not)
-(defvar cl-if) (defvar cl-if-not)
-(defvar cl-key)
+See `remove*' for the meaning of the keywords.
-;; XEmacs; #'replace is in fns.c.
+arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
+ (apply 'remove* 'remove* cl-seq :if cl-predicate cl-keys))
-(defun remove* (cl-item cl-seq &rest cl-keys)
- "Remove all occurrences of ITEM in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Keywords supported: :test :test-not :key :count :start :end :from-end
-The keywords :test and :test-not specify two-argument test and negated-test
-predicates, respectively; :test defaults to `eql'. :key specifies a
-one-argument function that transforms elements of SEQ into \"comparison keys\"
-before the test predicate is applied. See `member*' for more information
-on these keywords.
-:start and :end, if given, specify indices of a subsequence of SEQ to
-be processed. Indices are 0-based and processing involves the subsequence
-starting at the index given by :start and ending just before the index
-given by :end.
-:count, if given, limits the number of items removed to the number specified.
-:from-end, if given, causes processing to proceed starting from the end
-instead of the beginning; in this case, this matters only if :count is given."
- (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
- (:start 0) :end) ()
- (if (<= (or cl-count (setq cl-count 8000000)) 0)
- cl-seq
- (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000)))
- (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
- cl-from-end)))
- (if cl-i
- (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
- (append (if cl-from-end
- (list :end (1+ cl-i))
- (list :start cl-i))
- cl-keys))))
- (typecase cl-seq
- (list cl-res)
- (string (concat cl-res))
- (vector (vconcat cl-res))
- (bit-vector (bvconcat cl-res))))
- cl-seq))
- (setq cl-end (- (or cl-end 8000000) cl-start))
- (if (= cl-start 0)
- (while (and cl-seq (> cl-end 0)
- (cl-check-test cl-item (car cl-seq))
- (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
- (> (setq cl-count (1- cl-count)) 0))))
- (if (and (> cl-count 0) (> cl-end 0))
- (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
- (setq cl-end (1- cl-end)) (cdr cl-seq))))
- (while (and cl-p (> cl-end 0)
- (not (cl-check-test cl-item (car cl-p))))
- (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
- (if (and cl-p (> cl-end 0))
- (nconc (ldiff cl-seq cl-p)
- (if (= cl-count 1) (cdr cl-p)
- (and (cdr cl-p)
- (apply 'delete* cl-item
- (copy-sequence (cdr cl-p))
- :start 0 :end (1- cl-end)
- :count (1- cl-count) cl-keys))))
- cl-seq))
- cl-seq)))))
+(defun remove-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Remove all items not satisfying PREDICATE in SEQUENCE.
-(defun remove-if (cl-pred cl-list &rest cl-keys)
- "Remove all items satisfying PREDICATE in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'remove* nil cl-list :if cl-pred cl-keys))
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE. If SEQUENCE is a list, the copy
+may share list structure with SEQUENCE.
-(defun remove-if-not (cl-pred cl-list &rest cl-keys)
- "Remove all items not satisfying PREDICATE in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'remove* nil cl-list :if-not cl-pred cl-keys))
+See `remove*' for the meaning of the keywords.
-(defun delete* (cl-item cl-seq &rest cl-keys)
- "Remove all occurrences of ITEM in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :test :test-not :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
- (:start 0) :end) ()
- (if (<= (or cl-count (setq cl-count 8000000)) 0)
- cl-seq
- (if (listp cl-seq)
- (if (and cl-from-end (< cl-count 4000000))
- (let (cl-i)
- (while (and (>= (setq cl-count (1- cl-count)) 0)
- (setq cl-i (cl-position cl-item cl-seq cl-start
- cl-end cl-from-end)))
- (if (= cl-i 0) (setq cl-seq (cdr cl-seq))
- (let ((cl-tail (nthcdr (1- cl-i) cl-seq)))
- (setcdr cl-tail (cdr (cdr cl-tail)))))
- (setq cl-end cl-i))
- cl-seq)
- (setq cl-end (- (or cl-end 8000000) cl-start))
- (if (= cl-start 0)
- (progn
- (while (and cl-seq
- (> cl-end 0)
- (cl-check-test cl-item (car cl-seq))
- (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
- (> (setq cl-count (1- cl-count)) 0)))
- (setq cl-end (1- cl-end)))
- (setq cl-start (1- cl-start)))
- (if (and (> cl-count 0) (> cl-end 0))
- (let ((cl-p (nthcdr cl-start cl-seq)))
- (while (and (cdr cl-p) (> cl-end 0))
- (if (cl-check-test cl-item (car (cdr cl-p)))
- (progn
- (setcdr cl-p (cdr (cdr cl-p)))
- (if (= (setq cl-count (1- cl-count)) 0)
- (setq cl-end 1)))
- (setq cl-p (cdr cl-p)))
- (setq cl-end (1- cl-end)))))
- cl-seq)
- (apply 'remove* cl-item cl-seq cl-keys)))))
+arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
+ (apply 'remove* 'remove* cl-seq :if-not cl-predicate cl-keys))
-(defun delete-if (cl-pred cl-list &rest cl-keys)
- "Remove all items satisfying PREDICATE in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'delete* nil cl-list :if cl-pred cl-keys))
+(defun delete-if (cl-predicate cl-seq &rest cl-keys)
+ "Remove all items satisfying PREDICATE in SEQUENCE.
-(defun delete-if-not (cl-pred cl-list &rest cl-keys)
- "Remove all items not satisfying PREDICATE in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'delete* nil cl-list :if-not cl-pred cl-keys))
+This is a destructive function; if SEQUENCE is a list, it reuses its
+storage. If SEQUENCE is an array and some element satisfies SEQUENCE, a
+copy is always returned.
-;; XEmacs change: this is in subr.el in GNU Emacs
-(defun remove (cl-item cl-seq)
- "Remove all occurrences of ITEM in SEQ, testing with `equal'
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Also see: `remove*', `delete', `delete*'"
- (remove* cl-item cl-seq ':test 'equal))
+See `remove*' for the meaning of the keywords.
-;; XEmacs change: this is in subr.el in GNU Emacs
-(defun remq (cl-elt cl-list)
- "Remove all occurrences of ELT in LIST, comparing with `eq'.
-This is a non-destructive function; it makes a copy of LIST to avoid
-corrupting the original LIST.
-Also see: `delq', `delete', `delete*', `remove', `remove*'."
- (if (memq cl-elt cl-list)
- (delq cl-elt (copy-list cl-list))
- cl-list))
+arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
+ (apply 'delete* 'delete* cl-seq :if cl-predicate cl-keys))
-(defun remove-duplicates (cl-seq &rest cl-keys)
- "Return a copy of SEQ with all duplicate elements removed.
-Keywords supported: :test :test-not :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-delete-duplicates cl-seq cl-keys t))
+(defun delete-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Remove all items not satisfying PREDICATE in SEQUENCE.
-(defun delete-duplicates (cl-seq &rest cl-keys)
- "Remove all duplicate elements from SEQ (destructively).
-Keywords supported: :test :test-not :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-delete-duplicates cl-seq cl-keys nil))
+This is a destructive function; it reuses the storage of SEQUENCE whenever
+possible.
-(defun cl-delete-duplicates (cl-seq cl-keys cl-copy)
- (if (listp cl-seq)
- (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
- ()
- (if cl-from-end
- (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
- (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
- (while (> cl-end 1)
- (setq cl-i 0)
- (while (setq cl-i (cl-position (cl-check-key (car cl-p))
- (cdr cl-p) cl-i (1- cl-end)))
- (if cl-copy (setq cl-seq (copy-sequence cl-seq)
- cl-p (nthcdr cl-start cl-seq) cl-copy nil))
- (let ((cl-tail (nthcdr cl-i cl-p)))
- (setcdr cl-tail (cdr (cdr cl-tail))))
- (setq cl-end (1- cl-end)))
- (setq cl-p (cdr cl-p) cl-end (1- cl-end)
- cl-start (1+ cl-start)))
- cl-seq)
- (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
- (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
- (cl-position (cl-check-key (car cl-seq))
- (cdr cl-seq) 0 (1- cl-end)))
- (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
- (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
- (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
- (while (and (cdr (cdr cl-p)) (> cl-end 1))
- (if (cl-position (cl-check-key (car (cdr cl-p)))
- (cdr (cdr cl-p)) 0 (1- cl-end))
- (progn
- (if cl-copy (setq cl-seq (copy-sequence cl-seq)
- cl-p (nthcdr (1- cl-start) cl-seq)
- cl-copy nil))
- (setcdr cl-p (cdr (cdr cl-p))))
- (setq cl-p (cdr cl-p)))
- (setq cl-end (1- cl-end) cl-start (1+ cl-start)))
- cl-seq)))
- (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil)))
- (typecase cl-seq
- (string (concat cl-res))
- (vector (vconcat cl-res))
- (bit-vector (bvconcat cl-res))))))
+See `remove*' for the meaning of the keywords.
-(defun substitute (cl-new cl-old cl-seq &rest cl-keys)
- "Substitute NEW for OLD in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-Keywords supported: :test :test-not :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not :count
- (:start 0) :end :from-end) ()
- (if (or (eq cl-old cl-new)
- (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
- cl-seq
- (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end)))
- (if (not cl-i)
- cl-seq
- (setq cl-seq (copy-sequence cl-seq))
- (or cl-from-end
- (progn (cl-set-elt cl-seq cl-i cl-new)
- (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
- (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count
- :start cl-i cl-keys))))))
+arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
+ (apply 'delete* 'delete* cl-seq :if-not cl-predicate cl-keys))
-(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
- "Substitute NEW for all items satisfying PREDICATE in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-See `remove*' for the meaning of the keywords."
- (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys))
+(defun substitute-if (cl-new cl-predicate cl-seq &rest cl-keys)
+ "Substitute NEW for all items satisfying PREDICATE in SEQUENCE.
-(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
- "Substitute NEW for all items not satisfying PREDICATE in SEQ.
-This is a non-destructive function; it makes a copy of SEQ if necessary
-to avoid corrupting the original SEQ.
-See `remove*' for the meaning of the keywords."
- (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys))
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE.
-(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
- "Substitute NEW for OLD in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :test :test-not :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not :count
- (:start 0) :end :from-end) ()
- (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
- (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
- (let ((cl-p (nthcdr cl-start cl-seq)))
- (setq cl-end (- (or cl-end 8000000) cl-start))
- (while (and cl-p (> cl-end 0) (> cl-count 0))
- (if (cl-check-test cl-old (car cl-p))
- (progn
- (setcar cl-p cl-new)
- (setq cl-count (1- cl-count))))
- (setq cl-p (cdr cl-p) cl-end (1- cl-end))))
- (or cl-end (setq cl-end (length cl-seq)))
- (if cl-from-end
- (while (and (< cl-start cl-end) (> cl-count 0))
- (setq cl-end (1- cl-end))
- (if (cl-check-test cl-old (elt cl-seq cl-end))
- (progn
- (cl-set-elt cl-seq cl-end cl-new)
- (setq cl-count (1- cl-count)))))
- (while (and (< cl-start cl-end) (> cl-count 0))
- (if (cl-check-test cl-old (aref cl-seq cl-start))
- (progn
- (aset cl-seq cl-start cl-new)
- (setq cl-count (1- cl-count))))
- (setq cl-start (1+ cl-start))))))
- cl-seq))
+See `remove*' for the meaning of the keywords.
-(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
- "Substitute NEW for all items satisfying PREDICATE in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
+arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
+ (apply 'substitute cl-new 'substitute cl-seq :if cl-predicate cl-keys))
-(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
- "Substitute NEW for all items not satisfying PREDICATE in SEQ.
-This is a destructive function; it reuses the storage of SEQ whenever possible.
-Keywords supported: :key :count :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
+(defun substitute-if-not (cl-new cl-predicate cl-seq &rest cl-keys)
+ "Substitute NEW for all items not satisfying PREDICATE in SEQUENCE.
-(defun find (cl-item cl-seq &rest cl-keys)
- "Find the first occurrence of ITEM in LIST.
-Return the matching ITEM, or nil if not found.
-Keywords supported: :test :test-not :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
- (and cl-pos (elt cl-seq cl-pos))))
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE.
-(defun find-if (cl-pred cl-list &rest cl-keys)
- "Find the first item satisfying PREDICATE in LIST.
-Return the matching ITEM, or nil if not found.
-Keywords supported: :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'find nil cl-list :if cl-pred cl-keys))
+See `remove*' for the meaning of the keywords.
-(defun find-if-not (cl-pred cl-list &rest cl-keys)
- "Find the first item not satisfying PREDICATE in LIST.
-Return the matching ITEM, or nil if not found.
-Keywords supported: :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'find nil cl-list :if-not cl-pred cl-keys))
+arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
+ (apply 'substitute cl-new 'substitute cl-seq :if-not cl-predicate
+ cl-keys))
-(defun position (cl-item cl-seq &rest cl-keys)
- "Find the first occurrence of ITEM in LIST.
+(defun nsubstitute-if (cl-new cl-predicate cl-seq &rest cl-keys)
+ "Substitute NEW for all items satisfying PREDICATE in SEQUENCE.
+
+This is destructive function; it modifies SEQUENCE directly, never returning
+a copy. See `substitute-if' for a non-destructive version.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
+ (apply 'nsubstitute cl-new 'nsubstitute cl-seq :if cl-predicate
+ cl-keys))
+
+(defun nsubstitute-if-not (cl-new cl-predicate cl-seq &rest cl-keys)
+ "Substitute NEW for all items not satisfying PREDICATE in SEQUENCE.
+
+This is destructive function; it modifies SEQUENCE directly, never returning
+a copy. See `substitute-if-not' for a non-destructive version.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
+ (apply 'nsubstitute cl-new 'nsubstitute cl-seq :if-not cl-predicate
+ cl-keys))
+
+(defun find-if (cl-predicate cl-seq &rest cl-keys)
+ "Find the first item satisfying PREDICATE in SEQUENCE.
+
+Return the matching item, or DEFAULT (not a keyword specified for this
+function by Common Lisp) if not found.
+
+See `remove*' for the meaning of the other keywords.
+
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END DEFAULT)"
+ (apply 'find 'find cl-seq :if cl-predicate cl-keys))
+
+(defun find-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Find the first item not satisfying PREDICATE in SEQUENCE.
+
+Return the matching ITEM, or DEFAULT (not a keyword specified for this
+function by Common Lisp) if not found.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END DEFAULT)"
+ (apply 'find 'find cl-seq :if-not cl-predicate cl-keys))
+
+(defun position-if (cl-predicate cl-seq &rest cl-keys)
+ "Find the first item satisfying PREDICATE in SEQUENCE.
+
Return the index of the matching item, or nil if not found.
-Keywords supported: :test :test-not :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not
- (:start 0) :end :from-end) ()
- (cl-position cl-item cl-seq cl-start cl-end cl-from-end)))
-(defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
- (if (listp cl-seq)
- (let ((cl-p (nthcdr cl-start cl-seq)))
- (or cl-end (setq cl-end 8000000))
- (let ((cl-res nil))
- (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
- (if (cl-check-test cl-item (car cl-p))
- (setq cl-res cl-start))
- (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
- cl-res))
- (or cl-end (setq cl-end (length cl-seq)))
- (if cl-from-end
- (progn
- (while (and (>= (setq cl-end (1- cl-end)) cl-start)
- (not (cl-check-test cl-item (aref cl-seq cl-end)))))
- (and (>= cl-end cl-start) cl-end))
- (while (and (< cl-start cl-end)
- (not (cl-check-test cl-item (aref cl-seq cl-start))))
- (setq cl-start (1+ cl-start)))
- (and (< cl-start cl-end) cl-start))))
+See `remove*' for the meaning of the keywords.
-(defun position-if (cl-pred cl-list &rest cl-keys)
- "Find the first item satisfying PREDICATE in LIST.
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
+ (apply 'position 'position cl-seq :if cl-predicate cl-keys))
+
+(defun position-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Find the first item not satisfying PREDICATE in SEQUENCE.
+
Return the index of the matching item, or nil if not found.
-Keywords supported: :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'position nil cl-list :if cl-pred cl-keys))
-(defun position-if-not (cl-pred cl-list &rest cl-keys)
- "Find the first item not satisfying PREDICATE in LIST.
-Return the index of the matching item, or nil if not found.
-Keywords supported: :key :start :end :from-end
-See `remove*' for the meaning of the keywords."
- (apply 'position nil cl-list :if-not cl-pred cl-keys))
+See `remove*' for the meaning of the keywords.
-(defun count (cl-item cl-seq &rest cl-keys)
- "Count the number of occurrences of ITEM in LIST.
-Keywords supported: :test :test-not :key :start :end
-See `remove*' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
- (let ((cl-count 0) cl-x)
- (or cl-end (setq cl-end (length cl-seq)))
- (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
- (while (< cl-start cl-end)
- (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start)))
- (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
- (setq cl-start (1+ cl-start)))
- cl-count)))
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
+ (apply 'position 'position cl-seq :if-not cl-predicate cl-keys))
-(defun count-if (cl-pred cl-list &rest cl-keys)
- "Count the number of items satisfying PREDICATE in LIST.
-Keywords supported: :key :start :end
-See `remove*' for the meaning of the keywords."
- (apply 'count nil cl-list :if cl-pred cl-keys))
+(defun count-if (cl-predicate cl-seq &rest cl-keys)
+ "Count the number of items satisfying PREDICATE in SEQUENCE.
-(defun count-if-not (cl-pred cl-list &rest cl-keys)
- "Count the number of items not satisfying PREDICATE in LIST.
-Keywords supported: :key :start :end
-See `remove*' for the meaning of the keywords."
- (apply 'count nil cl-list :if-not cl-pred cl-keys))
+See `remove*' for the meaning of the keywords.
-(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
- "Compare SEQ1 with SEQ2, return index of first mismatching element.
-Return nil if the sequences match. If one sequence is a prefix of the
-other, the return value indicates the end of the shorter sequence.
-Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
-See `search' for the meaning of the keywords."
- (cl-parsing-keywords (:test :test-not :key :from-end
- (:start1 0) :end1 (:start2 0) :end2) ()
- (or cl-end1 (setq cl-end1 (length cl-seq1)))
- (or cl-end2 (setq cl-end2 (length cl-seq2)))
- (if cl-from-end
- (progn
- (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
- (cl-check-match (elt cl-seq1 (1- cl-end1))
- (elt cl-seq2 (1- cl-end2))))
- (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
- (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
- (1- cl-end1)))
- (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
- (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
- (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
- (cl-check-match (if cl-p1 (car cl-p1)
- (aref cl-seq1 cl-start1))
- (if cl-p2 (car cl-p2)
- (aref cl-seq2 cl-start2))))
- (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
- cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
- (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
- cl-start1)))))
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
+ (apply 'count 'count cl-seq :if cl-predicate cl-keys))
-(defun search (cl-seq1 cl-seq2 &rest cl-keys)
- "Search for SEQ1 as a subsequence of SEQ2.
-Return the index of the leftmost element of the first match found;
-return nil if there are no matches.
-Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
-See `remove*' for the meaning of the keywords. In this case, :start1 and :end1
-specify a subsequence of SEQ1, and :start2 and :end2 specify a subsequence
-of SEQ2."
- (cl-parsing-keywords (:test :test-not :key :from-end
- (:start1 0) :end1 (:start2 0) :end2) ()
- (or cl-end1 (setq cl-end1 (length cl-seq1)))
- (or cl-end2 (setq cl-end2 (length cl-seq2)))
- (if (>= cl-start1 cl-end1)
- (if cl-from-end cl-end2 cl-start2)
- (let* ((cl-len (- cl-end1 cl-start1))
- (cl-first (cl-check-key (elt cl-seq1 cl-start1)))
- (cl-if nil) cl-pos)
- (setq cl-end2 (- cl-end2 (1- cl-len)))
- (while (and (< cl-start2 cl-end2)
- (setq cl-pos (cl-position cl-first cl-seq2
- cl-start2 cl-end2 cl-from-end))
- (apply 'mismatch cl-seq1 cl-seq2
- :start1 (1+ cl-start1) :end1 cl-end1
- :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
- :from-end nil cl-keys))
- (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
- (and (< cl-start2 cl-end2) cl-pos)))))
+(defun count-if-not (cl-predicate cl-seq &rest cl-keys)
+ "Count the number of items not satisfying PREDICATE in SEQUENCE.
-(defun stable-sort (cl-seq cl-pred &rest cl-keys)
+See `remove*' for the meaning of the keywords.
+
+arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
+ (apply 'count 'count cl-seq :if-not cl-predicate cl-keys))
+
+(defun stable-sort (cl-seq cl-predicate &rest cl-keys)
"Sort the argument SEQUENCE stably according to PREDICATE.
This is a destructive function; it reuses the storage of SEQUENCE if possible.
Keywords supported: :key
＠＠ -589,144 +237,52 ＠＠
into \"comparison keys\" before the test predicate is applied. See
`member*' for more information.
-arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY))"
- (apply 'sort* cl-seq cl-pred cl-keys))
+arguments: (SEQUENCE PREDICATE &key (KEY #'identity))"
+ (apply 'sort* cl-seq cl-predicate cl-keys))
-;;; See compiler macro in cl-macs.el
-(defun member* (cl-item cl-list &rest cl-keys)
- "Find the first occurrence of ITEM in LIST.
-Return the sublist of LIST whose car is ITEM.
-Keywords supported: :test :test-not :key
-The keyword :test specifies a two-argument function that is used to
- compare ITEM with elements in LIST; if omitted, it defaults to `eql'.
-The keyword :test-not is similar, but specifies a negated predicate. That
- is, ITEM is considered equal to an element in LIST if the given predicate
- returns nil.
-:key specifies a one-argument function that transforms elements of LIST into
-\"comparison keys\" before the test predicate is applied. For example,
-if:key is #'car, then ITEM is compared with the car of elements from LIST1.
-The:key function, however, is not applied to ITEM, and does not affect the
-elements in the returned list, which are taken directly from the elements in
-LIST."
- (if cl-keys
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (while (and cl-list (not (cl-check-test cl-item (car cl-list))))
- (setq cl-list (cdr cl-list)))
- cl-list)
- (if (and (numberp cl-item) (not (fixnump cl-item)))
- (member cl-item cl-list)
- (memq cl-item cl-list))))
-
-(defun member-if (cl-pred cl-list &rest cl-keys)
+(defun member-if (cl-predicate cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'member* nil cl-list :if cl-pred cl-keys))
+See `member*' for the meaning of :key.
-(defun member-if-not (cl-pred cl-list &rest cl-keys)
+arguments: (PREDICATE LIST &key (KEY #'identity))"
+ (apply 'member* 'member* cl-list :if cl-predicate cl-keys))
+
+(defun member-if-not (cl-predicate cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'member* nil cl-list :if-not cl-pred cl-keys))
+See `member*' for the meaning of :key.
-(defun cl-adjoin (cl-item cl-list &rest cl-keys)
- (if (cl-parsing-keywords (:key) t
- (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
- cl-list
- (cons cl-item cl-list)))
+arguments: (PREDICATE LIST &key (KEY #'identity))"
+ (apply 'member* 'member* cl-list :if-not cl-predicate cl-keys))
-;;; See compiler macro in cl-macs.el
-(defun assoc* (cl-item cl-alist &rest cl-keys)
- "Find the first item whose car matches ITEM in LIST.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (if cl-keys
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (while (and cl-alist
- (or (not (consp (car cl-alist)))
- (not (cl-check-test cl-item (car (car cl-alist))))))
- (setq cl-alist (cdr cl-alist)))
- (and cl-alist (car cl-alist)))
- (if (and (numberp cl-item) (not (fixnump cl-item)))
- (assoc cl-item cl-alist)
- (assq cl-item cl-alist))))
+(defun assoc-if (cl-predicate cl-alist &rest cl-keys)
+ "Return the first item whose car satisfies PREDICATE in ALIST.
+See `member*' for the meaning of :key.
-(defun assoc-if (cl-pred cl-list &rest cl-keys)
- "Find the first item whose car satisfies PREDICATE in LIST.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'assoc* nil cl-list :if cl-pred cl-keys))
+arguments: (PREDICATE ALIST &key (KEY #'identity))"
+ (apply 'assoc* 'assoc* cl-alist :if cl-predicate cl-keys))
-(defun assoc-if-not (cl-pred cl-list &rest cl-keys)
- "Find the first item whose car does not satisfy PREDICATE in LIST.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'assoc* nil cl-list :if-not cl-pred cl-keys))
+(defun assoc-if-not (cl-predicate cl-alist &rest cl-keys)
+ "Return the first item whose car does not satisfy PREDICATE in ALIST.
+See `member*' for the meaning of :key.
-(defun rassoc* (cl-item cl-alist &rest cl-keys)
- "Find the first item whose cdr matches ITEM in LIST.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (if (or cl-keys (and (numberp cl-item) (not (fixnump cl-item))))
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (while (and cl-alist
- (or (not (consp (car cl-alist)))
- (not (cl-check-test cl-item (cdr (car cl-alist))))))
- (setq cl-alist (cdr cl-alist)))
- (and cl-alist (car cl-alist)))
- (rassq cl-item cl-alist)))
+arguments: (PREDICATE ALIST &key (KEY #'identity))"
+ (apply 'assoc* 'assoc* cl-alist :if-not cl-predicate cl-keys))
-(defun rassoc-if (cl-pred cl-list &rest cl-keys)
- "Find the first item whose cdr satisfies PREDICATE in LIST.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'rassoc* nil cl-list :if cl-pred cl-keys))
+(defun rassoc-if (cl-predicate cl-alist &rest cl-keys)
+ "Return the first item whose cdr satisfies PREDICATE in ALIST.
+See `member*' for the meaning of :key.
-(defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
- "Find the first item whose cdr does not satisfy PREDICATE in LIST.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys))
+arguments: (PREDICATE ALIST &key (KEY #'identity))"
+ (apply 'rassoc* 'rassoc* cl-alist :if cl-predicate cl-keys))
-(defun union (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-union operation.
-The result list contains all items that appear in either LIST1 or LIST2.
-This is a non-destructive function; it makes a copy of the data if necessary
-to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
-The keywords :test and :test-not specify two-argument test and negated-test
-predicates, respectively; :test defaults to `eql'. see `member*' for more
-information.
-:key specifies a one-argument function that transforms elements of LIST1
-and LIST2 into \"comparison keys\" before the test predicate is applied.
-For example, if :key is #'car, then the car of elements from LIST1 is
-compared with the car of elements from LIST2. The :key function, however,
-does not affect the elements in the returned list, which are taken directly
-from the elements in LIST1 and LIST2."
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- ((equal cl-list1 cl-list2) cl-list1)
- (t
- (or (>= (length cl-list1) (length cl-list2))
- (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
- (while cl-list2
- (if (or cl-keys (numberp (car cl-list2)))
- (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
- (or (memq (car cl-list2) cl-list1)
- (push (car cl-list2) cl-list1)))
- (pop cl-list2))
- cl-list1)))
+(defun rassoc-if-not (cl-predicate cl-alist &rest cl-keys)
+ "Return the first item whose cdr does not satisfy PREDICATE in ALIST.
+See `member*' for the meaning of :key.
-(defun nunion (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-union operation.
-The result list contains all items that appear in either LIST1 or LIST2.
-This is a destructive function; it reuses the storage of LIST1 and LIST2
-whenever possible.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- (t (apply 'union cl-list1 cl-list2 cl-keys))))
+arguments: (PREDICATE ALIST &key (KEY #'identity))"
+ (apply 'rassoc* 'rassoc* cl-alist :if-not cl-predicate cl-keys))
;; XEmacs addition: NOT IN COMMON LISP.
(defun stable-union (cl-list1 cl-list2 &rest cl-keys)
＠＠ -736,257 +292,90 ＠＠
LIST1 and LIST2. The result specifically consists of the elements in LIST1
in order, followed by any elements in LIST2 that are not also in LIST1, in
the order given in LIST2.
+
This is a non-destructive function; it makes a copy of the data if necessary
to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
+
See `union' for the meaning of :test, :test-not and :key.
NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs
-extension."
+extension.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)"
;; The standard `union' doesn't produce a "stable" union --
;; it iterates over the second list instead of the first one, and returns
;; the values in backwards order. According to the CLTL2 documentation,
;; `union' is not required to preserve the ordering of elements in
;; any fashion, so we add a new function rather than changing the
;; semantics of `union'.
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- ((equal cl-list1 cl-list2) cl-list1)
- (t
- (append
- cl-list1
- (cl-parsing-keywords (:key) (:test :test-not)
- (loop for cl-l in cl-list2
- if (not (if (or cl-keys (numberp cl-l))
- (apply 'member* (cl-check-key cl-l)
- cl-list1 cl-keys)
- (memq cl-l cl-list1)))
- collect cl-l))))))
-
-(defun intersection (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-intersection operation.
-The result list contains all items that appear in both LIST1 and LIST2.
-This is a non-destructive function; it makes a copy of the data if necessary
-to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (and cl-list1 cl-list2
- (if (equal cl-list1 cl-list2) cl-list1
- (cl-parsing-keywords (:key) (:test :test-not)
- (let ((cl-res nil))
- (or (>= (length cl-list1) (length cl-list2))
- (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
- (while cl-list2
- (if (if (or cl-keys (numberp (car cl-list2)))
- (apply 'member* (cl-check-key (car cl-list2))
- cl-list1 cl-keys)
- (memq (car cl-list2) cl-list1))
- (push (car cl-list2) cl-res))
- (pop cl-list2))
- cl-res)))))
-
-(defun nintersection (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-intersection operation.
-The result list contains all items that appear in both LIST1 and LIST2.
-This is a destructive function; it reuses the storage of LIST1 and LIST2
-whenever possible.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
+ (apply 'union cl-list1 cl-list2 :stable t cl-keys))
;; XEmacs addition: NOT IN COMMON LISP.
(defun stable-intersection (cl-list1 cl-list2 &rest cl-keys)
"Stably combine LIST1 and LIST2 using a set-intersection operation.
+
The result list contains all items that appear in both LIST1 and LIST2.
The result is \"stable\" in that it preserves the ordering of elements in
LIST1 that are also in LIST2.
+
This is a non-destructive function; it makes a copy of the data if necessary
to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
+
See `union' for the meaning of :test, :test-not and :key.
NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs
-extension."
+extension.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)"
;; The standard `intersection' doesn't produce a "stable" intersection --
;; it iterates over the second list instead of the first one, and returns
;; the values in backwards order. According to the CLTL2 documentation,
;; `intersection' is not required to preserve the ordering of elements in
- ;; any fashion, so we add a new function rather than changing the
- ;; semantics of `intersection'.
- (and cl-list1 cl-list2
- (if (equal cl-list1 cl-list2) cl-list1
- (cl-parsing-keywords (:key) (:test :test-not)
- (loop for cl-l in cl-list1
- if (if (or cl-keys (numberp cl-l))
- (apply 'member* (cl-check-key cl-l)
- cl-list2 cl-keys)
- (memq cl-l cl-list2))
- collect cl-l)))))
+ ;; any fashion, but it's trivial to implement a stable ordering in C,
+ ;; given that the order of arguments to the test function is specified.
+ (apply 'intersection cl-list1 cl-list2 :stable t cl-keys))
-(defun set-difference (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-difference operation.
-The result list contains all items that appear in LIST1 but not LIST2.
-This is a non-destructive function; it makes a copy of the data if necessary
-to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (if (or (null cl-list1) (null cl-list2)) cl-list1
- (cl-parsing-keywords (:key) (:test :test-not)
- (let ((cl-res nil))
- (while cl-list1
- (or (if (or cl-keys (numberp (car cl-list1)))
- (apply 'member* (cl-check-key (car cl-list1))
- cl-list2 cl-keys)
- (memq (car cl-list1) cl-list2))
- (push (car cl-list1) cl-res))
- (pop cl-list1))
- cl-res))))
+(defun subst-if (cl-new cl-predicate cl-tree &rest cl-keys)
+ "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
-(defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-difference operation.
-The result list contains all items that appear in LIST1 but not LIST2.
-This is a destructive function; it reuses the storage of LIST1 and LIST2
-whenever possible.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (if (or (null cl-list1) (null cl-list2)) cl-list1
- (apply 'set-difference cl-list1 cl-list2 cl-keys)))
+Return a copy of TREE with all matching elements replaced by NEW. If no
+element matches PREDICATE, return tree.
-(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-exclusive-or operation.
-The result list contains all items that appear in exactly one of LIST1, LIST2.
-This is a non-destructive function; it makes a copy of the data if necessary
-to avoid corrupting the original LIST1 and LIST2.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- ((equal cl-list1 cl-list2) nil)
- (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
- (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
+See `member*' for the meaning of :key.
-(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
- "Combine LIST1 and LIST2 using a set-exclusive-or operation.
-The result list contains all items that appear in exactly one of LIST1, LIST2.
-This is a destructive function; it reuses the storage of LIST1 and LIST2
-whenever possible.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- ((equal cl-list1 cl-list2) nil)
- (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
- (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
+arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
+ (apply 'subst cl-new 'subst cl-tree :if cl-predicate cl-keys))
-(defun subsetp (cl-list1 cl-list2 &rest cl-keys)
- "True if LIST1 is a subset of LIST2.
-I.e., if every element of LIST1 also appears in LIST2.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cond ((null cl-list1) t) ((null cl-list2) nil)
- ((equal cl-list1 cl-list2) t)
- (t (cl-parsing-keywords (:key) (:test :test-not)
- (while (and cl-list1
- (apply 'member* (cl-check-key (car cl-list1))
- cl-list2 cl-keys))
- (pop cl-list1))
- (null cl-list1)))))
+(defun subst-if-not (cl-new cl-predicate cl-tree &rest cl-keys)
+ "Substitute NEW for elements not matching PREDICATE in TREE.
-(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
- "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
-Return a copy of TREE with all matching elements replaced by NEW.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
+Return a copy of TREE with all matching elements replaced by NEW. If every
+element matches PREDICATE, return tree.
-(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
- "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
-Return a copy of TREE with all non-matching elements replaced by NEW.
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
+See `member*' for the meaning of :key.
-(defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
- "Substitute NEW for OLD everywhere in TREE (destructively).
-Any element of TREE which is `eql' to OLD is changed to NEW (via a call
-to `setcar').
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
+arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
+ (apply 'subst cl-new 'subst cl-tree :if-not cl-predicate cl-keys))
-(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
+(defun nsubst-if (cl-new cl-predicate cl-tree &rest cl-keys)
"Substitute NEW for elements matching PREDICATE in TREE (destructively).
+
Any element of TREE which matches is changed to NEW (via a call to `setcar').
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
-(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
+See `member*' for the meaning of :key.
+
+arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
+ (apply 'nsubst cl-new 'nsubst cl-tree :if cl-predicate cl-keys))
+
+(defun nsubst-if-not (cl-new cl-predicate cl-tree &rest cl-keys)
"Substitute NEW for elements not matching PREDICATE in TREE (destructively).
+
Any element of TREE which matches is changed to NEW (via a call to `setcar').
-Keywords supported: :key
-See `member*' for the meaning of :key."
- (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
-(defun sublis (cl-alist cl-tree &rest cl-keys)
- "Perform substitutions indicated by ALIST in TREE (non-destructively).
-Return a copy of TREE with all matching elements replaced.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (cl-sublis-rec cl-tree)))
+See `member*' for the meaning of :key.
-(defvar cl-alist)
-(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if*
- (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
- (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
- (setq cl-p (cdr cl-p)))
- (if cl-p (cdr (car cl-p))
- (if (consp cl-tree)
- (let ((cl-a (cl-sublis-rec (car cl-tree)))
- (cl-d (cl-sublis-rec (cdr cl-tree))))
- (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
- cl-tree
- (cons cl-a cl-d)))
- cl-tree))))
-
-(defun nsublis (cl-alist cl-tree &rest cl-keys)
- "Perform substitutions indicated by ALIST in TREE (destructively).
-Any matching element of TREE is changed via a call to `setcar'.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
- (let ((cl-hold (list cl-tree)))
- (cl-nsublis-rec cl-hold)
- (car cl-hold))))
-
-(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if*
- (while (consp cl-tree)
- (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
- (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
- (setq cl-p (cdr cl-p)))
- (if cl-p (setcar cl-tree (cdr (car cl-p)))
- (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
- (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
- (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
- (setq cl-p (cdr cl-p)))
- (if cl-p
- (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
- (setq cl-tree (cdr cl-tree))))))
-
-(defun tree-equal (cl-x cl-y &rest cl-keys)
- "Return t if trees X and Y have `eql' leaves.
-Atoms are compared by `eql'; cons cells are compared recursively.
-Keywords supported: :test :test-not :key
-See `union' for the meaning of :test, :test-not and :key."
- (cl-parsing-keywords (:test :test-not :key) ()
- (cl-tree-equal-rec cl-x cl-y)))
-
-(defun cl-tree-equal-rec (cl-x cl-y)
- (while (and (consp cl-x) (consp cl-y)
- (cl-tree-equal-rec (car cl-x) (car cl-y)))
- (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
- (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
-
-
-(run-hooks 'cl-seq-load-hook)
+arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
+ (apply 'nsubst cl-new 'nsubst cl-tree :if-not cl-predicate cl-keys))
;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c
;;; cl-seq.el ends here
diff -r f87bb35a6b94 -r d1b17a33450b lisp/cl.el
--- a/lisp/cl.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/cl.el Thu Dec 30 01:59:52 2010 +0000
＠＠ -557,36 +557,6 ＠＠
(defalias 'cl-round 'round*)
(defalias 'cl-mod 'mod*)
-(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs
- "Return ITEM consed onto the front of LIST only if it's not already there.
-Otherwise, return LIST unmodified.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (cond ((or (equal cl-keys '(:test eq))
- (and (null cl-keys) (not (numberp cl-item))))
- (if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
- ((or (equal cl-keys '(:test equal)) (null cl-keys))
- (if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
- (t (apply 'cl-adjoin cl-item cl-list cl-keys))))
-
-(defun subst (cl-new cl-old cl-tree &rest cl-keys)
- "Substitute NEW for OLD everywhere in TREE (non-destructively).
-Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
-Keywords supported: :test :test-not :key
-See `member*' for the meaning of :test, :test-not and :key."
- (if (or cl-keys (and (numberp cl-old) (not (fixnump cl-old))))
- (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
- (cl-do-subst cl-new cl-old cl-tree)))
-
-(defun cl-do-subst (cl-new cl-old cl-tree)
- (cond ((eq cl-tree cl-old) cl-new)
- ((consp cl-tree)
- (let ((a (cl-do-subst cl-new cl-old (car cl-tree)))
- (d (cl-do-subst cl-new cl-old (cdr cl-tree))))
- (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
- cl-tree (cons a d))))
- (t cl-tree)))
-
(defun acons (key value alist)
"Return a new alist created by adding (KEY . VALUE) to ALIST."
(cons (cons key value) alist))
diff -r f87bb35a6b94 -r d1b17a33450b lisp/obsolete.el
--- a/lisp/obsolete.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/obsolete.el Thu Dec 30 01:59:52 2010 +0000
＠＠ -244,6 +244,15 ＠＠
(define-compatible-function-alias 'cl-mapc 'mapc)
+;; XEmacs; old compiler macros meant that this was called directly
+;; from compiled code, and we need to provide a version of it for a
+;; couple of years at least because of that. Aidan Kehoe, Mon Oct 4
+;; 12:06:41 IST 2010
+(defun cl-delete-duplicates (cl-seq cl-keys cl-copy)
+ (apply (if cl-copy #'remove-duplicates #'delete-duplicates) cl-seq cl-keys))
+
+(make-obsolete 'cl-delete-duplicates 'delete-duplicates)
+
; old names
(define-compatible-function-alias 'byte-code-function-p
'compiled-function-p) ;FSFmacs
＠＠ -433,5 +442,8 ＠＠
(define-compatible-function-alias 'process-plist 'object-plist)
(define-compatible-function-alias 'set-process-plist 'object-setplist)
+(define-function 'memql 'member*)
+(make-compatible 'memql "use the more full-featured `member*' instead.")
+
(provide 'obsolete)
;;; obsolete.el ends here
diff -r f87bb35a6b94 -r d1b17a33450b lisp/subr.el
--- a/lisp/subr.el Thu Dec 30 01:14:13 2010 +0000
+++ b/lisp/subr.el Thu Dec 30 01:59:52 2010 +0000
＠＠ -226,6 +226,9 ＠＠
;; XEmacs; this is in Lisp, its bytecode now taken by subseq.
(define-function 'substring 'subseq)
+
+(define-function 'sort 'sort*)
+(define-function 'fillarray 'fill)
;; XEmacs:
(defun local-variable-if-set-p (sym buffer)
＠＠ -1104,13 +1107,13 ＠＠
"Replace the variable names in MAP-PLIST-DEFINITION with uninterned
symbols, avoiding the risk of interference with variables in other functions
introduced by dynamic scope."
- (if-fboundp 'nsublis
- (nsublis
- '((mp-function . #:function)
- (plist . #:plist)
- (result . #:result))
- map-plist-definition)
- map-plist-definition)))
+ (nsublis '((mp-function . #:function)
+ (plist . #:plist)
+ (result . #:result))
+ ;; Need to specify #'eq as the test, otherwise we have a
+ ;; bootstrap issue, since #'eql is in cl.el, loaded after
+ ;; this file.
+ map-plist-definition :test #'eq)))
(defun map-plist (mp-function plist)
"Map FUNCTION (a function of two args) over each key/value pair in PLIST.
Return a list of the results."
diff -r f87bb35a6b94 -r d1b17a33450b src/ChangeLog
--- a/src/ChangeLog Thu Dec 30 01:14:13 2010 +0000
+++ b/src/ChangeLog Thu Dec 30 01:59:52 2010 +0000
＠＠ -1,3 +1,50 ＠＠
+2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Move the heavy lifting from cl-seq.el to C, finally making those
+ functions first-class XEmacs citizens, with circularity checking,
+ built-in support for tests other than #'eql, and as much
+ compatibility with current Common Lisp as Paul Dietz' tests require.
+
+ * fns.c (check_eq_nokey, check_eq_key, check_eql_nokey)
+ (check_eql_key, check_equal_nokey, check_equal_key)
+ (check_equalp_nokey, check_equalp_key, check_string_match_nokey)
+ (check_string_match_key, check_other_nokey, check_other_key)
+ (check_if_nokey, check_if_key, check_match_eq_key)
+ (check_match_eql_key, check_match_equal_key)
+ (check_match_equalp_key, check_match_other_key): New. These are
+ basically to provide function pointers to be used by Lisp
+ functions that take TEST, TEST-NOT and KEY arguments.
+
+ (get_check_match_function_1, get_check_test_function)
+ (get_check_match_function): These functions work out which of the
+ previous list of functions to use, given the keywords supplied by
+ the user.
+
+ (count_with_tail): New. This is the bones of #'count.
+ (list_count_from_end, string_count_from_end): Utility functions
+ for #'count.
+ (Fcount): New, moved from cl-seq.el.
+ (list_position_cons_before): New. The implementation of #'member*,
+ and important in implementing various other functions.
+
+ (FmemberX, Fadjoin, FassocX, FrassocX, Fposition, Ffind)
+ (FdeleteX, FremoveX, Fdelete_duplicates, Fremove_duplicates)
+ (Fnsubstitute, Fsubstitute, Fsublis, Fnsublis, Fsubst, Fnsubst)
+ (Ftree_equal, Fmismatch, Fsearch, Fintersection, Fnintersection)
+ (Fsubsetp, Fset_difference, Fnset_difference, Fnunion, Funion)
+ (Fset_exclusive_or, Fnset_exclusive_or): New, moved here from
+ cl-seq.el.
+
+ (position): New. The implementation of #'find and #'position.
+ (list_delete_duplicates_from_end, subst, sublis, nsublis)
+ (tree_equal, mismatch_from_end, mismatch_list_list)
+ (mismatch_list_string, mismatch_list_array)
+ (mismatch_string_array, mismatch_string_string)
+ (mismatch_array_array, get_mismatch_func): Helper C functions for
+ the Lisp-visible functions.
+ (venn, nvenn): New. The implementation of the main Lisp functions that
+ treat lists as sets.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* lisp.h (DECLARE_N_KEYWORDS_8, DECLARE_N_KEYWORDS_9)
diff -r f87bb35a6b94 -r d1b17a33450b src/fns.c
--- a/src/fns.c Thu Dec 30 01:14:13 2010 +0000
+++ b/src/fns.c Thu Dec 30 01:59:52 2010 +0000
＠＠ -54,16 +54,23 ＠＠
/* NOTE: This symbol is also used in lread.c */
#define FEATUREP_SYNTAX
-Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill, Qreplace;
-Lisp_Object Qidentity;
+Lisp_Object Qstring_lessp, Qmerge, Qfill, Qreplace, QassocX, QrassocX;
+Lisp_Object Qposition, Qfind, QdeleteX, QremoveX, Qidentity, Qadjoin;
Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value;
Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into;
-Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce;
-Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2;
+Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce, Qsubstitute;
+Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable;
+Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch;
+
+Lisp_Object Qintersection, Qnintersection, Qset_difference, Qnset_difference;
+Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qnset_difference;
Lisp_Object Qbase64_conversion_error;
Lisp_Object Vpath_separator;
+
+extern Fixnum max_lisp_eval_depth;
+extern int lisp_eval_depth;
static int internal_old_equal (Lisp_Object, Lisp_Object, int);
Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
＠＠ -199,6 +206,445 ＠＠
bit_vector_description,
size_bit_vector,
Lisp_Bit_Vector);
+
+/* Various test functions for #'member*, #'assoc* and the other functions
+ that take both TEST and KEY arguments. */
+
+typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt);
+
+static Boolint
+check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ return EQ (item, elt);
+}
+
+static Boolint
+check_eq_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
+ Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return EQ (item, elt);
+}
+
+/* The next two are not used by #'member* and #'assoc*, since we can decide
+ on #'eq vs. #'equal when we have the type of ITEM. */
+static Boolint
+check_eql_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ return EQ (elt1, elt2)
+ || (NON_FIXNUM_NUMBER_P (elt1) && internal_equal (elt1, elt2, 0));
+}
+
+static Boolint
+check_eql_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
+ Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return EQ (item, elt)
+ || (NON_FIXNUM_NUMBER_P (item) && internal_equal (item, elt, 0));
+}
+
+static Boolint
+check_equal_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ return internal_equal (item, elt, 0);
+}
+
+static Boolint
+check_equal_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
+ Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return internal_equal (item, elt, 0);
+}
+
+static Boolint
+check_equalp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ return internal_equalp (item, elt, 0);
+}
+
+static Boolint
+check_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return internal_equalp (item, elt, 0);
+}
+
+static Boolint
+check_string_match_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ return !NILP (Fstring_match (item, elt, Qnil, Qnil));
+}
+
+static Boolint
+check_string_match_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
+ return !NILP (Fstring_match (item, elt, Qnil, Qnil));
+}
+
+static Boolint
+check_other_nokey (Lisp_Object test, Lisp_Object UNUSED (key),
+ Lisp_Object item, Lisp_Object elt)
+{
+ Lisp_Object args[] = { test, item, elt };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ UNGCPRO;
+
+ return !NILP (item);
+}
+
+static Boolint
+check_other_key (Lisp_Object test, Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt)
+{
+ Lisp_Object args[] = { item, key, elt };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args) - 1, args + 1));
+ args[1] = item;
+ args[0] = test;
+ item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ UNGCPRO;
+
+ return !NILP (item);
+}
+
+static Boolint
+check_if_nokey (Lisp_Object test, Lisp_Object UNUSED (key),
+ Lisp_Object UNUSED (item), Lisp_Object elt)
+{
+ elt = IGNORE_MULTIPLE_VALUES (call1 (test, elt));
+ return !NILP (elt);
+}
+
+static Boolint
+check_if_key (Lisp_Object test, Lisp_Object key,
+ Lisp_Object UNUSED (item), Lisp_Object elt)
+{
+ Lisp_Object args[] = { key, elt };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ args[0] = test;
+ elt = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ UNGCPRO;
+
+ return !NILP (elt);
+}
+
+static Boolint
+check_match_eq_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return EQ (args[0], args[1]);
+}
+
+static Boolint
+check_match_eql_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return EQ (args[0], args[1]) ||
+ (NON_FIXNUM_NUMBER_P (args[0]) && internal_equal (args[0], args[1], 0));
+}
+
+static Boolint
+check_match_equal_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return internal_equal (args[0], args[1], 0);
+}
+
+static Boolint
+check_match_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return internal_equalp (args[0], args[1], 0);
+}
+
+static Boolint
+check_match_other_key (Lisp_Object test, Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ args[1] = args[0];
+ args[0] = test;
+
+ elt1 = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
+ UNGCPRO;
+
+ return !NILP (elt1);
+}
+
+static check_test_func_t
+get_check_match_function_1 (Lisp_Object item,
+ Lisp_Object *test_inout, Lisp_Object test_not,
+ Lisp_Object if_, Lisp_Object if_not,
+ Lisp_Object key, Boolint *test_not_unboundp_out,
+ check_test_func_t *test_func_out)
+{
+ Lisp_Object test = *test_inout;
+ check_test_func_t result = NULL, test_func = NULL;
+ Boolint force_if = 0;
+
+ if (!NILP (if_))
+ {
+ if (!(NILP (test) && NILP (test_not) && NILP (if_not)))
+ {
+ invalid_argument ("only one keyword among :test :test-not "
+ ":if :if-not allowed", if_);
+ }
+
+ test = *test_inout = if_;
+ force_if = 1;
+ }
+ else if (!NILP (if_not))
+ {
+ if (!(NILP (test) && NILP (test_not)))
+ {
+ invalid_argument ("only one keyword among :test :test-not "
+ ":if :if-not allowed", if_not);
+ }
+
+ test_not = if_not;
+ force_if = 1;
+ }
+
+ if (NILP (test))
+ {
+ if (!NILP (test_not))
+ {
+ test = *test_inout = test_not;
+ if (NULL != test_not_unboundp_out)
+ {
+ *test_not_unboundp_out = 0;
+ }
+ }
+ else
+ {
+ test = Qeql;
+ if (NULL != test_not_unboundp_out)
+ {
+ *test_not_unboundp_out = 1;
+ }
+ }
+ }
+ else if (!NILP (test_not))
+ {
+ invalid_argument_2 ("conflicting :test and :test-not keyword arguments",
+ test, test_not);
+ }
+
+ test = indirect_function (test, 1);
+
+ if (NILP (key) ||
+ EQ (indirect_function (key, 1), XSYMBOL_FUNCTION (Qidentity)))
+ {
+ key = Qidentity;
+ }
+
+ if (force_if)
+ {
+ result = EQ (key, Qidentity) ? check_if_nokey : check_if_key;
+
+ if (NULL != test_func_out)
+ {
+ *test_func_out = result;
+ }
+
+ return result;
+ }
+
+ if (!UNBOUNDP (item) && EQ (test, XSYMBOL_FUNCTION (Qeql)))
+ {
+ test = XSYMBOL_FUNCTION (NON_FIXNUM_NUMBER_P (item) ? Qequal : Qeq);
+ }
+
+#define FROB(known_test, eq_condition) \
+ if (EQ (test, XSYMBOL_FUNCTION (Q##known_test))) do \
+ { \
+ if (eq_condition) \
+ { \
+ test = XSYMBOL_FUNCTION (Qeq); \
+ goto force_eq_check; \
+ } \
+ \
+ if (!EQ (Qidentity, key)) \
+ { \
+ test_func = check_##known_test##_key; \
+ result = check_match_##known_test##_key; \
+ } \
+ else \
+ { \
+ result = test_func = check_##known_test##_nokey; \
+ } \
+ } while (0)
+
+ FROB (eql, 0);
+ else if (SUBRP (test))
+ {
+ force_eq_check:
+ FROB (eq, 0);
+ else FROB (equal, (SYMBOLP (item) || INTP (item) || CHARP (item)));
+ else FROB (equalp, (SYMBOLP (item)));
+ else if (EQ (test, XSYMBOL_FUNCTION (Qstring_match)))
+ {
+ if (EQ (Qidentity, key))
+ {
+ test_func = result = check_string_match_nokey;
+ }
+ else
+ {
+ test_func = check_string_match_key;
+ result = check_other_key;
+ }
+ }
+ }
+
+ if (NULL == result)
+ {
+ if (EQ (Qidentity, key))
+ {
+ test_func = result = check_other_nokey;
+ }
+ else
+ {
+ test_func = check_other_key;
+ result = check_match_other_key;
+ }
+ }
+
+ if (NULL != test_func_out)
+ {
+ *test_func_out = test_func;
+ }
+
+ return result;
+}
+#undef FROB
+
+/* Given TEST, TEST_NOT, IF, IF_NOT, KEY, and ITEM, return a C function
+ pointer appropriate for use in deciding whether a given element of a
+ sequence satisfies TEST.
+
+ Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero
+ if it was bound, and set *test_inout to the value it was bound to. If
+ TEST was not bound, leave *test_inout alone; the value is not used by
+ check_eq_*key() or check_equal_*key(), which are the defaults, depending
+ on the type of ITEM.
+
+ The returned function takes arguments (TEST, KEY, ITEM, ELT), where ITEM
+ is the item being searched for and ELT is the element of the sequence
+ being examined.
+
+ Error if both TEST and TEST_NOT were specified, which Common Lisp says is
+ undefined behaviour. */
+
+static check_test_func_t
+get_check_test_function (Lisp_Object item,
+ Lisp_Object *test_inout, Lisp_Object test_not,
+ Lisp_Object if_, Lisp_Object if_not,
+ Lisp_Object key, Boolint *test_not_unboundp_out)
+{
+ check_test_func_t result = NULL;
+ get_check_match_function_1 (item, test_inout, test_not, if_, if_not,
+ key, test_not_unboundp_out, &result);
+ return result;
+}
+
+/* Given TEST, TEST_NOT, IF, IF_NOT and KEY, return a C function pointer
+ appropriate for use in deciding whether two given elements of a sequence
+ satisfy TEST.
+
+ Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero
+ if it was bound, and set *test_inout to the value it was bound to. If
+ TEST was not bound, leave *test_inout alone; the value is not used by
+ check_eql_*key().
+
+ The returned function takes arguments (TEST, KEY, ELT1, ELT2), where ELT1
+ and ELT2 are elements of the sequence being examined.
+
+ The value that would be given by get_check_test_function() is returned in
+ *TEST_FUNC_OUT, which allows calling functions to do their own key checks
+ if they're processing one element at a time.
+
+ Error if both TEST and TEST_NOT were specified, which Common Lisp says is
+ undefined behaviour. */
+
+static check_test_func_t
+get_check_match_function (Lisp_Object *test_inout, Lisp_Object test_not,
+ Lisp_Object if_, Lisp_Object if_not,
+ Lisp_Object key, Boolint *test_not_unboundp_out,
+ check_test_func_t *test_func_out)
+{
+ return get_check_match_function_1 (Qunbound, test_inout, test_not,
+ if_, if_not, key,
+ test_not_unboundp_out, test_func_out);
+}
DEFUN ("identity", Fidentity, 1, 1, 0, /*
＠＠ -366,7 +812,316 ＠＠
return EQ (hare, tortoise) && len != 0 ? Qnil : make_int (len);
}
-
+
+static Lisp_Object string_count_from_end (Lisp_Object, Lisp_Object ,
+ check_test_func_t, Boolint,
+ Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object);
+
+static Lisp_Object list_count_from_end (Lisp_Object, Lisp_Object,
+ check_test_func_t, Boolint,
+ Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object);
+
+/* Count the number of occurrences of ITEM in SEQUENCE; if SEQUENCE is a
+ list, store the cons cell of which the car is the last ITEM in SEQUENCE,
+ at the address given by tail_out. */
+
+static Lisp_Object
+count_with_tail (Lisp_Object *tail_out, int nargs, Lisp_Object *args,
+ Lisp_Object caller)
+{
+ Lisp_Object item = args[0], sequence = args[1];
+ Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0;
+ Elemcount len, ii = 0, counting = EMACS_INT_MAX;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS_8 (caller, nargs, args, 9,
+ (test, key, start, end, from_end, test_not, count,
+ if_, if_not), (start = Qzero), 2, 0);
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ counting = BIGNUMP (count) ? EMACS_INT_MAX + 1 : XINT (count);
+
+ /* 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));
+ }
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ *tail_out = Qnil;
+
+ if (CONSP (sequence))
+ {
+ Lisp_Object elt, tail = Qnil;
+ struct gcpro gcpro1;
+
+ if (EQ (caller, Qcount) && !NILP (from_end)
+ && (!EQ (key, Qnil) ||
+ check_test == check_other_nokey || check_test == check_if_nokey))
+ {
+ /* #'count, #'count-if, and #'count-if-not are documented to have
+ a given traversal order if :from-end t is passed in, even
+ though forward traversal of the sequence has the same result
+ and is algorithmically less expensive for lists and strings.
+ This order isn't necessary for other callers, though. */
+ return list_count_from_end (item, sequence, check_test,
+ test_not_unboundp, test, key,
+ start, end);
+ }
+
+ GCPRO1 (tail);
+
+ /* If COUNT is non-nil and FROM-END is t, we can give the tail
+ containing the last match, since that's what #'remove* is
+ interested in (a zero or negative COUNT won't ever reach
+ count_with_tail(), our callers will return immediately on seeing
+ it). */
+ if (!NILP (count) && !NILP (from_end))
+ {
+ counting = EMACS_INT_MAX;
+ }
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (!(ii < ending))
+ {
+ break;
+ }
+
+ if (starting <= ii &&
+ check_test (test, key, item, elt) == test_not_unboundp)
+ {
+ encountered++;
+ *tail_out = tail;
+
+ if (encountered == counting)
+ {
+ break;
+ }
+ }
+
+ ii++;
+ }
+ }
+
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end))) &&
+ encountered != counting)
+ {
+ check_sequence_range (args[1], start, end, Flength (args[1]));
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
+ Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
+ Lisp_Object character = Qnil;
+
+ if (EQ (caller, Qcount) && !NILP (from_end)
+ && (!EQ (key, Qnil) ||
+ check_test == check_other_nokey || check_test == check_if_nokey))
+ {
+ /* See comment above in the list code. */
+ return string_count_from_end (item, sequence,
+ check_test, test_not_unboundp,
+ test, key, start, end);
+ }
+
+ while (cursor_offset < byte_len && ii < ending && encountered < counting)
+ {
+ if (ii >= starting)
+ {
+ character = make_char (itext_ichar (cursor));
+
+ if (check_test (test, key, item, character)
+ == test_not_unboundp)
+ {
+ encountered++;
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (caller, sequence);
+ }
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+ }
+ else
+ {
+ Lisp_Object object = Qnil;
+
+ len = XINT (Flength (sequence));
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ ending = min (ending, len);
+ if (0 == len)
+ {
+ /* Catches the case where we have nil. */
+ return make_integer (encountered);
+ }
+
+ if (NILP (from_end))
+ {
+ for (ii = starting; ii < ending && encountered < counting; ii++)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (check_test (test, key, item, object) == test_not_unboundp)
+ {
+ encountered++;
+ }
+ }
+ }
+ else
+ {
+ for (ii = ending - 1; ii >= starting && encountered < counting; ii--)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (check_test (test, key, item, object) == test_not_unboundp)
+ {
+ encountered++;
+ }
+ }
+ }
+ }
+
+ return make_integer (encountered);
+}
+
+static Lisp_Object
+list_count_from_end (Lisp_Object item, Lisp_Object sequence,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Lisp_Object start, Lisp_Object end)
+{
+ Elemcount length = XINT (Flength (sequence)), ii = 0, starting = XINT (start);
+ Elemcount ending = NILP (end) ? length : XINT (end), encountered = 0;
+ Lisp_Object *storage;
+ struct gcpro gcpro1;
+
+ check_sequence_range (sequence, start, end, make_integer (length));
+
+ storage = alloca_array (Lisp_Object, ending - starting);
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence)
+ {
+ if (starting <= ii && ii < ending)
+ {
+ storage[ii - starting] = elt;
+ }
+ ii++;
+ }
+ }
+
+ GCPRO1 (storage[0]);
+ gcpro1.nvars = ending - starting;
+
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ if (check_test (test, key, item, storage[ii - starting])
+ == test_not_unboundp)
+ {
+ encountered++;
+ }
+ }
+
+ UNGCPRO;
+
+ return make_integer (encountered);
+}
+
+static Lisp_Object
+string_count_from_end (Lisp_Object item, Lisp_Object sequence,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Lisp_Object start, Lisp_Object end)
+{
+ Elemcount length = string_char_length (sequence), ii = 0;
+ Elemcount starting = XINT (start), ending = NILP (end) ? length : XINT (end);
+ Elemcount encountered = 0;
+ Ibyte *cursor = XSTRING_DATA (sequence);
+ Ibyte *endp = cursor + XSTRING_LENGTH (sequence);
+ Ichar *storage;
+
+ check_sequence_range (sequence, start, end, make_integer (length));
+
+ storage = alloca_array (Ichar, ending - starting);
+
+ while (cursor < endp && ii < ending)
+ {
+ if (starting <= ii && ii < ending)
+ {
+ storage [ii - starting] = itext_ichar (cursor);
+ }
+
+ ii++;
+ INC_IBYTEPTR (cursor);
+ }
+
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ if (check_test (test, key, item, make_char (storage [ii - starting]))
+ == test_not_unboundp)
+ {
+ encountered++;
+ }
+ }
+
+ return make_integer (encountered);
+}
+
+DEFUN ("count", Fcount, 2, MANY, 0, /*
+Count the number of occurrences of ITEM in SEQUENCE.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object tail = Qnil;
+
+ /* count_with_tail() accepts more keywords than we do, check those we've
+ been given. */
+ PARSE_KEYWORDS (Fcount, nargs, args, 8,
+ (test, test_not, if_, if_not, key, start, end, from_end),
+ NULL);
+
+ return count_with_tail (&tail, nargs, args, Qcount);
+}
+
/*** string functions. ***/
DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
＠＠ -1002,7 +1757,7 ＠＠
Lisp_Object
safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
{
- if (depth > 200)
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
stack_overflow ("Stack overflow in copy-tree", arg);
if (CONSP (arg))
＠＠ -1742,978 +2497,116 ＠＠
return Qnil;
}
-DEFUN ("assoc", Fassoc, 2, 2, 0, /*
-Return non-nil if KEY is `equal' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car equals KEY.
-*/
- (key, alist))
-{
- /* This function can GC. */
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_equal (key, elt_car, 0))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
-Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car equals KEY.
-*/
- (key, alist))
-{
- /* This function can GC. */
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_old_equal (key, elt_car, 0))
- return elt;
- }
- return Qnil;
-}
-
-Lisp_Object
-assoc_no_quit (Lisp_Object key, Lisp_Object alist)
-{
- int speccount = specpdl_depth ();
- specbind (Qinhibit_quit, Qt);
- return unbind_to_1 (speccount, Fassoc (key, alist));
-}
-
-DEFUN ("assq", Fassq, 2, 2, 0, /*
-Return non-nil if KEY is `eq' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car is KEY.
-Elements of ALIST that are not conses are ignored.
-*/
- (key, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
-Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car is KEY.
-Elements of ALIST that are not conses are ignored.
-This function is provided only for byte-code compatibility with v19.
-Do not use it.
-*/
- (key, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (HACKEQ_UNSAFE (key, elt_car))
- return elt;
- }
- return Qnil;
-}
-
-/* Like Fassq but never report an error and do not allow quits.
- Use only on lists known never to be circular. */
-
-Lisp_Object
-assq_no_quit (Lisp_Object key, Lisp_Object alist)
-{
- /* This cannot GC. */
- LIST_LOOP_2 (elt, alist)
- {
- Lisp_Object elt_car = XCAR (elt);
- if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
-Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr equals VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_equal (value, elt_cdr, 0))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
-Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr equals VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_old_equal (value, elt_cdr, 0))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("rassq", Frassq, 2, 2, 0, /*
-Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr is VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
-Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr is VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (HACKEQ_UNSAFE (value, elt_cdr))
- return elt;
- }
- return Qnil;
-}
-
-/* Like Frassq, but caller must ensure that ALIST is properly
- nil-terminated and ebola-free. */
-Lisp_Object
-rassq_no_quit (Lisp_Object value, Lisp_Object alist)
-{
- LIST_LOOP_2 (elt, alist)
- {
- Lisp_Object elt_cdr = XCDR (elt);
- if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
- return elt;
- }
- return Qnil;
-}
-
-
-DEFUN ("delete", Fdelete, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `equal'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (delete element foo))' to be sure
-of changing the value of `foo'.
-Also see: `remove'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (internal_equal (elt, list_elt, 0)));
- return list;
-}
-
-DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `old-equal'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (old-delete element foo))' to be sure
-of changing the value of `foo'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (internal_old_equal (elt, list_elt, 0)));
- return list;
-}
-
-DEFUN ("delq", Fdelq, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `eq'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (delq element foo))' to be sure of
-changing the value of `foo'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
- return list;
-}
-
-DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `old-eq'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
-changing the value of `foo'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (HACKEQ_UNSAFE (elt, list_elt)));
- return list;
-}
-
-/* Like Fdelq, but caller must ensure that LIST is properly
- nil-terminated and ebola-free. */
-
-Lisp_Object
-delq_no_quit (Lisp_Object elt, Lisp_Object list)
-{
- LIST_LOOP_DELETE_IF (list_elt, list,
- (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
- return list;
-}
-
-/* Be VERY careful with this. This is like delq_no_quit() but
- also calls free_cons() on the removed conses. You must be SURE
- that no pointers to the freed conses remain around (e.g.
- someone else is pointing to part of the list). This function
- is useful on internal lists that are used frequently and where
- the actual list doesn't escape beyond known code bounds. */
-
-Lisp_Object
-delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
-{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- REGISTER Lisp_Object tem = XCAR (tail);
- if (EQ (elt, tem))
- {
- Lisp_Object cons_to_free = tail;
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- tail = XCDR (tail);
- free_cons (cons_to_free);
- }
- else
- {
- prev = tail;
- tail = XCDR (tail);
- }
- }
- return list;
-}
-
-DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
-Delete by side effect any elements of ALIST whose car is `equal' to KEY.
-The modified ALIST is returned. If the first member of ALIST has a car
-that is `equal' to KEY, there is no way to remove it by side effect;
-therefore, write `(setq foo (remassoc key foo))' to be sure of changing
-the value of `foo'.
-*/
- (key, alist))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- internal_equal (key, XCAR (elt), 0)));
- return alist;
-}
-
-Lisp_Object
-remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
-{
- int speccount = specpdl_depth ();
- specbind (Qinhibit_quit, Qt);
- return unbind_to_1 (speccount, Fremassoc (key, alist));
-}
-
-DEFUN ("remassq", Fremassq, 2, 2, 0, /*
-Delete by side effect any elements of ALIST whose car is `eq' to KEY.
-The modified ALIST is returned. If the first member of ALIST has a car
-that is `eq' to KEY, there is no way to remove it by side effect;
-therefore, write `(setq foo (remassq key foo))' to be sure of changing
-the value of `foo'.
-*/
- (key, alist))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
- return alist;
-}
-
-/* no quit, no errors; be careful */
-
-Lisp_Object
-remassq_no_quit (Lisp_Object key, Lisp_Object alist)
-{
- LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
- return alist;
-}
-
-DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
-Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
-The modified ALIST is returned. If the first member of ALIST has a car
-that is `equal' to VALUE, there is no way to remove it by side effect;
-therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
-the value of `foo'.
-*/
- (value, alist))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- internal_equal (value, XCDR (elt), 0)));
- return alist;
-}
-
-DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
-Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
-The modified ALIST is returned. If the first member of ALIST has a car
-that is `eq' to VALUE, there is no way to remove it by side effect;
-therefore, write `(setq foo (remrassq value foo))' to be sure of changing
-the value of `foo'.
-*/
- (value, alist))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
- return alist;
-}
-
-/* Like Fremrassq, fast and unsafe; be careful */
-Lisp_Object
-remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
-{
- LIST_LOOP_DELETE_IF (elt, alist,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
- return alist;
-}
-
-DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
-Reverse SEQUENCE, destructively.
-
-Return the beginning of the reversed sequence, which will be a distinct Lisp
-object if SEQUENCE is a list with length greater than one. See also
-`reverse', the non-destructive version of this function.
-*/
- (sequence))
-{
- CHECK_SEQUENCE (sequence);
-
- if (CONSP (sequence))
- {
- struct gcpro gcpro1, gcpro2;
- Lisp_Object prev = Qnil;
- Lisp_Object tail = sequence;
-
- /* We gcpro our args; see `nconc' */
- GCPRO2 (prev, tail);
- while (!NILP (tail))
- {
- REGISTER Lisp_Object next;
- CONCHECK_CONS (tail);
- next = XCDR (tail);
- XCDR (tail) = prev;
- prev = tail;
- tail = next;
- }
- UNGCPRO;
- return prev;
- }
- else if (VECTORP (sequence))
- {
- Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
- Elemcount half = length / 2;
- Lisp_Object swap = Qnil;
- CHECK_LISP_WRITEABLE (sequence);
-
- while (ii > half)
- {
- swap = XVECTOR_DATA (sequence) [length - ii];
- XVECTOR_DATA (sequence) [length - ii]
- = XVECTOR_DATA (sequence) [ii - 1];
- XVECTOR_DATA (sequence) [ii - 1] = swap;
- --ii;
- }
- }
- else if (STRINGP (sequence))
- {
- Elemcount length = XSTRING_LENGTH (sequence);
- Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
- Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
-
- CHECK_LISP_WRITEABLE (sequence);
- while (cursor < endp)
- {
- staging_end -= itext_ichar_len (cursor);
- itext_copy_ichar (cursor, staging_end);
- INC_IBYTEPTR (cursor);
- }
-
- assert (staging == staging_end);
-
- memcpy (XSTRING_DATA (sequence), staging, length);
- init_string_ascii_begin (sequence);
- bump_string_modiff (sequence);
- sledgehammer_check_ascii_begin (sequence);
- }
- else if (BIT_VECTORP (sequence))
- {
- Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
- Elemcount length = bit_vector_length (bv), ii = length;
- Elemcount half = length / 2;
- int swap = 0;
-
- CHECK_LISP_WRITEABLE (sequence);
- while (ii > half)
- {
- swap = bit_vector_bit (bv, length - ii);
- set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1));
- set_bit_vector_bit (bv, ii - 1, swap);
- --ii;
- }
- }
- else
- {
- assert (NILP (sequence));
- }
-
- return sequence;
-}
-
-DEFUN ("reverse", Freverse, 1, 1, 0, /*
-Reverse SEQUENCE, copying. Return the reversed sequence.
-See also the function `nreverse', which is used more often.
-*/
- (sequence))
-{
- Lisp_Object result = Qnil;
-
- CHECK_SEQUENCE (sequence);
-
- if (CONSP (sequence))
- {
- EXTERNAL_LIST_LOOP_2 (elt, sequence)
- {
- result = Fcons (elt, result);
- }
- }
- else if (VECTORP (sequence))
- {
- Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
- Lisp_Object *staging = alloca_array (Lisp_Object, length);
-
- while (ii > 0)
- {
- staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1];
- --ii;
- }
-
- result = Fvector (length, staging);
- }
- else if (STRINGP (sequence))
- {
- Elemcount length = XSTRING_LENGTH (sequence);
- Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
- Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
-
- while (cursor < endp)
- {
- staging_end -= itext_ichar_len (cursor);
- itext_copy_ichar (cursor, staging_end);
- INC_IBYTEPTR (cursor);
- }
-
- assert (staging == staging_end);
-
- result = make_string (staging, length);
- }
- else if (BIT_VECTORP (sequence))
- {
- Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res;
- Elemcount length = bit_vector_length (bv), ii = length;
-
- result = make_bit_vector (length, Qzero);
- res = XBIT_VECTOR (result);
-
- while (ii > 0)
- {
- set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1));
- --ii;
- }
- }
- else
- {
- assert (NILP (sequence));
- }
-
- return result;
-}
-
-static Lisp_Object
-c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object key_func)
-{
- struct gcpro gcpro1;
- Lisp_Object args[3];
-
- /* We could use call2() and call3() here, but we're called O(nlogn) times
- for a sequence of length n, it make some sense to inline them. */
- args[0] = key_func;
- args[1] = obj1;
- args[2] = Qnil;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = countof (args);
-
- obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
-
- args[1] = obj2;
- obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
-
- args[0] = pred;
- args[1] = obj1;
- args[2] = obj2;
-
- RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
-}
-
-static Lisp_Object
-c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object UNUSED (key_func))
-{
- struct gcpro gcpro1;
- Lisp_Object args[3];
-
- /* This is (almost) the implementation of call2, it makes some sense to
- inline it here. */
- args[0] = pred;
- args[1] = obj1;
- args[2] = obj2;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = countof (args);
-
- RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
-}
-
-Lisp_Object
-list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
-{
- Lisp_Object value;
- Lisp_Object tail;
- Lisp_Object tem;
- Lisp_Object l1, l2;
- Lisp_Object tortoises[2];
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
- int l1_count = 0, l2_count = 0;
-
- l1 = org_l1;
- l2 = org_l2;
- tail = Qnil;
- value = Qnil;
- tortoises[0] = org_l1;
- tortoises[1] = org_l2;
-
- if (NULL == c_predicate)
- {
- c_predicate = EQ (key_func, Qidentity) ?
- c_merge_predicate_nokey : c_merge_predicate_key;
- }
-
- /* It is sufficient to protect org_l1 and org_l2.
- When l1 and l2 are updated, we copy the new values
- back into the org_ vars. */
-
- GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
- gcpro5.nvars = 2;
-
- while (1)
- {
- if (NILP (l1))
- {
- UNGCPRO;
- if (NILP (tail))
- return l2;
- Fsetcdr (tail, l2);
- return value;
- }
- if (NILP (l2))
- {
- UNGCPRO;
- if (NILP (tail))
- return l1;
- Fsetcdr (tail, l1);
- return value;
- }
-
- if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func)))
- {
- tem = l1;
- l1 = Fcdr (l1);
- org_l1 = l1;
-
- if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
- {
- if (l1_count & 1)
- {
- if (!CONSP (tortoises[0]))
- {
- mapping_interaction_error (Qmerge, tortoises[0]);
- }
-
- tortoises[0] = XCDR (tortoises[0]);
- }
-
- if (EQ (org_l1, tortoises[0]))
- {
- signal_circular_list_error (org_l1);
- }
- }
- }
- else
- {
- tem = l2;
- l2 = Fcdr (l2);
- org_l2 = l2;
-
- if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
- {
- if (l2_count & 1)
- {
- if (!CONSP (tortoises[1]))
- {
- mapping_interaction_error (Qmerge, tortoises[1]);
- }
-
- tortoises[1] = XCDR (tortoises[1]);
- }
-
- if (EQ (org_l2, tortoises[1]))
- {
- signal_circular_list_error (org_l2);
- }
- }
- }
-
- if (NILP (tail))
- value = tem;
- else
- Fsetcdr (tail, tem);
-
- tail = tem;
- }
-}
-
-static void
-array_merge (Lisp_Object *dest, Elemcount dest_len,
- Lisp_Object *front, Elemcount front_len,
- Lisp_Object *back, Elemcount back_len,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
-{
- Elemcount ii, fronting, backing;
- Lisp_Object *front_staging = front;
- Lisp_Object *back_staging = back;
+/* Return the first index of ITEM in LIST. In CONS_OUT, return the cons cell
+ before that containing the element. If the element is in the first cons
+ cell, return Qnil in CONS_OUT. TEST, KEY, START, END are as in
+ #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should have been initialized
+ with get_check_match_function() or get_check_test_function(). A non-zero
+ REVERSE_TEST_ORDER means call TEST with the element from LIST as its
+ first argument and ITEM as its second. Error if LIST is ill-formed, or
+ circular. */
+static Lisp_Object
+list_position_cons_before (Lisp_Object *cons_out,
+ Lisp_Object item, Lisp_Object list,
+ check_test_func_t check_test,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint reverse_test_order,
+ Lisp_Object start, Lisp_Object end)
+{
struct gcpro gcpro1, gcpro2;
-
- assert (dest_len == (back_len + front_len));
-
- if (0 == dest_len)
- {
- return;
- }
-
- if (front >= dest && front < (dest + dest_len))
- {
- front_staging = alloca_array (Lisp_Object, front_len);
-
- for (ii = 0; ii < front_len; ++ii)
- {
- front_staging[ii] = front[ii];
- }
- }
-
- if (back >= dest && back < (dest + dest_len))
- {
- back_staging = alloca_array (Lisp_Object, back_len);
-
- for (ii = 0; ii < back_len; ++ii)
- {
- back_staging[ii] = back[ii];
- }
- }
-
- GCPRO2 (front_staging[0], back_staging[0]);
- gcpro1.nvars = front_len;
- gcpro2.nvars = back_len;
-
- for (ii = fronting = backing = 0; ii < dest_len; ++ii)
- {
- if (fronting >= front_len)
- {
- while (ii < dest_len)
- {
- dest[ii] = back_staging[backing];
- ++ii, ++backing;
- }
- UNGCPRO;
- return;
- }
-
- if (backing >= back_len)
- {
- while (ii < dest_len)
- {
- dest[ii] = front_staging[fronting];
- ++ii, ++fronting;
- }
- UNGCPRO;
- return;
- }
-
- if (NILP (c_predicate (back_staging[backing], front_staging[fronting],
- predicate, key_func)))
- {
- dest[ii] = front_staging[fronting];
- ++fronting;
- }
- else
- {
- dest[ii] = back_staging[backing];
- ++backing;
- }
- }
-
- UNGCPRO;
-}
-
-static Lisp_Object
-list_array_merge_into_list (Lisp_Object list,
- Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func,
- Boolint reverse_order)
-{
- Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
- Elemcount array_index = 0;
- int looped = 0;
-
- GCPRO4 (list, tail, value, tortoise);
-
- while (1)
- {
- if (NILP (list))
- {
- UNGCPRO;
-
- if (NILP (tail))
- {
- return Flist (array_len, array);
- }
-
- Fsetcdr (tail, Flist (array_len - array_index, array + array_index));
- return value;
- }
-
- if (array_index >= array_len)
- {
- UNGCPRO;
- if (NILP (tail))
- {
- return list;
- }
-
- Fsetcdr (tail, list);
- return value;
- }
-
-
- if (reverse_order ?
- !NILP (c_predicate (Fcar (list), array [array_index], predicate,
- key_func)) :
- NILP (c_predicate (array [array_index], Fcar (list), predicate,
- key_func)))
- {
- if (NILP (tail))
- {
- value = tail = list;
- }
- else
- {
- Fsetcdr (tail, list);
- tail = XCDR (tail);
- }
-
- list = Fcdr (list);
- }
- else
- {
- if (NILP (tail))
- {
- value = tail = Fcons (array [array_index], Qnil);
- }
- else
- {
- Fsetcdr (tail, Fcons (array [array_index], tail));
- tail = XCDR (tail);
- }
- ++array_index;
- }
-
- if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH)
- {
- if (looped & 1)
- {
- tortoise = XCDR (tortoise);
- }
-
- if (EQ (list, tortoise))
- {
- signal_circular_list_error (list);
- }
- }
- }
-}
-
-static void
-list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
- Lisp_Object list_one, Lisp_Object list_two,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
-{
- Elemcount output_index = 0;
-
- while (output_index < output_len)
- {
- if (NILP (list_one))
- {
- while (output_index < output_len)
- {
- output [output_index] = Fcar (list_two);
- list_two = Fcdr (list_two), ++output_index;
- }
- return;
- }
-
- if (NILP (list_two))
- {
- while (output_index < output_len)
- {
- output [output_index] = Fcar (list_one);
- list_one = Fcdr (list_one), ++output_index;
- }
- return;
- }
-
- if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate,
- key_func)))
- {
- output [output_index] = XCAR (list_one);
- list_one = XCDR (list_one);
- }
- else
- {
- output [output_index] = XCAR (list_two);
- list_two = XCDR (list_two);
- }
-
- ++output_index;
-
- /* No need to check for circularity. */
- }
-}
-
-static void
-list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
- Lisp_Object list,
- Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func,
- Boolint reverse_order)
-{
- Elemcount output_index = 0, array_index = 0;
-
- while (output_index < output_len)
- {
- if (NILP (list))
- {
- if (array_len - array_index != output_len - output_index)
- {
- mapping_interaction_error (Qmerge, list);
- }
-
- while (array_index < array_len)
- {
- output [output_index++] = array [array_index++];
- }
-
- return;
- }
-
- if (array_index >= array_len)
- {
- while (output_index < output_len)
- {
- output [output_index++] = Fcar (list);
- list = Fcdr (list);
- }
-
- return;
- }
-
- if (reverse_order ?
- !NILP (c_predicate (Fcar (list), array [array_index], predicate,
- key_func)) :
- NILP (c_predicate (array [array_index], Fcar (list), predicate,
- key_func)))
- {
- output [output_index] = XCAR (list);
- list = XCDR (list);
- }
- else
- {
- output [output_index] = array [array_index];
- ++array_index;
- }
-
- ++output_index;
- }
-}
-
-#define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \
- do { \
- c_array = alloca_array (Lisp_Object, len); \
- for (counter = 0; counter < len; ++counter) \
- { \
- c_array[counter] = make_char (itext_ichar (strdata)); \
- INC_IBYTEPTR (strdata); \
- } \
- } while (0)
-
-#define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \
- c_array = alloca_array (Lisp_Object, len); \
- for (counter = 0; counter < len; ++counter) \
- { \
- c_array[counter] = make_int (bit_vector_bit (v, counter)); \
- } \
- } while (0)
+ Lisp_Object elt = Qnil, tail = list, tail_before = Qnil;
+ Elemcount len, ii = 0, starting = XINT (start);
+ Elemcount ending = NILP (end) ? EMACS_INT_MAX : XINT (end);
+
+ GCPRO2 (elt, tail);
+
+ if (check_test == check_eq_nokey)
+ {
+ /* TEST is #'eq, no need to call any C functions, and the test order
+ won't be visible. */
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len)
+ {
+ if (starting <= ii && ii < ending &&
+ EQ (item, elt) == test_not_unboundp)
+ {
+ *cons_out = tail_before;
+ RETURN_UNGCPRO (make_integer (ii));
+ }
+ else
+ {
+ if (ii >= ending)
+ {
+ break;
+ }
+ }
+ ii++;
+ tail_before = tail;
+ }
+ }
+ else
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len)
+ {
+ if (starting <= ii && ii < ending &&
+ (reverse_test_order ?
+ check_test (test, key, elt, item) :
+ check_test (test, key, item, elt)) == test_not_unboundp)
+ {
+ *cons_out = tail_before;
+ RETURN_UNGCPRO (make_integer (ii));
+ }
+ else
+ {
+ if (ii >= ending)
+ {
+ break;
+ }
+ }
+ ii++;
+ tail_before = tail;
+ }
+ }
+
+ RETURN_UNGCPRO (Qnil);
+}
+
+DEFUN ("member*", FmemberX, 2, MANY, 0, /*
+Return the first sublist of LIST with car ITEM, or nil if no such sublist.
+
+The keyword :test specifies a two-argument function that is used to compare
+ITEM with elements in LIST; if omitted, it defaults to `eql'.
+
+The keyword :test-not is similar, but specifies a negated function. That
+is, ITEM is considered equal to an element in LIST if the given function
+returns nil. Common Lisp deprecates :test-not, and if both are specified,
+XEmacs signals an error.
+
+:key specifies a one-argument function that transforms elements of LIST into
+\"comparison keys\" before the test predicate is applied. For example,
+if:key is #'car, then ITEM is compared with the car of elements from LIST.
+The:key function, however, is not applied to ITEM, and does not affect the
+elements in the returned list, which are taken directly from the elements in
+LIST.
+
+arguments: (ITEM LIST &key (TEST #'eql) TEST-NOT (KEY #'identity))
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], list = args[1], result = Qnil, position0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (FmemberX, nargs, args, 5, (test, if_not, if_, test_not, key),
+ NULL);
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+ position0
+ = list_position_cons_before (&result, item, list, check_test,
+ test_not_unboundp, test, key, 0, Qzero, Qnil);
+
+ return CONSP (result) ? XCDR (result) : ZEROP (position0) ? list : Qnil;
+}
/* This macro might eventually find a better home than here. */
＠＠ -2727,8 +2620,2567 ＠＠
if (!EQ (key, Qidentity)) \
{ \
key = indirect_function (key, 1); \
+ if (EQ (key, XSYMBOL_FUNCTION (Qidentity))) \
+ { \
+ key = Qidentity; \
+ } \
} \
} while (0)
+
+#define KEY(key, item) (EQ (Qidentity, key) ? item : \
+ IGNORE_MULTIPLE_VALUES (call1 (key, item)))
+
+DEFUN ("adjoin", Fadjoin, 2, MANY, 0, /*
+Return ITEM consed onto the front of LIST, if not already in LIST.
+
+Otherwise, return LIST unmodified.
+
+See `member*' for the meaning of the keywords.
+
+arguments: (ITEM LIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], list = args[1], keyed = Qnil, ignore = Qnil;
+ struct gcpro gcpro1;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fadjoin, nargs, args, 3, (test, key, test_not),
+ NULL);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ keyed = KEY (key, item);
+
+ GCPRO1 (keyed);
+ check_test = get_check_test_function (keyed, &test, test_not, Qnil, Qnil,
+ key, &test_not_unboundp);
+ if (NILP (list_position_cons_before (&ignore, keyed, list, check_test,
+ test_not_unboundp, test, key, 0, Qzero,
+ Qnil)))
+ {
+ RETURN_UNGCPRO (Fcons (item, list));
+ }
+
+ RETURN_UNGCPRO (list);
+}
+
+DEFUN ("assoc", Fassoc, 2, 2, 0, /*
+Return non-nil if KEY is `equal' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car equals KEY.
+*/
+ (key, alist))
+{
+ /* This function can GC. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_equal (key, elt_car, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
+Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car equals KEY.
+*/
+ (key, alist))
+{
+ /* This function can GC. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_old_equal (key, elt_car, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+Lisp_Object
+assoc_no_quit (Lisp_Object key, Lisp_Object alist)
+{
+ int speccount = specpdl_depth ();
+ specbind (Qinhibit_quit, Qt);
+ return unbind_to_1 (speccount, Fassoc (key, alist));
+}
+
+DEFUN ("assq", Fassq, 2, 2, 0, /*
+Return non-nil if KEY is `eq' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car is KEY.
+Elements of ALIST that are not conses are ignored.
+*/
+ (key, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
+Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car is KEY.
+Elements of ALIST that are not conses are ignored.
+This function is provided only for byte-code compatibility with v19.
+Do not use it.
+*/
+ (key, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (HACKEQ_UNSAFE (key, elt_car))
+ return elt;
+ }
+ return Qnil;
+}
+
+/* Like Fassq but never report an error and do not allow quits.
+ Use only on lists known never to be circular. */
+
+Lisp_Object
+assq_no_quit (Lisp_Object key, Lisp_Object alist)
+{
+ /* This cannot GC. */
+ LIST_LOOP_2 (elt, alist)
+ {
+ Lisp_Object elt_car = XCAR (elt);
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("assoc*", FassocX, 2, MANY, 0, /*
+Find the first item whose car matches ITEM in ALIST.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], alist = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (FassocX, nargs, args, 5, (test, if_, if_not, test_not, key),
+ NULL);
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ if (check_test == check_eq_nokey)
+ {
+ /* TEST is #'eq, no need to call any C functions. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (EQ (item, elt_car) == test_not_unboundp)
+ {
+ return elt;
+ }
+ }
+ }
+ else
+ {
+ Lisp_Object tailed = alist;
+ struct gcpro gcpro1;
+
+ GCPRO1 (tailed);
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, item, elt_car) == test_not_unboundp)
+ {
+ RETURN_UNGCPRO (elt);
+ }
+ }
+ }
+ UNGCPRO;
+ }
+
+ return Qnil;
+}
+
+DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
+Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr equals VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_equal (value, elt_cdr, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
+Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr equals VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_old_equal (value, elt_cdr, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("rassq", Frassq, 2, 2, 0, /*
+Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr is VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
+Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr is VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (HACKEQ_UNSAFE (value, elt_cdr))
+ return elt;
+ }
+ return Qnil;
+}
+
+/* Like Frassq, but caller must ensure that ALIST is properly
+ nil-terminated and ebola-free. */
+Lisp_Object
+rassq_no_quit (Lisp_Object value, Lisp_Object alist)
+{
+ LIST_LOOP_2 (elt, alist)
+ {
+ Lisp_Object elt_cdr = XCDR (elt);
+ if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("rassoc*", FrassocX, 2, MANY, 0, /*
+Find the first item whose cdr matches ITEM in ALIST.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], alist = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (FrassocX, nargs, args, 5, (test, if_, if_not, test_not, key),
+ NULL);
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ if (check_test == check_eq_nokey)
+ {
+ /* TEST is #'eq, no need to call any C functions. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (EQ (item, elt_cdr) == test_not_unboundp)
+ {
+ return elt;
+ }
+ }
+ }
+ else
+ {
+ struct gcpro gcpro1;
+ Lisp_Object tailed = alist;
+
+ GCPRO1 (tailed);
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, item, elt_cdr) == test_not_unboundp)
+ {
+ RETURN_UNGCPRO (elt);
+ }
+ }
+ }
+ UNGCPRO;
+ }
+
+ return Qnil;
+}
+
+/* This is the implementation of both #'find and #'position. */
+static Lisp_Object
+position (Lisp_Object *object_out, Lisp_Object item, Lisp_Object sequence,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key, Lisp_Object start, Lisp_Object end,
+ Lisp_Object from_end, Lisp_Object default_, Lisp_Object caller)
+{
+ Lisp_Object result = Qnil;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0;
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = INTP (start) ? XINT (start) : 1 + EMACS_INT_MAX;
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = INTP (end) ? XINT (end) : 1 + EMACS_INT_MAX;
+ }
+
+ *object_out = default_;
+
+ if (CONSP (sequence))
+ {
+ Lisp_Object elt, tail = Qnil;
+ struct gcpro gcpro1;
+
+ if (!(starting < ending))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ /* starting could be equal to ending, in which case nil is what
+ we want to return. */
+ return Qnil;
+ }
+
+ GCPRO1 (tail);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (starting <= ii && ii < ending
+ && check_test (test, key, item, elt) == test_not_unboundp)
+ {
+ result = make_integer (ii);
+ *object_out = elt;
+
+ if (NILP (from_end))
+ {
+ UNGCPRO;
+ return result;
+ }
+ }
+ else if (ii == ending)
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+
+ UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
+ Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
+ Lisp_Object character = Qnil;
+
+ while (cursor_offset < byte_len && ii < ending)
+ {
+ if (ii >= starting)
+ {
+ character = make_char (itext_ichar (cursor));
+
+ if (check_test (test, key, item, character) == test_not_unboundp)
+ {
+ result = make_integer (ii);
+ *object_out = character;
+
+ if (NILP (from_end))
+ {
+ return result;
+ }
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (caller, sequence);
+ }
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+ }
+ else
+ {
+ Lisp_Object object = Qnil;
+ len = XINT (Flength (sequence));
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ ending = min (ending, len);
+ if (0 == len)
+ {
+ /* Catches the case where we have nil. */
+ return result;
+ }
+
+ if (NILP (from_end))
+ {
+ for (ii = starting; ii < ending; ii++)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (check_test (test, key, item, object) == test_not_unboundp)
+ {
+ result = make_integer (ii);
+ *object_out = object;
+ return result;
+ }
+ }
+ }
+ else
+ {
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (check_test (test, key, item, object) == test_not_unboundp)
+ {
+ result = make_integer (ii);
+ *object_out = object;
+ return result;
+ }
+ }
+ }
+ }
+
+ return result;
+}
+
+DEFUN ("position", Fposition, 2, MANY, 0, /*
+Return the index of the first occurrence of ITEM in SEQUENCE.
+
+Return nil if not found. See `remove*' for the meaning of the keywords.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object object = Qnil, item = args[0], sequence = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fposition, nargs, args, 8,
+ (test, if_, test_not, if_not, key, start, end, from_end),
+ (start = Qzero));
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ return position (&object, item, sequence, check_test, test_not_unboundp,
+ test, key, start, end, from_end, Qnil, Qposition);
+}
+
+DEFUN ("find", Ffind, 2, MANY, 0, /*
+Find the first occurrence of ITEM in SEQUENCE.
+
+Return the matching ITEM, or nil if not found. See `remove*' for the
+meaning of the keywords.
+
+The keyword :default, not specified by Common Lisp, designates an object to
+return instead of nil if ITEM is not found.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) DEFAULT FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object object = Qnil, item = args[0], sequence = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fposition, nargs, args, 9,
+ (test, if_, test_not, if_not, key, start, end, from_end,
+ default_),
+ (start = Qzero));
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ position (&object, item, sequence, check_test, test_not_unboundp,
+ test, key, start, end, from_end, Qnil, Qposition);
+
+ return object;
+}
+
+DEFUN ("delete", Fdelete, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `equal'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (delete element foo))' to be sure
+of changing the value of `foo'.
+Also see: `remove'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_equal (elt, list_elt, 0)));
+ return list;
+}
+
+DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `old-equal'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (old-delete element foo))' to be sure
+of changing the value of `foo'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_old_equal (elt, list_elt, 0)));
+ return list;
+}
+
+DEFUN ("delq", Fdelq, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `eq'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (delq element foo))' to be sure of
+changing the value of `foo'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
+ return list;
+}
+
+DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `old-eq'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
+changing the value of `foo'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (HACKEQ_UNSAFE (elt, list_elt)));
+ return list;
+}
+
+/* Like Fdelq, but caller must ensure that LIST is properly
+ nil-terminated and ebola-free. */
+
+Lisp_Object
+delq_no_quit (Lisp_Object elt, Lisp_Object list)
+{
+ LIST_LOOP_DELETE_IF (list_elt, list,
+ (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
+ return list;
+}
+
+/* Be VERY careful with this. This is like delq_no_quit() but
+ also calls free_cons() on the removed conses. You must be SURE
+ that no pointers to the freed conses remain around (e.g.
+ someone else is pointing to part of the list). This function
+ is useful on internal lists that are used frequently and where
+ the actual list doesn't escape beyond known code bounds. */
+
+Lisp_Object
+delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
+{
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object tem = XCAR (tail);
+ if (EQ (elt, tem))
+ {
+ Lisp_Object cons_to_free = tail;
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ tail = XCDR (tail);
+ free_cons (cons_to_free);
+ }
+ else
+ {
+ prev = tail;
+ tail = XCDR (tail);
+ }
+ }
+ return list;
+}
+
+DEFUN ("delete*", FdeleteX, 2, MANY, 0, /*
+Remove all occurrences of ITEM in SEQUENCE, destructively.
+
+If SEQUENCE is a non-nil list, this modifies the list directly. A non-list
+SEQUENCE will not be destructively modified, rather, if ITEM occurs in it, a
+new SEQUENCE of the same type without ITEM will be returned.
+
+See `remove*' for a non-destructive alternative, and for explanation of the
+keyword arguments.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], sequence = args[1], tail = sequence;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, counting = EMACS_INT_MAX;
+ Elemcount len, ii = 0, encountered = 0, presenting = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1;
+
+ PARSE_KEYWORDS (FdeleteX, nargs, args, 9,
+ (test, if_not, if_, test_not, key, start, end, from_end,
+ count), (start = Qzero, count = Qunbound));
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (!UNBOUNDP (count))
+ {
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ if (BIGNUMP (count))
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + EMACS_INT_MAX : EMACS_INT_MIN - 1;
+ }
+ else
+ {
+ counting = XINT (count);
+ }
+
+ if (counting < 1)
+ {
+ return sequence;
+ }
+ }
+ }
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ if (CONSP (sequence))
+ {
+ Lisp_Object prev_tail_list_elt = Qnil, list_elt = Qnil;
+ Elemcount list_len = 0, deleted = 0;
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ /* Both COUNT and FROM-END were specified; we need to traverse the
+ list twice. */
+ Lisp_Object present = count_with_tail (&list_elt, nargs, args,
+ QdeleteX);
+
+ if (ZEROP (present))
+ {
+ return sequence;
+ }
+
+ presenting = XINT (present);
+
+ /* If there are fewer items in the list than we have permission to
+ delete, we don't need to differentiate between the :from-end
+ nil and :from-end t cases. Otherwise, presenting is the number
+ of matching items we need to ignore before we start to
+ delete. */
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ GCPRO1 (tail);
+ ii = -1;
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (list_elt, sequence, tail, list_len)
+ {
+ ii++;
+
+ if (starting <= ii && ii < ending &&
+ (check_test (test, key, item, list_elt) == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting
+: encountered++ < counting))
+ {
+ if (NILP (prev_tail_list_elt))
+ {
+ sequence = XCDR (tail);
+ }
+ else
+ {
+ XSETCDR (prev_tail_list_elt, XCDR (tail));
+ }
+
+ /* Keep tortoise from ever passing hare. */
+ list_len = 0;
+ deleted++;
+ }
+ else
+ {
+ prev_tail_list_elt = tail;
+ if (ii >= ending || (!presenting && encountered > counting))
+ {
+ break;
+ }
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end))) &&
+ !(presenting ? encountered == presenting : encountered == counting))
+ {
+ check_sequence_range (args[1], start, end,
+ make_int (deleted + XINT (Flength (args[1]))));
+ }
+
+ return sequence;
+ }
+ else if (STRINGP (sequence))
+ {
+ Ibyte *staging = alloca_ibytes (XSTRING_LENGTH (sequence));
+ Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence);
+ Ibyte *cursor = startp;
+ Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence);
+ Lisp_Object character, result = sequence;
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ Lisp_Object present = count_with_tail (&character, nargs, args,
+ QdeleteX);
+
+ if (ZEROP (present))
+ {
+ return sequence;
+ }
+
+ presenting = XINT (present);
+
+ /* If there are fewer items in the list than we have permission to
+ delete, we don't need to differentiate between the :from-end
+ nil and :from-end t cases. Otherwise, presenting is the number
+ of matching items we need to ignore before we start to
+ delete. */
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ ii = 0;
+ while (cursor_offset < byte_len)
+ {
+ if (ii >= starting && ii < ending)
+ {
+ character = make_char (itext_ichar (cursor));
+
+ if ((check_test (test, key, item, character)
+ == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting :
+ encountered++ < counting))
+ {
+ DO_NOTHING;
+ }
+ else
+ {
+ staging_cursor
+ += set_itext_ichar (staging_cursor, XCHAR (character));
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (QdeleteX, sequence);
+ }
+ }
+ else
+ {
+ staging_cursor += itext_copy_ichar (cursor, staging_cursor);
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+
+ if (0 != encountered)
+ {
+ result = make_string (staging, staging_cursor - staging);
+ copy_string_extents (result, sequence, 0, 0,
+ staging_cursor - staging);
+ sequence = result;
+ }
+
+ return sequence;
+ }
+ else
+ {
+ Lisp_Object position0 = Qnil, object = Qnil;
+ Lisp_Object *staging = NULL, *staging_cursor, *staging_limit;
+ Elemcount positioning;
+
+ len = XINT (Flength (sequence));
+
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ position0 = position (&object, item, sequence, check_test,
+ test_not_unboundp, test, key, start, end,
+ from_end, Qnil, QdeleteX);
+ if (NILP (position0))
+ {
+ return sequence;
+ }
+
+ ending = min (ending, len);
+ positioning = XINT (position0);
+ encountered = 1;
+
+ if (NILP (from_end))
+ {
+ staging = alloca_array (Lisp_Object, len - 1);
+ staging_cursor = staging;
+
+ ii = 0;
+ while (ii < positioning)
+ {
+ *staging_cursor++ = Faref (sequence, make_int (ii));
+ ii++;
+ }
+
+ ii = positioning + 1;
+ while (ii < ending)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (encountered < counting
+ && (check_test (test, key, item, object)
+ == test_not_unboundp))
+ {
+ encountered++;
+ }
+ else
+ {
+ *staging_cursor++ = object;
+ }
+ ii++;
+ }
+
+ while (ii < len)
+ {
+ *staging_cursor++ = Faref (sequence, make_int (ii));
+ ii++;
+ }
+ }
+ else
+ {
+ staging = alloca_array (Lisp_Object, len - 1);
+ staging_cursor = staging_limit = staging + len - 1;
+
+ ii = len - 1;
+ while (ii > positioning)
+ {
+ *--staging_cursor = Faref (sequence, make_int (ii));
+ ii--;
+ }
+
+ ii = positioning - 1;
+ while (ii >= starting)
+ {
+ object = Faref (sequence, make_int (ii));
+ if (encountered < counting
+ && (check_test (test, key, item, object) ==
+ test_not_unboundp))
+ {
+ encountered++;
+ }
+ else
+ {
+ *--staging_cursor = object;
+ }
+
+ ii--;
+ }
+
+ while (ii >= 0)
+ {
+ *--staging_cursor = Faref (sequence, make_int (ii));
+ ii--;
+ }
+
+ staging = staging_cursor;
+ staging_cursor = staging_limit;
+ }
+
+ if (VECTORP (sequence))
+ {
+ return Fvector (staging_cursor - staging, staging);
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ return Fbit_vector (staging_cursor - staging, staging);
+ }
+
+ /* A nil sequence will have given us a nil #'position,
+ above. */
+ ABORT ();
+
+ return Qnil;
+ }
+}
+
+DEFUN ("remove*", FremoveX, 2, MANY, 0, /*
+Remove all occurrences of ITEM in SEQUENCE, non-destructively.
+
+If SEQUENCE is a list, `remove*' makes a copy if that is necessary to avoid
+corrupting the original SEQUENCE.
+
+The keywords :test and :test-not specify two-argument test and negated-test
+predicates, respectively; :test defaults to `eql'. :key specifies a
+one-argument function that transforms elements of SEQUENCE into \"comparison
+keys\" before the test predicate is applied. See `member*' for more
+information on these keywords.
+
+:start and :end, if given, specify indices of a subsequence of SEQUENCE to
+be processed. Indices are 0-based and processing involves the subsequence
+starting at the index given by :start and ending just before the index given
+by:end.
+
+:count, if given, limits the number of items removed to the number
+specified.:from-end, if given, causes processing to proceed starting from
+the end instead of the beginning; in this case, this matters only if :count
+is given.
+
+arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object item = args[0], sequence = args[1], matched_count = Qnil,
+ tail = Qnil;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, counting = EMACS_INT_MAX;
+ Elemcount len, ii = 0, encountered = 0, presenting = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1;
+
+ PARSE_KEYWORDS (FremoveX, nargs, args, 9,
+ (test, if_not, if_, test_not, key, start, end, from_end,
+ count), (start = Qzero));
+
+ if (!CONSP (sequence))
+ {
+ return FdeleteX (nargs, args);
+ }
+
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ if (BIGNUMP (count))
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
+ }
+ else
+ {
+ counting = XINT (count);
+ }
+
+ if (counting <= 0)
+ {
+ return sequence;
+ }
+ }
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ matched_count = count_with_tail (&tail, nargs, args, QremoveX);
+
+ if (!ZEROP (matched_count))
+ {
+ Lisp_Object elt, tailing = Qnil, result = Qnil, result_tail = Qnil;
+ GCPRO1 (tailing);
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ presenting = XINT (matched_count);
+
+ /* If there are fewer matching elements in the list than we have
+ permission to delete, we don't need to differentiate between
+ the :from-end nil and :from-end t cases. Otherwise, presenting
+ is the number of matching items we need to ignore before we
+ start to delete. */
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tailing, len)
+ {
+ if (EQ (tail, tailing))
+ {
+ if (NILP (result))
+ {
+ RETURN_UNGCPRO (XCDR (tail));
+ }
+
+ XSETCDR (result_tail, XCDR (tail));
+ RETURN_UNGCPRO (result);
+ }
+ else if (starting <= ii && ii < ending &&
+ (check_test (test, key, item, elt) == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting
+: encountered++ < counting))
+ {
+ DO_NOTHING;
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+
+ if (ii == ending)
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+
+ UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
+ }
+
+ return result;
+ }
+
+ return sequence;
+}
+
+DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
+Delete by side effect any elements of ALIST whose car is `equal' to KEY.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `equal' to KEY, there is no way to remove it by side effect;
+therefore, write `(setq foo (remassoc key foo))' to be sure of changing
+the value of `foo'.
+*/
+ (key, alist))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ internal_equal (key, XCAR (elt), 0)));
+ return alist;
+}
+
+Lisp_Object
+remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
+{
+ int speccount = specpdl_depth ();
+ specbind (Qinhibit_quit, Qt);
+ return unbind_to_1 (speccount, Fremassoc (key, alist));
+}
+
+DEFUN ("remassq", Fremassq, 2, 2, 0, /*
+Delete by side effect any elements of ALIST whose car is `eq' to KEY.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `eq' to KEY, there is no way to remove it by side effect;
+therefore, write `(setq foo (remassq key foo))' to be sure of changing
+the value of `foo'.
+*/
+ (key, alist))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
+ return alist;
+}
+
+/* no quit, no errors; be careful */
+
+Lisp_Object
+remassq_no_quit (Lisp_Object key, Lisp_Object alist)
+{
+ LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
+ return alist;
+}
+
+DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
+Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `equal' to VALUE, there is no way to remove it by side effect;
+therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
+the value of `foo'.
+*/
+ (value, alist))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ internal_equal (value, XCDR (elt), 0)));
+ return alist;
+}
+
+DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
+Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `eq' to VALUE, there is no way to remove it by side effect;
+therefore, write `(setq foo (remrassq value foo))' to be sure of changing
+the value of `foo'.
+*/
+ (value, alist))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
+ return alist;
+}
+
+/* Like Fremrassq, fast and unsafe; be careful */
+Lisp_Object
+remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
+{
+ LIST_LOOP_DELETE_IF (elt, alist,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
+ return alist;
+}
+
+/* Remove duplicate elements between START and END from LIST, a non-nil
+ list; if COPY is zero, do so destructively. Items to delete are selected
+ according to the algorithm used when :from-end t is passed to
+ #'delete-duplicates. Error if LIST is ill-formed or circular.
+
+ TEST and KEY are as in #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should
+ reflect them, having been initialised with get_check_match_function() or
+ get_check_test_function(). */
+static Lisp_Object
+list_delete_duplicates_from_end (Lisp_Object list,
+ check_test_func_t check_test,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Lisp_Object start,
+ Lisp_Object end, Boolint copy)
+{
+ Lisp_Object checking = Qnil, elt, tail, result = list;
+ Lisp_Object keyed, positioned, position_cons = Qnil, result_tail;
+ Elemcount len = XINT (Flength (list)), pos, starting = XINT (start);
+ Elemcount ending = (NILP (end) ? len : XINT (end)), greatest_pos_seen = -1;
+ Elemcount ii = 0;
+ struct gcpro gcpro1, gcpro2;
+
+ /* We can't delete (or remove) as we go, because that breaks START and
+ END. We could if END were nil, and that would change an ON(N + 2)
+ algorithm to an ON^2 algorithm; list_position_cons_before() would need to
+ be modified to return the cons *before* the one containing the item for
+ that. Here and now it doesn't matter, though, #'delete-duplicates is
+ relatively expensive no matter what. */
+ struct Lisp_Bit_Vector *deleting
+ = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ + (sizeof (long)
+ * (BIT_VECTOR_LONG_STORAGE (len)
+ - 1)));
+
+ check_sequence_range (list, start, end, make_integer (len));
+
+ deleting->size = len;
+ memset (&(deleting->bits), 0,
+ sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
+
+ GCPRO2 (tail, keyed);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len)
+ {
+ if (!(starting <= ii && ii <= ending) || bit_vector_bit (deleting, ii))
+ {
+ ii++;
+ continue;
+ }
+
+ keyed = KEY (key, elt);
+ checking = XCDR (tail);
+ pos = ii + 1;
+
+ while (!NILP ((positioned = list_position_cons_before
+ (&position_cons, keyed, checking, check_test,
+ test_not_unboundp, test, key, 0,
+ make_int (max (starting - pos, 0)),
+ make_int (ending - pos)))))
+ {
+ pos = XINT (positioned) + pos;
+ set_bit_vector_bit (deleting, pos, 1);
+ greatest_pos_seen = max (greatest_pos_seen, pos);
+ checking = NILP (position_cons) ?
+ XCDR (checking) : XCDR (XCDR (position_cons));
+ pos += 1;
+ }
+ ii++;
+ }
+ }
+
+ UNGCPRO;
+
+ ii = 0;
+
+ if (greatest_pos_seen > -1)
+ {
+ if (copy)
+ {
+ result = result_tail = Fcons (XCAR (list), Qnil);
+ list = XCDR (list);
+ ii = 1;
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, list, tail, len)
+ {
+ if (ii == greatest_pos_seen)
+ {
+ XSETCDR (result_tail, XCDR (tail));
+ break;
+ }
+ else if (!bit_vector_bit (deleting, ii))
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ ii++;
+ }
+ }
+ }
+ else
+ {
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt0, list,
+ bit_vector_bit (deleting, ii++));
+ }
+ }
+
+ return result;
+}
+
+DEFUN ("delete-duplicates", Fdelete_duplicates, 1, MANY, 0, /*
+Remove all duplicate elements from SEQUENCE, destructively.
+
+If SEQUENCE is a list and has duplicates, modify and return it. Note that
+SEQUENCE may start with an element to be deleted; because of this, if
+modifying a variable, be sure to write `(setq VARIABLE (delete-duplicates
+VARIABLE))' to be certain to have a list without duplicate elements.
+
+If SEQUENCE is an array and has duplicates, return a newly-allocated array
+of the same type comprising all unique elements of SEQUENCE.
+
+If there are no duplicate elements in SEQUENCE, return it unmodified.
+
+See `remove*' for the meaning of the keywords. See `remove-duplicates' for
+a non-destructive version of this function.
+
+arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence = args[0], tail = sequence, keyed = Qnil, elt = Qnil;
+ Lisp_Object elt0 = Qnil, positioned = Qnil, ignore = Qnil;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0, jj = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2;
+
+ PARSE_KEYWORDS (Fdelete_duplicates, nargs, args, 6,
+ (test, key, test_not, start, end, from_end),
+ (start = Qzero));
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ CHECK_KEY_ARGUMENT (key);
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ if (CONSP (sequence))
+ {
+ if (NILP (from_end))
+ {
+ Lisp_Object prev_tail = Qnil;
+ Elemcount deleted = 0;
+
+ GCPRO2 (tail, keyed);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (starting <= ii && ii < ending)
+ {
+ keyed = KEY (key, elt);
+ positioned
+ = list_position_cons_before (&ignore, keyed,
+ XCDR (tail), check_test,
+ test_not_unboundp, test, key,
+ 0, make_int (max (starting
+ - (ii + 1),
+ 0)),
+ make_int (ending
+ - (ii + 1)));
+ if (!NILP (positioned))
+ {
+ sequence = XCDR (tail);
+ deleted++;
+ }
+ else
+ {
+ break;
+ }
+ }
+ else
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt0, sequence, tail, len)
+ {
+ if (!(starting <= ii && ii <= ending))
+ {
+ prev_tail = tail;
+ ii++;
+ continue;
+ }
+
+ keyed = KEY (key, elt0);
+ positioned
+ = list_position_cons_before (&ignore, keyed, XCDR (tail),
+ check_test, test_not_unboundp,
+ test, key, 0,
+ make_int (max (starting
+ - (ii + 1), 0)),
+ make_int (ending - (ii + 1)));
+ if (!NILP (positioned))
+ {
+ /* We know this isn't the first iteration of the loop,
+ because we advanced above to the point where we have at
+ least one non-duplicate entry at the head of the
+ list. */
+ XSETCDR (prev_tail, XCDR (tail));
+ len = 0;
+ deleted++;
+ }
+ else
+ {
+ prev_tail = tail;
+ if (ii >= ending)
+ {
+ break;
+ }
+ }
+
+ ii++;
+ }
+ }
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end))))
+ {
+ check_sequence_range (args[0], start, end,
+ make_int (deleted
+ + XINT (Flength (args[0]))));
+ }
+ }
+ else
+ {
+ sequence = list_delete_duplicates_from_end (sequence, check_test,
+ test_not_unboundp,
+ test, key, start, end,
+ 0);
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ if (EQ (Qidentity, key))
+ {
+ /* We know all the elements will be characters; set check_test to
+ reflect that. This isn't useful if KEY is not #'identity, since
+ it may return non-characters for the elements. */
+ check_test = get_check_test_function (make_char ('a'),
+ &test, test_not,
+ Qnil, Qnil, key,
+ &test_not_unboundp);
+ }
+
+ if (NILP (from_end))
+ {
+ Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
+ Ibyte *staging = alloca_ibytes (byte_len), *staging_cursor = staging;
+ Ibyte *cursor = XSTRING_DATA (sequence), *startp = cursor;
+ Elemcount deleted = 0;
+
+ elt = Qnil;
+ GCPRO1 (elt);
+
+ while (cursor_offset < byte_len)
+ {
+ if (starting <= ii && ii < ending)
+ {
+ Ibyte *cursor0 = cursor;
+ Bytecount cursor0_offset;
+ Boolint delete_this = 0;
+
+ elt = KEY (key, make_char (itext_ichar (cursor)));
+ INC_IBYTEPTR (cursor0);
+ cursor0_offset = cursor0 - startp;
+
+ for (jj = ii + 1; jj < ending && cursor0_offset < byte_len;
+ jj++)
+ {
+ if (check_test (test, key, elt,
+ make_char (itext_ichar (cursor0)))
+ == test_not_unboundp)
+ {
+ delete_this = 1;
+ deleted++;
+ break;
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor0 = startp + cursor0_offset;
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor0))
+ {
+ mapping_interaction_error (Qdelete_duplicates,
+ sequence);
+ }
+
+ INC_IBYTEPTR (cursor0);
+ cursor0_offset = cursor0 - startp;
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (Qdelete_duplicates, sequence);
+ }
+
+ if (!delete_this)
+ {
+ staging_cursor
+ += itext_copy_ichar (cursor, staging_cursor);
+
+ }
+ }
+ else
+ {
+ staging_cursor += itext_copy_ichar (cursor, staging_cursor);
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+
+ if (0 != deleted)
+ {
+ sequence = make_string (staging, staging_cursor - staging);
+ }
+ }
+ else
+ {
+ Elemcount deleted = 0;
+ Ibyte *staging = alloca_ibytes ((len = string_char_length (sequence))
+ * MAX_ICHAR_LEN);
+ Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence);
+ Ibyte *endp = startp + XSTRING_LENGTH (sequence);
+ struct Lisp_Bit_Vector *deleting
+ = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ + (sizeof (long)
+ * (BIT_VECTOR_LONG_STORAGE (len)
+ - 1)));
+
+ check_sequence_range (sequence, start, end, make_integer (len));
+
+ /* For the from_end t case; transform contents to an array with
+ elements addressable in constant time, use the same algorithm
+ as for vectors. */
+ deleting->size = len;
+ memset (&(deleting->bits), 0,
+ sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
+
+ while (startp < endp)
+ {
+ itext_copy_ichar (startp, staging + (ii * MAX_ICHAR_LEN));
+ INC_IBYTEPTR (startp);
+ ii++;
+ }
+
+ GCPRO1 (elt);
+
+ ending = min (ending, len);
+
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ elt = KEY (key, make_char (itext_ichar (staging +
+ (ii * MAX_ICHAR_LEN))));
+ for (jj = ii - 1; jj >= starting; jj--)
+ {
+ if (check_test (test, key, elt,
+ make_char (itext_ichar
+ (staging + (jj * MAX_ICHAR_LEN))))
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if (0 != deleted)
+ {
+ startp = XSTRING_DATA (sequence);
+
+ for (ii = 0; ii < len; ii++)
+ {
+ if (!bit_vector_bit (deleting, ii))
+ {
+ staging_cursor
+ += itext_copy_ichar (startp, staging_cursor);
+ }
+
+ INC_IBYTEPTR (startp);
+ }
+
+ sequence = make_string (staging, staging_cursor - staging);
+ }
+ }
+ }
+ else if (VECTORP (sequence))
+ {
+ Elemcount deleted = 0;
+ Lisp_Object *content = XVECTOR_DATA (sequence);
+ struct Lisp_Bit_Vector *deleting;
+
+ len = XVECTOR_LENGTH (sequence);
+ check_sequence_range (sequence, start, end, make_integer (len));
+
+ deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ + (sizeof (long)
+ * (BIT_VECTOR_LONG_STORAGE (len)
+ - 1)));
+ deleting->size = len;
+ memset (&(deleting->bits), 0,
+ sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
+
+ GCPRO1 (elt);
+
+ ending = min (ending, len);
+
+ if (NILP (from_end))
+ {
+ for (ii = starting; ii < ending; ii++)
+ {
+ elt = KEY (key, content[ii]);
+
+ for (jj = ii + 1; jj < ending; jj++)
+ {
+ if (check_test (test, key, elt, content[jj])
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+ }
+ else
+ {
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ elt = KEY (key, content[ii]);
+
+ for (jj = ii - 1; jj >= starting; jj--)
+ {
+ if (check_test (test, key, elt, content[jj])
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if (deleted)
+ {
+ Lisp_Object res = make_vector (len - deleted, Qnil),
+ *res_content = XVECTOR_DATA (res);
+
+ for (ii = jj = 0; ii < len; ii++)
+ {
+ if (!bit_vector_bit (deleting, ii))
+ {
+ res_content[jj++] = content[ii];
+ }
+ }
+
+ sequence = res;
+ }
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
+ Elemcount deleted = 0;
+ /* I'm a little irritated at this. Basically, the only reasonable
+ thing delete-duplicates should do if handed a bit vector is return
+ something of maximum length two and minimum length 0 (because
+ that's the possible number of distinct elements if EQ is regarded
+ as identity, which it should be). But to support arbitrary TEST
+ and KEY arguments, which may be non-deterministic from our
+ perspective, we need the same algorithm as for vectors. */
+ struct Lisp_Bit_Vector *deleting;
+
+ len = bit_vector_length (bv);
+
+ if (EQ (Qidentity, key))
+ {
+ /* We know all the elements will be bits; set check_test to
+ reflect that. This isn't useful if KEY is not #'identity, since
+ it may return non-bits for the elements. */
+ check_test = get_check_test_function (Qzero, &test, test_not,
+ Qnil, Qnil, key,
+ &test_not_unboundp);
+ }
+
+ check_sequence_range (sequence, start, end, make_integer (len));
+
+ deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
+ + (sizeof (long)
+ * (BIT_VECTOR_LONG_STORAGE (len)
+ - 1)));
+ deleting->size = len;
+ memset (&(deleting->bits), 0,
+ sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
+
+ ending = min (ending, len);
+
+ GCPRO1 (elt);
+
+ if (NILP (from_end))
+ {
+ for (ii = starting; ii < ending; ii++)
+ {
+ elt = KEY (key, make_int (bit_vector_bit (bv, ii)));
+
+ for (jj = ii + 1; jj < ending; jj++)
+ {
+ if (check_test (test, key, elt,
+ make_int (bit_vector_bit (bv, jj)))
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+ }
+ else
+ {
+ for (ii = ending - 1; ii >= starting; ii--)
+ {
+ elt = KEY (key, make_int (bit_vector_bit (bv, ii)));
+
+ for (jj = ii - 1; jj >= starting; jj--)
+ {
+ if (check_test (test, key, elt,
+ make_int (bit_vector_bit (bv, jj)))
+ == test_not_unboundp)
+ {
+ set_bit_vector_bit (deleting, ii, 1);
+ deleted++;
+ break;
+ }
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if (deleted)
+ {
+ Lisp_Object res = make_bit_vector (len - deleted, Qzero);
+ Lisp_Bit_Vector *resbv = XBIT_VECTOR (res);
+
+ for (ii = jj = 0; ii < len; ii++)
+ {
+ if (!bit_vector_bit (deleting, ii))
+ {
+ set_bit_vector_bit (resbv, jj++, bit_vector_bit (bv, ii));
+ }
+ }
+
+ sequence = res;
+ }
+ }
+
+ return sequence;
+}
+
+DEFUN ("remove-duplicates", Fremove_duplicates, 1, MANY, 0, /*
+Remove duplicate elements from SEQUENCE, non-destructively.
+
+If there are no duplicate elements in SEQUENCE, return it unmodified;
+otherwise, return a new object. If SEQUENCE is a list, the new object may
+share list structure with SEQUENCE.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence = args[0], tail = sequence, keyed, positioned = Qnil;
+ Lisp_Object result = sequence, result_tail = result, cursor = Qnil;
+ Lisp_Object cons_with_shared_tail = Qnil, elt, elt0;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, len, ii = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS (Fremove_duplicates, nargs, args, 6,
+ (test, key, test_not, start, end, from_end),
+ (start = Qzero));
+
+ CHECK_SEQUENCE (sequence);
+
+ if (!CONSP (sequence))
+ {
+ return Fdelete_duplicates (nargs, args);
+ }
+
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (NILP (key))
+ {
+ key = Qidentity;
+ }
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ if (NILP (from_end))
+ {
+ Lisp_Object ignore = Qnil;
+
+ GCPRO3 (tail, keyed, result);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (starting <= ii && ii <= ending)
+ {
+ keyed = KEY (key, elt);
+ positioned
+ = list_position_cons_before (&ignore, keyed, XCDR (tail),
+ check_test, test_not_unboundp,
+ test, key, 0,
+ make_int (max (starting
+ - (ii + 1), 0)),
+ make_int (ending - (ii + 1)));
+ if (!NILP (positioned))
+ {
+ sequence = result = result_tail = XCDR (tail);
+ }
+ else
+ {
+ break;
+ }
+ }
+ else
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt0, sequence, tail, len)
+ {
+ if (!(starting <= ii && ii <= ending))
+ {
+ ii++;
+ continue;
+ }
+
+ /* For this algorithm, each time we encounter an object to be
+ removed, copy the output list from the tail beyond the last
+ removed cons to this one. Otherwise, the tail of the output list
+ is shared with the input list, which is OK. */
+
+ keyed = KEY (key, elt0);
+ positioned
+ = list_position_cons_before (&ignore, keyed, XCDR (tail),
+ check_test, test_not_unboundp,
+ test, key, 0,
+ make_int (max (starting - (ii + 1),
+ 0)),
+ make_int (ending - (ii + 1)));
+ if (!NILP (positioned))
+ {
+ if (EQ (result, sequence))
+ {
+ result = cons_with_shared_tail
+ = Fcons (XCAR (sequence), XCDR (sequence));
+ }
+
+ result_tail = cons_with_shared_tail;
+ cursor = XCDR (cons_with_shared_tail);
+
+ while (!EQ (cursor, tail) && !NILP (cursor))
+ {
+ XSETCDR (result_tail, Fcons (XCAR (cursor), Qnil));
+ result_tail = XCDR (result_tail);
+ cursor = XCDR (cursor);
+ }
+
+ XSETCDR (result_tail, XCDR (tail));
+ cons_with_shared_tail = result_tail;
+ }
+
+ ii++;
+ }
+ }
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end))))
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
+ }
+ }
+ else
+ {
+ result = list_delete_duplicates_from_end (sequence, check_test,
+ test_not_unboundp, test, key,
+ start, end, 1);
+ }
+
+ return result;
+}
+#undef KEY
+
+DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
+Reverse SEQUENCE, destructively.
+
+Return the beginning of the reversed sequence, which will be a distinct Lisp
+object if SEQUENCE is a list with length greater than one. See also
+`reverse', the non-destructive version of this function.
+*/
+ (sequence))
+{
+ CHECK_SEQUENCE (sequence);
+
+ if (CONSP (sequence))
+ {
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object prev = Qnil;
+ Lisp_Object tail = sequence;
+
+ /* We gcpro our args; see `nconc' */
+ GCPRO2 (prev, tail);
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object next;
+ CONCHECK_CONS (tail);
+ next = XCDR (tail);
+ XCDR (tail) = prev;
+ prev = tail;
+ tail = next;
+ }
+ UNGCPRO;
+ return prev;
+ }
+ else if (VECTORP (sequence))
+ {
+ Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
+ Elemcount half = length / 2;
+ Lisp_Object swap = Qnil;
+ CHECK_LISP_WRITEABLE (sequence);
+
+ while (ii > half)
+ {
+ swap = XVECTOR_DATA (sequence) [length - ii];
+ XVECTOR_DATA (sequence) [length - ii]
+ = XVECTOR_DATA (sequence) [ii - 1];
+ XVECTOR_DATA (sequence) [ii - 1] = swap;
+ --ii;
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ Elemcount length = XSTRING_LENGTH (sequence);
+ Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
+ Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
+
+ CHECK_LISP_WRITEABLE (sequence);
+ while (cursor < endp)
+ {
+ staging_end -= itext_ichar_len (cursor);
+ itext_copy_ichar (cursor, staging_end);
+ INC_IBYTEPTR (cursor);
+ }
+
+ assert (staging == staging_end);
+
+ memcpy (XSTRING_DATA (sequence), staging, length);
+ init_string_ascii_begin (sequence);
+ bump_string_modiff (sequence);
+ sledgehammer_check_ascii_begin (sequence);
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
+ Elemcount length = bit_vector_length (bv), ii = length;
+ Elemcount half = length / 2;
+ int swap = 0;
+
+ CHECK_LISP_WRITEABLE (sequence);
+ while (ii > half)
+ {
+ swap = bit_vector_bit (bv, length - ii);
+ set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1));
+ set_bit_vector_bit (bv, ii - 1, swap);
+ --ii;
+ }
+ }
+ else
+ {
+ assert (NILP (sequence));
+ }
+
+ return sequence;
+}
+
+DEFUN ("reverse", Freverse, 1, 1, 0, /*
+Reverse SEQUENCE, copying. Return the reversed sequence.
+See also the function `nreverse', which is used more often.
+*/
+ (sequence))
+{
+ Lisp_Object result = Qnil;
+
+ CHECK_SEQUENCE (sequence);
+
+ if (CONSP (sequence))
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence)
+ {
+ result = Fcons (elt, result);
+ }
+ }
+ else if (VECTORP (sequence))
+ {
+ Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
+ Lisp_Object *staging = alloca_array (Lisp_Object, length);
+
+ while (ii > 0)
+ {
+ staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1];
+ --ii;
+ }
+
+ result = Fvector (length, staging);
+ }
+ else if (STRINGP (sequence))
+ {
+ Elemcount length = XSTRING_LENGTH (sequence);
+ Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
+ Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
+
+ while (cursor < endp)
+ {
+ staging_end -= itext_ichar_len (cursor);
+ itext_copy_ichar (cursor, staging_end);
+ INC_IBYTEPTR (cursor);
+ }
+
+ assert (staging == staging_end);
+
+ result = make_string (staging, length);
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res;
+ Elemcount length = bit_vector_length (bv), ii = length;
+
+ result = make_bit_vector (length, Qzero);
+ res = XBIT_VECTOR (result);
+
+ while (ii > 0)
+ {
+ set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1));
+ --ii;
+ }
+ }
+ else
+ {
+ assert (NILP (sequence));
+ }
+
+ return result;
+}
+
+static Lisp_Object
+c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
+ Lisp_Object pred, Lisp_Object key_func)
+{
+ struct gcpro gcpro1;
+ Lisp_Object args[3];
+
+ /* We could use call2() and call3() here, but we're called O(nlogn) times
+ for a sequence of length n, it make some sense to inline them. */
+ args[0] = key_func;
+ args[1] = obj1;
+ args[2] = Qnil;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+
+ obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+
+ args[1] = obj2;
+ obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+
+ args[0] = pred;
+ args[1] = obj1;
+ args[2] = obj2;
+
+ RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
+}
+
+static Lisp_Object
+c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
+ Lisp_Object pred, Lisp_Object UNUSED (key_func))
+{
+ struct gcpro gcpro1;
+ Lisp_Object args[3];
+
+ /* This is (almost) the implementation of call2, it makes some sense to
+ inline it here. */
+ args[0] = pred;
+ args[1] = obj1;
+ args[2] = obj2;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+
+ RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
+}
+
+Lisp_Object
+list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
+ Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func)
+{
+ Lisp_Object value;
+ Lisp_Object tail;
+ Lisp_Object tem;
+ Lisp_Object l1, l2;
+ Lisp_Object tortoises[2];
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
+ int l1_count = 0, l2_count = 0;
+
+ l1 = org_l1;
+ l2 = org_l2;
+ tail = Qnil;
+ value = Qnil;
+ tortoises[0] = org_l1;
+ tortoises[1] = org_l2;
+
+ if (NULL == c_predicate)
+ {
+ c_predicate = EQ (key_func, Qidentity) ?
+ c_merge_predicate_nokey : c_merge_predicate_key;
+ }
+
+ /* It is sufficient to protect org_l1 and org_l2.
+ When l1 and l2 are updated, we copy the new values
+ back into the org_ vars. */
+
+ GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
+ gcpro5.nvars = 2;
+
+ while (1)
+ {
+ if (NILP (l1))
+ {
+ UNGCPRO;
+ if (NILP (tail))
+ return l2;
+ Fsetcdr (tail, l2);
+ return value;
+ }
+ if (NILP (l2))
+ {
+ UNGCPRO;
+ if (NILP (tail))
+ return l1;
+ Fsetcdr (tail, l1);
+ return value;
+ }
+
+ if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func)))
+ {
+ tem = l1;
+ l1 = Fcdr (l1);
+ org_l1 = l1;
+
+ if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (l1_count & 1)
+ {
+ if (!CONSP (tortoises[0]))
+ {
+ mapping_interaction_error (Qmerge, tortoises[0]);
+ }
+
+ tortoises[0] = XCDR (tortoises[0]);
+ }
+
+ if (EQ (org_l1, tortoises[0]))
+ {
+ signal_circular_list_error (org_l1);
+ }
+ }
+ }
+ else
+ {
+ tem = l2;
+ l2 = Fcdr (l2);
+ org_l2 = l2;
+
+ if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (l2_count & 1)
+ {
+ if (!CONSP (tortoises[1]))
+ {
+ mapping_interaction_error (Qmerge, tortoises[1]);
+ }
+
+ tortoises[1] = XCDR (tortoises[1]);
+ }
+
+ if (EQ (org_l2, tortoises[1]))
+ {
+ signal_circular_list_error (org_l2);
+ }
+ }
+ }
+
+ if (NILP (tail))
+ value = tem;
+ else
+ Fsetcdr (tail, tem);
+
+ tail = tem;
+ }
+}
+
+static void
+array_merge (Lisp_Object *dest, Elemcount dest_len,
+ Lisp_Object *front, Elemcount front_len,
+ Lisp_Object *back, Elemcount back_len,
+ Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func)
+{
+ Elemcount ii, fronting, backing;
+ Lisp_Object *front_staging = front;
+ Lisp_Object *back_staging = back;
+ struct gcpro gcpro1, gcpro2;
+
+ assert (dest_len == (back_len + front_len));
+
+ if (0 == dest_len)
+ {
+ return;
+ }
+
+ if (front >= dest && front < (dest + dest_len))
+ {
+ front_staging = alloca_array (Lisp_Object, front_len);
+
+ for (ii = 0; ii < front_len; ++ii)
+ {
+ front_staging[ii] = front[ii];
+ }
+ }
+
+ if (back >= dest && back < (dest + dest_len))
+ {
+ back_staging = alloca_array (Lisp_Object, back_len);
+
+ for (ii = 0; ii < back_len; ++ii)
+ {
+ back_staging[ii] = back[ii];
+ }
+ }
+
+ GCPRO2 (front_staging[0], back_staging[0]);
+ gcpro1.nvars = front_len;
+ gcpro2.nvars = back_len;
+
+ for (ii = fronting = backing = 0; ii < dest_len; ++ii)
+ {
+ if (fronting >= front_len)
+ {
+ while (ii < dest_len)
+ {
+ dest[ii] = back_staging[backing];
+ ++ii, ++backing;
+ }
+ UNGCPRO;
+ return;
+ }
+
+ if (backing >= back_len)
+ {
+ while (ii < dest_len)
+ {
+ dest[ii] = front_staging[fronting];
+ ++ii, ++fronting;
+ }
+ UNGCPRO;
+ return;
+ }
+
+ if (NILP (c_predicate (back_staging[backing], front_staging[fronting],
+ predicate, key_func)))
+ {
+ dest[ii] = front_staging[fronting];
+ ++fronting;
+ }
+ else
+ {
+ dest[ii] = back_staging[backing];
+ ++backing;
+ }
+ }
+
+ UNGCPRO;
+}
+
+static Lisp_Object
+list_array_merge_into_list (Lisp_Object list,
+ Lisp_Object *array, Elemcount array_len,
+ Lisp_Object (*c_predicate) (Lisp_Object,
+ Lisp_Object,
+ Lisp_Object,
+ Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func,
+ Boolint reverse_order)
+{
+ Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
+ Elemcount array_index = 0;
+ int looped = 0;
+
+ GCPRO4 (list, tail, value, tortoise);
+
+ while (1)
+ {
+ if (NILP (list))
+ {
+ UNGCPRO;
+
+ if (NILP (tail))
+ {
+ return Flist (array_len, array);
+ }
+
+ Fsetcdr (tail, Flist (array_len - array_index, array + array_index));
+ return value;
+ }
+
+ if (array_index >= array_len)
+ {
+ UNGCPRO;
+ if (NILP (tail))
+ {
+ return list;
+ }
+
+ Fsetcdr (tail, list);
+ return value;
+ }
+
+
+ if (reverse_order ?
+ !NILP (c_predicate (Fcar (list), array [array_index], predicate,
+ key_func)) :
+ NILP (c_predicate (array [array_index], Fcar (list), predicate,
+ key_func)))
+ {
+ if (NILP (tail))
+ {
+ value = tail = list;
+ }
+ else
+ {
+ Fsetcdr (tail, list);
+ tail = XCDR (tail);
+ }
+
+ list = Fcdr (list);
+ }
+ else
+ {
+ if (NILP (tail))
+ {
+ value = tail = Fcons (array [array_index], Qnil);
+ }
+ else
+ {
+ Fsetcdr (tail, Fcons (array [array_index], tail));
+ tail = XCDR (tail);
+ }
+ ++array_index;
+ }
+
+ if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (looped & 1)
+ {
+ tortoise = XCDR (tortoise);
+ }
+
+ if (EQ (list, tortoise))
+ {
+ signal_circular_list_error (list);
+ }
+ }
+ }
+}
+
+static void
+list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
+ Lisp_Object list_one, Lisp_Object list_two,
+ Lisp_Object (*c_predicate) (Lisp_Object,
+ Lisp_Object,
+ Lisp_Object,
+ Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func)
+{
+ Elemcount output_index = 0;
+
+ while (output_index < output_len)
+ {
+ if (NILP (list_one))
+ {
+ while (output_index < output_len)
+ {
+ output [output_index] = Fcar (list_two);
+ list_two = Fcdr (list_two), ++output_index;
+ }
+ return;
+ }
+
+ if (NILP (list_two))
+ {
+ while (output_index < output_len)
+ {
+ output [output_index] = Fcar (list_one);
+ list_one = Fcdr (list_one), ++output_index;
+ }
+ return;
+ }
+
+ if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate,
+ key_func)))
+ {
+ output [output_index] = XCAR (list_one);
+ list_one = XCDR (list_one);
+ }
+ else
+ {
+ output [output_index] = XCAR (list_two);
+ list_two = XCDR (list_two);
+ }
+
+ ++output_index;
+
+ /* No need to check for circularity. */
+ }
+}
+
+static void
+list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
+ Lisp_Object list,
+ Lisp_Object *array, Elemcount array_len,
+ Lisp_Object (*c_predicate) (Lisp_Object,
+ Lisp_Object,
+ Lisp_Object,
+ Lisp_Object),
+ Lisp_Object predicate, Lisp_Object key_func,
+ Boolint reverse_order)
+{
+ Elemcount output_index = 0, array_index = 0;
+
+ while (output_index < output_len)
+ {
+ if (NILP (list))
+ {
+ if (array_len - array_index != output_len - output_index)
+ {
+ mapping_interaction_error (Qmerge, list);
+ }
+
+ while (array_index < array_len)
+ {
+ output [output_index++] = array [array_index++];
+ }
+
+ return;
+ }
+
+ if (array_index >= array_len)
+ {
+ while (output_index < output_len)
+ {
+ output [output_index++] = Fcar (list);
+ list = Fcdr (list);
+ }
+
+ return;
+ }
+
+ if (reverse_order ?
+ !NILP (c_predicate (Fcar (list), array [array_index], predicate,
+ key_func)) :
+ NILP (c_predicate (array [array_index], Fcar (list), predicate,
+ key_func)))
+ {
+ output [output_index] = XCAR (list);
+ list = XCDR (list);
+ }
+ else
+ {
+ output [output_index] = array [array_index];
+ ++array_index;
+ }
+
+ ++output_index;
+ }
+}
+
+#define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \
+ do { \
+ c_array = alloca_array (Lisp_Object, len); \
+ for (counter = 0; counter < len; ++counter) \
+ { \
+ c_array[counter] = make_char (itext_ichar (strdata)); \
+ INC_IBYTEPTR (strdata); \
+ } \
+ } while (0)
+
+#define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \
+ c_array = alloca_array (Lisp_Object, len); \
+ for (counter = 0; counter < len; ++counter) \
+ { \
+ c_array[counter] = make_int (bit_vector_bit (v, counter)); \
+ } \
+ } while (0)
DEFUN ("merge", Fmerge, 4, MANY, 0, /*
Destructively merge SEQUENCE-ONE and SEQUENCE-TWO, producing a new sequence.
＠＠ -3944,7 +6396,7 ＠＠
int
internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- if (depth > 200)
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
stack_overflow ("Stack overflow in equal", Qunbound);
QUIT;
if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
＠＠ -3989,7 +6441,7 ＠＠
int
internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- if (depth > 200)
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
stack_overflow ("Stack overflow in equalp", Qunbound);
QUIT;
＠＠ -4065,7 +6517,7 ＠＠
static int
internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- if (depth > 200)
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
stack_overflow ("Stack overflow in equal", Qunbound);
QUIT;
if (HACKEQ_UNSAFE (obj1, obj2))
＠＠ -4231,21 +6683,23 ＠＠
{
Elemcount counting = 0;
- EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
- {
- if (counting >= starting)
- {
- if (counting < ending)
- {
- XSETCAR (tail, item);
- }
- else if (counting == ending)
- {
- break;
- }
- }
- ++counting;
- }
+ {
+ EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
+ {
+ if (counting >= starting)
+ {
+ if (counting < ending)
+ {
+ XSETCAR (tail, item);
+ }
+ else if (counting == ending)
+ {
+ break;
+ }
+ }
+ ++counting;
+ }
+ }
if (counting < starting || (counting != ending && !NILP (end)))
{
＠＠ -6079,6 +8533,8 ＠＠
*p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor;
Charcount ii = 0, len1 = string_char_length (sequence1);
+ check_sequence_range (sequence1, start1, end1, make_int (len1));
+
while (ii < starting2 && p2 < p2end)
{
INC_IBYTEPTR (p2);
＠＠ -6188,6 +8644,2414 ＠＠
return result;
}
+DEFUN ("nsubstitute", Fnsubstitute, 3, MANY, 0, /*
+Substitute NEW for OLD in SEQUENCE.
+
+This is a destructive function; it reuses the storage of SEQUENCE whenever
+possible. See `remove*' for the meaning of the keywords.
+
+arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil;
+ Lisp_Object object_, position0;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0;
+ Elemcount len, ii = 0, counting = EMACS_INT_MAX, presenting = 0;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1;
+
+ PARSE_KEYWORDS (Fnsubstitute, nargs, args, 9,
+ (test, if_, if_not, test_not, key, start, end, count,
+ from_end), (start = Qzero));
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ if (BIGNUMP (count))
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
+ }
+ else
+ {
+ counting = XINT (count);
+ }
+
+ if (counting <= 0)
+ {
+ return sequence;
+ }
+ }
+
+ check_test = get_check_test_function (item, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ if (CONSP (sequence))
+ {
+ Lisp_Object elt;
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ Lisp_Object present = count_with_tail (&elt, nargs - 1, args + 1,
+ Qnsubstitute);
+
+ if (ZEROP (present))
+ {
+ return sequence;
+ }
+
+ presenting = XINT (present);
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ GCPRO1 (tail);
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len)
+ {
+ if (!(ii < ending))
+ {
+ break;
+ }
+
+ if (starting <= ii &&
+ check_test (test, key, item, elt) == test_not_unboundp
+ && (presenting ? encountered++ >= presenting
+: encountered++ < counting))
+ {
+ CHECK_LISP_WRITEABLE (tail);
+ XSETCAR (tail, new_);
+ }
+ else if (!presenting && encountered >= counting)
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+ UNGCPRO;
+
+ if ((ii < starting || (ii < ending && !NILP (end)))
+ && encountered < counting)
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
+ }
+ }
+ else if (STRINGP (sequence))
+ {
+ Ibyte *staging, new_bytes[MAX_ICHAR_LEN], *staging_cursor;
+ Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
+ Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence);
+ Bytecount new_len;
+ Lisp_Object character;
+
+ CHECK_CHAR_COERCE_INT (new_);
+
+ new_len = set_itext_ichar (new_bytes, XCHAR (new_));
+
+ /* Worst case scenario; new char is four octets long, all the old ones
+ were one octet long, all the old ones match. */
+ staging = alloca_ibytes (XSTRING_LENGTH (sequence) * new_len);
+ staging_cursor = staging;
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ Lisp_Object present = count_with_tail (&character, nargs - 1,
+ args + 1, Qnsubstitute);
+
+ if (ZEROP (present))
+ {
+ return sequence;
+ }
+
+ presenting = XINT (present);
+
+ /* If there are fewer items in the string than we have
+ permission to change, we don't need to differentiate
+ between the :from-end nil and :from-end t
+ cases. Otherwise, presenting is the number of matching
+ items we need to ignore before we start to change. */
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ ii = 0;
+ while (cursor_offset < byte_len && ii < ending)
+ {
+ if (ii >= starting)
+ {
+ character = make_char (itext_ichar (cursor));
+
+ if ((check_test (test, key, item, character)
+ == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting :
+ encountered++ < counting))
+ {
+ staging_cursor
+ += itext_copy_ichar (new_bytes, staging_cursor);
+ }
+ else
+ {
+ staging_cursor
+ += itext_copy_ichar (cursor, staging_cursor);
+ }
+
+ startp = XSTRING_DATA (sequence);
+ cursor = startp + cursor_offset;
+
+ if (byte_len != XSTRING_LENGTH (sequence)
+ || !valid_ibyteptr_p (cursor))
+ {
+ mapping_interaction_error (Qnsubstitute, sequence);
+ }
+ }
+ else
+ {
+ staging_cursor += itext_copy_ichar (cursor, staging_cursor);
+ }
+
+ INC_IBYTEPTR (cursor);
+ cursor_offset = cursor - startp;
+ ii++;
+ }
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
+
+ if (0 != encountered)
+ {
+ CHECK_LISP_WRITEABLE (sequence);
+ replace_string_range (sequence, Qzero, make_int (ii),
+ staging, staging_cursor);
+ }
+ }
+ else
+ {
+ Elemcount positioning;
+ Lisp_Object object = Qnil;
+
+ len = XINT (Flength (sequence));
+ check_sequence_range (sequence, start, end, make_int (len));
+
+ position0 = position (&object, item, sequence, check_test,
+ test_not_unboundp, test, key, start, end, from_end,
+ Qnil, Qnsubstitute);
+
+ if (NILP (position0))
+ {
+ return sequence;
+ }
+
+ positioning = XINT (position0);
+ ending = min (len, ending);
+
+ Faset (sequence, position0, new_);
+ encountered = 1;
+
+ if (NILP (from_end))
+ {
+ for (ii = positioning + 1; ii < ending; ii++)
+ {
+ object_ = Faref (sequence, make_int (ii));
+
+ if (check_test (test, key, item, object_) == test_not_unboundp
+ && encountered++ < counting)
+ {
+ Faset (sequence, make_int (ii), new_);
+ }
+ else if (encountered == counting)
+ {
+ break;
+ }
+ }
+ }
+ else
+ {
+ for (ii = positioning - 1; ii >= starting; ii--)
+ {
+ object_ = Faref (sequence, make_int (ii));
+
+ if (check_test (test, key, item, object_) == test_not_unboundp
+ && encountered++ < counting)
+ {
+ Faset (sequence, make_int (ii), new_);
+ }
+ else if (encountered == counting)
+ {
+ break;
+ }
+ }
+ }
+ }
+
+ return sequence;
+}
+
+DEFUN ("substitute", Fsubstitute, 3, MANY, 0, /*
+Substitute NEW for OLD in SEQUENCE.
+
+This is a non-destructive function; it makes a copy of SEQUENCE if necessary
+to avoid corrupting the original SEQUENCE.
+
+See `remove*' for the meaning of the keywords.
+
+arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) COUNT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil;
+ Lisp_Object elt, tailing = Qnil, result = Qnil, result_tail = Qnil;
+ Lisp_Object object, position0, matched_count;
+ Elemcount starting = 0, ending = EMACS_INT_MAX, encountered = 0;
+ Elemcount len, ii = 0, counting = EMACS_INT_MAX, presenting = 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));
+
+ CHECK_SEQUENCE (sequence);
+
+ CHECK_NATNUM (start);
+ starting = BIGNUMP (start) ? 1 + EMACS_INT_MAX : XINT (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ ending = BIGNUMP (end) ? 1 + EMACS_INT_MAX : XINT (end);
+ }
+
+ 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 (BIGNUMP (count))
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + EMACS_INT_MAX : -1 + EMACS_INT_MIN;
+ }
+ else
+ {
+ counting = XINT (count);
+ }
+
+ if (counting <= 0)
+ {
+ return sequence;
+ }
+ }
+ }
+
+ if (!CONSP (sequence))
+ {
+ position0 = position (&object, item, sequence, check_test,
+ test_not_unboundp, test, key, start, end, from_end,
+ Qnil, Qsubstitute);
+
+ if (NILP (position0))
+ {
+ return sequence;
+ }
+ else
+ {
+ args[2] = Fcopy_sequence (sequence);
+ return Fnsubstitute (nargs, args);
+ }
+ }
+
+ matched_count = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute);
+
+ if (ZEROP (matched_count))
+ {
+ return sequence;
+ }
+
+ if (!NILP (count) && !NILP (from_end))
+ {
+ presenting = XINT (matched_count);
+ presenting = presenting <= counting ? 0 : presenting - counting;
+ }
+
+ GCPRO1 (tailing);
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tailing, len)
+ {
+ if (EQ (tail, tailing))
+ {
+ if (NILP (result))
+ {
+ RETURN_UNGCPRO (XCDR (tail));
+ }
+
+ XSETCDR (result_tail, XCDR (tail));
+ RETURN_UNGCPRO (result);
+ }
+ else if (starting <= ii && ii < ending &&
+ (check_test (test, key, item, elt) == test_not_unboundp)
+ && (presenting ? encountered++ >= presenting
+: encountered++ < counting))
+ {
+ if (NILP (result))
+ {
+ result = result_tail = Fcons (new_, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (new_, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+
+ if (ii == ending)
+ {
+ break;
+ }
+
+ ii++;
+ }
+ }
+ UNGCPRO;
+
+ if (ii < starting || (ii < ending && !NILP (end)))
+ {
+ check_sequence_range (args[0], start, end, Flength (args[0]));
+ }
+
+ return result;
+}
+
+static Lisp_Object
+subst (Lisp_Object new_, Lisp_Object old, Lisp_Object tree, int depth)
+{
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
+ {
+ stack_overflow ("Stack overflow in subst", tree);
+ }
+
+ if (EQ (tree, old))
+ {
+ return new_;
+ }
+ else if (CONSP (tree))
+ {
+ Lisp_Object aa = subst (new_, old, XCAR (tree), depth + 1);
+ Lisp_Object dd = subst (new_, old, XCDR (tree), depth + 1);
+
+ if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree)))
+ {
+ return tree;
+ }
+ else
+ {
+ return Fcons (aa, dd);
+ }
+ }
+ else
+ {
+ return tree;
+ }
+}
+
+static Lisp_Object
+sublis (Lisp_Object alist, Lisp_Object tree,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key, int depth)
+{
+ Lisp_Object keyed = KEY (key, tree), tailed = alist, aa, dd;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
+ {
+ stack_overflow ("Stack overflow in sublis", tree);
+ }
+
+ GCPRO3 (tailed, alist, tree);
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, elt_car, keyed) == test_not_unboundp)
+ {
+ /* Don't use elt_cdr, it is helpful to allow TEST or KEY to
+ modify the alist while it executes. */
+ RETURN_UNGCPRO (XCDR (elt));
+ }
+ }
+ }
+ if (!CONSP (tree))
+ {
+ RETURN_UNGCPRO (tree);
+ }
+
+ aa = sublis (alist, XCAR (tree), check_test, test_not_unboundp, test, key,
+ depth + 1);
+ dd = sublis (alist, XCDR (tree), check_test, test_not_unboundp, test, key,
+ depth + 1);
+
+ if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree)))
+ {
+ RETURN_UNGCPRO (tree);
+ }
+
+ RETURN_UNGCPRO (Fcons (aa, dd));
+}
+
+DEFUN ("sublis", Fsublis, 2, MANY, 0, /*
+Perform substitutions indicated by ALIST in TREE (non-destructively).
+Return a copy of TREE with all matching elements replaced.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object alist = args[0], tree = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fsublis, nargs, args, 5, (test, if_, test_not, if_not, key),
+ (key = Qidentity));
+
+ if (NILP (key))
+ {
+ key = Qidentity;
+ }
+
+ get_check_match_function (&test, test_not, if_, if_not,
+ /* sublis() is going to apply the key, don't ask
+ for a match function that will do it for
+ us. */
+ Qidentity, &test_not_unboundp, &check_test);
+
+ if (CONSP (alist) && NILP (XCDR (alist)) && CONSP (XCAR (alist))
+ && EQ (key, Qidentity) && 1 == test_not_unboundp
+ && (check_eq_nokey == check_test ||
+ (check_eql_nokey == check_test &&
+ !NON_FIXNUM_NUMBER_P (XCAR (XCAR (alist))))))
+ {
+ /* #'subst with #'eq is very cheap indeed; call it. */
+ return subst (XCDR (XCAR (alist)), XCAR (XCAR (alist)), tree, 0);
+ }
+
+ return sublis (alist, tree, check_test, test_not_unboundp, test, key, 0);
+}
+
+static Lisp_Object
+nsublis (Lisp_Object alist, Lisp_Object tree,
+ check_test_func_t check_test,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key, int depth)
+{
+ Lisp_Object tree_saved = tree, tailed = alist, tortoise = tree, keyed = Qnil;
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
+ int count = 0;
+
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
+ {
+ stack_overflow ("Stack overflow in nsublis", tree);
+ }
+
+ GCPRO4 (tailed, alist, tree_saved, keyed);
+
+ while (CONSP (tree))
+ {
+ Boolint replaced = 0;
+ keyed = KEY (key, XCAR (tree));
+
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, elt_car, keyed) == test_not_unboundp)
+ {
+ CHECK_LISP_WRITEABLE (tree);
+ /* See comment in sublis() on using elt_cdr. */
+ XSETCAR (tree, XCDR (elt));
+ replaced = 1;
+ break;
+ }
+ }
+ }
+
+ if (!replaced)
+ {
+ if (CONSP (XCAR (tree)))
+ {
+ nsublis (alist, XCAR (tree), check_test, test_not_unboundp,
+ test, key, depth + 1);
+ }
+ }
+
+ keyed = KEY (key, XCDR (tree));
+ replaced = 0;
+
+ {
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, elt_car, keyed) == test_not_unboundp)
+ {
+ CHECK_LISP_WRITEABLE (tree);
+ /* See comment in sublis() on using elt_cdr. */
+ XSETCDR (tree, XCDR (elt));
+ tree = Qnil;
+ break;
+ }
+ }
+ }
+
+ if (!NILP (tree))
+ {
+ tree = XCDR (tree);
+ }
+
+ if (++count > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (count & 1)
+ {
+ tortoise = XCDR (tortoise);
+ }
+
+ if (EQ (tortoise, tree))
+ {
+ signal_circular_list_error (tree);
+ }
+ }
+ }
+
+ RETURN_UNGCPRO (tree_saved);
+}
+
+DEFUN ("nsublis", Fnsublis, 2, MANY, 0, /*
+Perform substitutions indicated by ALIST in TREE (destructively).
+Any matching element of TREE is changed via a call to `setcar'.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object alist = args[0], tree = args[1], tailed = Qnil, keyed = Qnil;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2;
+
+ PARSE_KEYWORDS (Fnsublis, nargs, args, 5, (test, if_, test_not, if_not, key),
+ (key = Qidentity));
+
+ if (NILP (key))
+ {
+ key = Qidentity;
+ }
+
+ get_check_match_function (&test, test_not, if_, if_not,
+ /* nsublis() is going to apply the key, don't ask
+ for a match function that will do it for
+ us. */
+ Qidentity, &test_not_unboundp, &check_test);
+
+ GCPRO2 (tailed, keyed);
+
+ keyed = KEY (key, tree);
+
+ {
+ /* nsublis() won't attempt to replace a cons handed to it, do that
+ ourselves. */
+ EXTERNAL_ALIST_LOOP_5 (elt, elt_car, elt_cdr, alist, tail)
+ {
+ tailed = tail;
+
+ if (check_test (test, key, elt_car, keyed) == test_not_unboundp)
+ {
+ /* See comment in sublis() on using elt_cdr. */
+ RETURN_UNGCPRO (XCDR (elt));
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ return nsublis (alist, tree, check_test, test_not_unboundp, test, key, 0);
+}
+
+DEFUN ("subst", Fsubst, 3, MANY, 0, /*
+Substitute NEW for OLD everywhere in TREE (non-destructively).
+
+Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
+
+See `member*' for the meaning of :test, :test-not and :key.
+
+arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]),
+ Qnil);
+ args[1] = alist;
+ result = Fsublis (nargs - 1, args + 1);
+ free_cons (XCAR (alist));
+ free_cons (alist);
+
+ return result;
+}
+
+DEFUN ("nsubst", Fnsubst, 3, MANY, 0, /*
+Substitute NEW for OLD everywhere in TREE (destructively).
+
+Any element of TREE which is `eql' to OLD is changed to NEW (via a call to
+`setcar').
+
+See `member*' for the meaning of the keywords.
+
+arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]),
+ Qnil);
+ args[1] = alist;
+ result = Fnsublis (nargs - 1, args + 1);
+ free_cons (XCAR (alist));
+ free_cons (alist);
+
+ return result;
+}
+
+static Boolint
+tree_equal (Lisp_Object tree1, Lisp_Object tree2,
+ check_test_func_t check_test, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key, int depth)
+{
+ Lisp_Object tortoise1 = tree1, tortoise2 = tree2;
+ struct gcpro gcpro1, gcpro2;
+ int count = 0;
+ Boolint result;
+
+ if (depth + lisp_eval_depth > max_lisp_eval_depth)
+ {
+ stack_overflow ("Stack overflow in tree-equal", tree1);
+ }
+
+ GCPRO2 (tree1, tree2);
+
+ while (CONSP (tree1) && CONSP (tree2)
+ && tree_equal (XCAR (tree1), XCAR (tree2), check_test,
+ test_not_unboundp, test, key, depth + 1))
+ {
+ tree1 = XCDR (tree1);
+ tree2 = XCDR (tree2);
+
+ if (++count > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (count & 1)
+ {
+ tortoise1 = XCDR (tortoise1);
+ tortoise2 = XCDR (tortoise2);
+ }
+
+ if (EQ (tortoise1, tree1))
+ {
+ signal_circular_list_error (tree1);
+ }
+
+ if (EQ (tortoise2, tree2))
+ {
+ signal_circular_list_error (tree2);
+ }
+ }
+ }
+
+ if (CONSP (tree1) || CONSP (tree2))
+ {
+ UNGCPRO;
+ return 0;
+ }
+
+ result = check_test (test, key, tree1, tree2) == test_not_unboundp;
+ UNGCPRO;
+
+ return result;
+}
+
+DEFUN ("tree-equal", Ftree_equal, 2, MANY, 0, /*
+Return t if TREE1 and TREE2 have `eql' leaves.
+
+Atoms are compared by `eql', unless another test is specified using
+:test; cons cells are compared recursively.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+arguments: (TREE1 TREE2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object tree1 = args[0], tree2 = args[1];
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Ftree_equal, nargs, args, 3, (test, key, test_not),
+ (key = Qidentity));
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ return tree_equal (tree1, tree2, check_test, test_not_unboundp, test, key,
+ 0) ? Qt : Qnil;
+}
+
+static Lisp_Object
+mismatch_from_end (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
+ Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint UNUSED (return_sequence1_index))
+{
+ Elemcount sequence1_len = XINT (Flength (sequence1));
+ Elemcount sequence2_len = XINT (Flength (sequence2)), ii = 0;
+ Elemcount starting1, ending1, starting2, ending2;
+ Lisp_Object *sequence1_storage = NULL, *sequence2_storage = NULL;
+ struct gcpro gcpro1, gcpro2;
+
+ check_sequence_range (sequence1, start1, end1, make_int (sequence1_len));
+ starting1 = XINT (start1);
+ ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX;
+ ending1 = min (ending1, sequence1_len);
+
+ check_sequence_range (sequence2, start2, end2, make_int (sequence2_len));
+ starting2 = XINT (start2);
+ ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX;
+ ending2 = min (ending2, sequence2_len);
+
+ if (LISTP (sequence1))
+ {
+ Lisp_Object *saving;
+ sequence1_storage = saving
+ = alloca_array (Lisp_Object, ending1 - starting1);
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence1)
+ {
+ if (starting1 <= ii && ii < ending1)
+ {
+ *saving++ = elt;
+ }
+ else if (ii == ending1)
+ {
+ break;
+ }
+
+ ++ii;
+ }
+ }
+ }
+ else if (STRINGP (sequence1))
+ {
+ const Ibyte *cursor = string_char_addr (sequence1, starting1);
+
+ STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence1_storage, ii,
+ ending1 - starting1);
+
+ }
+ else if (BIT_VECTORP (sequence1))
+ {
+ Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence1);
+ sequence1_storage = alloca_array (Lisp_Object, ending1 - starting1);
+ for (ii = starting1; ii < ending1; ++ii)
+ {
+ sequence1_storage[ii - starting1]
+ = make_int (bit_vector_bit (vv, ii));
+ }
+ }
+ else
+ {
+ sequence1_storage = XVECTOR_DATA (sequence1) + starting1;
+ }
+
+ ii = 0;
+
+ if (LISTP (sequence2))
+ {
+ Lisp_Object *saving;
+ sequence2_storage = saving
+ = alloca_array (Lisp_Object, ending2 - starting2);
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence2)
+ {
+ if (starting2 <= ii && ii < ending2)
+ {
+ *saving++ = elt;
+ }
+ else if (ii == ending2)
+ {
+ break;
+ }
+
+ ++ii;
+ }
+ }
+ }
+ else if (STRINGP (sequence2))
+ {
+ const Ibyte *cursor = string_char_addr (sequence2, starting2);
+
+ STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence2_storage, ii,
+ ending2 - starting2);
+
+ }
+ else if (BIT_VECTORP (sequence2))
+ {
+ Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence2);
+ sequence2_storage = alloca_array (Lisp_Object, ending2 - starting2);
+ for (ii = starting2; ii < ending2; ++ii)
+ {
+ sequence2_storage[ii - starting2]
+ = make_int (bit_vector_bit (vv, ii));
+ }
+ }
+ else
+ {
+ sequence2_storage = XVECTOR_DATA (sequence2) + starting2;
+ }
+
+ GCPRO2 (sequence1_storage[0], sequence2_storage[0]);
+ gcpro1.nvars = ending1 - starting1;
+ gcpro2.nvars = ending2 - starting2;
+
+ while (ending1 > starting1 && ending2 > starting2)
+ {
+ --ending1;
+ --ending2;
+
+ if (check_match (test, key, sequence1_storage[ending1 - starting1],
+ sequence2_storage[ending2 - starting2])
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (ending1 + 1);
+ }
+ }
+
+ UNGCPRO;
+
+ if (ending1 > starting1 || ending2 > starting2)
+ {
+ return make_integer (ending1);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_list_list (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
+ Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint UNUSED (return_list_index))
+{
+ Lisp_Object sequence1_tortoise = sequence1, sequence2_tortoise = sequence2;
+ Lisp_Object orig_sequence1 = sequence1, orig_sequence2 = sequence2;
+ Elemcount ending1 = EMACS_INT_MAX, ending2 = EMACS_INT_MAX;
+ Elemcount starting1, starting2, counting, startcounting;
+ Elemcount shortest_len = 0;
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
+
+ starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX;
+ starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX;
+
+ if (!NILP (end1))
+ {
+ ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX;
+ }
+
+ if (!NILP (end2))
+ {
+ ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX;
+ }
+
+ if (!ZEROP (start1))
+ {
+ sequence1 = Fnthcdr (start1, sequence1);
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (sequence1_tortoise, start1, end1,
+ Flength (sequence1_tortoise));
+ /* Give up early here. */
+ return Qnil;
+ }
+
+ ending1 -= starting1;
+ starting1 = 0;
+ sequence1_tortoise = sequence1;
+ }
+
+ if (!ZEROP (start2))
+ {
+ sequence2 = Fnthcdr (start2, sequence2);
+
+ if (NILP (sequence2))
+ {
+ check_sequence_range (sequence2_tortoise, start2, end2,
+ Flength (sequence2_tortoise));
+ return Qnil;
+ }
+
+ ending2 -= starting2;
+ starting2 = 0;
+ sequence2_tortoise = sequence2;
+ }
+
+ GCPRO4 (sequence1, sequence2, sequence1_tortoise, sequence2_tortoise);
+
+ counting = startcounting = min (ending1, ending2);
+
+ while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2))
+ {
+ if (check_match (test, key,
+ CONSP (sequence1) ? XCAR (sequence1)
+: Fcar (sequence1),
+ CONSP (sequence2) ? XCAR (sequence2)
+: Fcar (sequence2) ) != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (XINT (start1) + shortest_len);
+ }
+
+ sequence1 = CONSP (sequence1) ? XCDR (sequence1) : Fcdr (sequence1);
+ sequence2 = CONSP (sequence2) ? XCDR (sequence2) : Fcdr (sequence2);
+
+ shortest_len++;
+
+ if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (counting & 1)
+ {
+ sequence1_tortoise = XCDR (sequence1_tortoise);
+ sequence2_tortoise = XCDR (sequence2_tortoise);
+ }
+
+ if (EQ (sequence1, sequence1_tortoise))
+ {
+ signal_circular_list_error (sequence1);
+ }
+
+ if (EQ (sequence2, sequence2_tortoise))
+ {
+ signal_circular_list_error (sequence2);
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ if (NILP (sequence1))
+ {
+ Lisp_Object args[] = { start1, make_int (shortest_len) };
+ check_sequence_range (orig_sequence1, start1, end1,
+ Fplus (countof (args), args));
+ }
+
+ if (NILP (sequence2))
+ {
+ Lisp_Object args[] = { start2, make_int (shortest_len) };
+ check_sequence_range (orig_sequence2, start2, end2,
+ Fplus (countof (args), args));
+ }
+
+ if ((!NILP (end1) && shortest_len != ending1 - starting1) ||
+ (!NILP (end2) && shortest_len != ending2 - starting2))
+ {
+ return make_integer (XINT (start1) + shortest_len);
+ }
+
+ if ((NILP (end1) && CONSP (sequence1)) || (NILP (end2) && CONSP (sequence2)))
+ {
+ return make_integer (XINT (start1) + shortest_len);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_list_string (Lisp_Object list, Lisp_Object list_start,
+ Lisp_Object list_end,
+ Lisp_Object string, Lisp_Object string_start,
+ Lisp_Object string_end,
+ check_test_func_t check_match,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint return_list_index)
+{
+ Ibyte *string_data = XSTRING_DATA (string), *startp = string_data;
+ Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string);
+ Elemcount char_count = 0, list_starting, list_ending;
+ Elemcount string_starting, string_ending;
+ Lisp_Object character, orig_list = list;
+ struct gcpro gcpro1;
+
+ list_ending = INTP (list_end) ? XINT (list_end) : 1 + EMACS_INT_MAX;
+ list_starting = INTP (list_start) ? XINT (list_start) : 1 + EMACS_INT_MAX;
+
+ string_ending = INTP (string_end) ? XINT (string_end) : 1 + EMACS_INT_MAX;
+ string_starting
+ = INTP (string_start) ? XINT (string_start) : 1 + EMACS_INT_MAX;
+
+ while (char_count < string_starting && string_offset < string_len)
+ {
+ INC_IBYTEPTR (string_data);
+ string_offset = string_data - startp;
+ char_count++;
+ }
+
+ if (!ZEROP (list_start))
+ {
+ list = Fnthcdr (list_start, list);
+ if (NILP (list))
+ {
+ check_sequence_range (orig_list, list_start, list_end,
+ Flength (orig_list));
+ return Qnil;
+ }
+
+ list_ending -= list_starting;
+ list_starting = 0;
+ }
+
+ GCPRO1 (list);
+
+ while (list_starting < list_ending && string_starting < string_ending
+ && string_offset < string_len && !NILP (list))
+ {
+ character = make_char (itext_ichar (string_data));
+
+ if (return_list_index)
+ {
+ if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list),
+ character)
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (XINT (list_start) + char_count);
+ }
+ }
+ else
+ {
+ if (check_match (test, key, character,
+ CONSP (list) ? XCAR (list) : Fcar (list))
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (char_count);
+ }
+ }
+
+ list = CONSP (list) ? XCDR (list) : Fcdr (list);
+
+ startp = XSTRING_DATA (string);
+ string_data = startp + string_offset;
+ if (string_len != XSTRING_LENGTH (string)
+ || !valid_ibyteptr_p (string_data))
+ {
+ mapping_interaction_error (Qmismatch, string);
+ }
+
+ list_starting++;
+ string_starting++;
+ char_count++;
+ INC_IBYTEPTR (string_data);
+ string_offset = string_data - startp;
+ }
+
+ UNGCPRO;
+
+ if (NILP (list))
+ {
+ Lisp_Object args[] = { list_start, make_int (char_count) };
+ check_sequence_range (orig_list, list_start, list_end,
+ Fplus (countof (args), args));
+ }
+
+ if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string))
+ {
+ check_sequence_range (string, string_start, string_end,
+ make_int (char_count));
+ }
+
+ if ((NILP (string_end) ?
+ string_offset < string_len : string_starting < string_ending) ||
+ (NILP (list_end) ? !NILP (list) : list_starting < list_ending))
+ {
+ return make_integer (return_list_index ? XINT (list_start) + char_count :
+ char_count);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_list_array (Lisp_Object list, Lisp_Object list_start,
+ Lisp_Object list_end,
+ Lisp_Object array, Lisp_Object array_start,
+ Lisp_Object array_end,
+ check_test_func_t check_match,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint return_list_index)
+{
+ Elemcount ii = 0, list_starting, list_ending;
+ Elemcount array_starting, array_ending, array_len;
+ Lisp_Object orig_list = list;
+ struct gcpro gcpro1;
+
+ list_ending = INTP (list_end) ? XINT (list_end) : 1 + EMACS_INT_MAX;
+ list_starting = INTP (list_start) ? XINT (list_start) : 1 + EMACS_INT_MAX;
+
+ array_ending = INTP (array_end) ? XINT (array_end) : 1 + EMACS_INT_MAX;
+ array_starting = INTP (array_start) ? XINT (array_start) : 1 + EMACS_INT_MAX;
+ array_len = XINT (Flength (array));
+
+ array_ending = min (array_ending, array_len);
+
+ check_sequence_range (array, array_start, array_end, make_int (array_len));
+
+ if (!ZEROP (list_start))
+ {
+ list = Fnthcdr (list_start, list);
+ if (NILP (list))
+ {
+ check_sequence_range (orig_list, list_start, list_end,
+ Flength (orig_list));
+ return Qnil;
+ }
+
+ list_ending -= list_starting;
+ list_starting = 0;
+ }
+
+ GCPRO1 (list);
+
+ while (list_starting < list_ending && array_starting < array_ending
+ && !NILP (list))
+ {
+ if (return_list_index)
+ {
+ if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list),
+ Faref (array, make_int (array_starting)))
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (XINT (list_start) + ii);
+ }
+ }
+ else
+ {
+ if (check_match (test, key, Faref (array, make_int (array_starting)),
+ CONSP (list) ? XCAR (list) : Fcar (list))
+ != test_not_unboundp)
+ {
+ UNGCPRO;
+ return make_integer (array_starting);
+ }
+ }
+
+ list = CONSP (list) ? XCDR (list) : Fcdr (list);
+ list_starting++;
+ array_starting++;
+ ii++;
+ }
+
+ UNGCPRO;
+
+ if (NILP (list))
+ {
+ Lisp_Object args[] = { list_start, make_int (ii) };
+ check_sequence_range (orig_list, list_start, list_end,
+ Fplus (countof (args), args));
+ }
+
+ if (array_starting < array_ending ||
+ (NILP (list_end) ? !NILP (list) : list_starting < list_ending))
+ {
+ return make_integer (return_list_index ? XINT (list_start) + ii :
+ array_starting);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_string_array (Lisp_Object string, Lisp_Object string_start,
+ Lisp_Object string_end,
+ Lisp_Object array, Lisp_Object array_start,
+ Lisp_Object array_end,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint return_string_index)
+{
+ Ibyte *string_data = XSTRING_DATA (string), *startp = string_data;
+ Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string);
+ Elemcount char_count = 0, array_starting, array_ending, array_length;
+ Elemcount string_starting, string_ending;
+ Lisp_Object character;
+
+ array_starting = INTP (array_start) ? XINT (array_start) : 1 + EMACS_INT_MAX;
+ array_ending = INTP (array_end) ? XINT (array_end) : 1 + EMACS_INT_MAX;
+ array_length = XINT (Flength (array));
+ check_sequence_range (array, array_start, array_end, make_int (array_length));
+ array_ending = min (array_ending, array_length);
+
+ string_ending = INTP (string_end) ? XINT (string_end) : 1 + EMACS_INT_MAX;
+ string_starting
+ = INTP (string_start) ? XINT (string_start) : 1 + EMACS_INT_MAX;
+
+ while (char_count < string_starting && string_offset < string_len)
+ {
+ INC_IBYTEPTR (string_data);
+ string_offset = string_data - startp;
+ char_count++;
+ }
+
+ while (array_starting < array_ending && string_starting < string_ending
+ && string_offset < string_len)
+ {
+ character = make_char (itext_ichar (string_data));
+
+ if (return_string_index)
+ {
+ if (check_match (test, key, character,
+ Faref (array, make_int (array_starting)))
+ != test_not_unboundp)
+ {
+ return make_integer (char_count);
+ }
+ }
+ else
+ {
+ if (check_match (test, key,
+ Faref (array, make_int (array_starting)),
+ character)
+ != test_not_unboundp)
+ {
+ return make_integer (XINT (array_start) + char_count);
+ }
+ }
+
+ startp = XSTRING_DATA (string);
+ string_data = startp + string_offset;
+ if (string_len != XSTRING_LENGTH (string)
+ || !valid_ibyteptr_p (string_data))
+ {
+ mapping_interaction_error (Qmismatch, string);
+ }
+
+ array_starting++;
+ string_starting++;
+ char_count++;
+ INC_IBYTEPTR (string_data);
+ string_offset = string_data - startp;
+ }
+
+ if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string))
+ {
+ check_sequence_range (string, string_start, string_end,
+ make_int (char_count));
+ }
+
+ if ((NILP (string_end) ?
+ string_offset < string_len : string_starting < string_ending) ||
+ (NILP (array_end) ? !NILP (array) : array_starting < array_ending))
+ {
+ return make_integer (return_string_index ? char_count :
+ XINT (array_start) + char_count);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_string_string (Lisp_Object string1,
+ Lisp_Object string1_start, Lisp_Object string1_end,
+ Lisp_Object string2, Lisp_Object string2_start,
+ Lisp_Object string2_end,
+ check_test_func_t check_match,
+ Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint UNUSED (return_string1_index))
+{
+ Ibyte *string1_data = XSTRING_DATA (string1), *startp1 = string1_data;
+ Bytecount string1_offset = 0, string1_len = XSTRING_LENGTH (string1);
+ Ibyte *string2_data = XSTRING_DATA (string2), *startp2 = string2_data;
+ Bytecount string2_offset = 0, string2_len = XSTRING_LENGTH (string2);
+ Elemcount char_count1 = 0, string1_starting, string1_ending;
+ Elemcount char_count2 = 0, string2_starting, string2_ending;
+ Lisp_Object character1, character2;
+
+ string1_ending = INTP (string1_end) ? XINT (string1_end) : 1 + EMACS_INT_MAX;
+ string1_starting
+ = INTP (string1_start) ? XINT (string1_start) : 1 + EMACS_INT_MAX;
+
+ string2_starting
+ = INTP (string2_start) ? XINT (string2_start) : 1 + EMACS_INT_MAX;
+ string2_ending = INTP (string2_end) ? XINT (string2_end) : 1 + EMACS_INT_MAX;
+
+ while (char_count1 < string1_starting && string1_offset < string1_len)
+ {
+ INC_IBYTEPTR (string1_data);
+ string1_offset = string1_data - startp1;
+ char_count1++;
+ }
+
+ while (char_count2 < string2_starting && string2_offset < string2_len)
+ {
+ INC_IBYTEPTR (string2_data);
+ string2_offset = string2_data - startp2;
+ char_count2++;
+ }
+
+ while (string2_starting < string2_ending && string1_starting < string1_ending
+ && string1_offset < string1_len && string2_offset < string2_len)
+ {
+ character1 = make_char (itext_ichar (string1_data));
+ character2 = make_char (itext_ichar (string2_data));
+
+ if (check_match (test, key, character1, character2)
+ != test_not_unboundp)
+ {
+ return make_integer (char_count1);
+ }
+
+ startp1 = XSTRING_DATA (string1);
+ string1_data = startp1 + string1_offset;
+ if (string1_len != XSTRING_LENGTH (string1)
+ || !valid_ibyteptr_p (string1_data))
+ {
+ mapping_interaction_error (Qmismatch, string1);
+ }
+
+ startp2 = XSTRING_DATA (string2);
+ string2_data = startp2 + string2_offset;
+ if (string2_len != XSTRING_LENGTH (string2)
+ || !valid_ibyteptr_p (string2_data))
+ {
+ mapping_interaction_error (Qmismatch, string2);
+ }
+
+ string2_starting++;
+ string1_starting++;
+ char_count1++;
+ char_count2++;
+ INC_IBYTEPTR (string1_data);
+ string1_offset = string1_data - startp1;
+ INC_IBYTEPTR (string2_data);
+ string2_offset = string2_data - startp2;
+ }
+
+ if (string1_data == XSTRING_DATA (string1) + XSTRING_LENGTH (string1))
+ {
+ check_sequence_range (string1, string1_start, string1_end,
+ make_int (char_count1));
+ }
+
+ if (string2_data == XSTRING_DATA (string2) + XSTRING_LENGTH (string2))
+ {
+ check_sequence_range (string2, string2_start, string2_end,
+ make_int (char_count2));
+ }
+
+ if ((!NILP (string1_end) && string1_starting < string1_ending) ||
+ (!NILP (string2_end) && string2_starting < string2_ending))
+ {
+ return make_integer (char_count1);
+ }
+
+ if ((NILP (string1_end) && string1_data
+ < (XSTRING_DATA (string1) + XSTRING_LENGTH (string1))) ||
+ (NILP (string2_end) && string2_data
+ < (XSTRING_DATA (string2) + XSTRING_LENGTH (string2))))
+ {
+ return make_integer (char_count1);
+ }
+
+ return Qnil;
+}
+
+static Lisp_Object
+mismatch_array_array (Lisp_Object array1, Lisp_Object start1, Lisp_Object end1,
+ Lisp_Object array2, Lisp_Object start2, Lisp_Object end2,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint UNUSED (return_array1_index))
+{
+ Elemcount len1 = XINT (Flength (array1)), len2 = XINT (Flength (array2));
+ Elemcount ending1 = EMACS_INT_MAX, ending2 = EMACS_INT_MAX;
+ Elemcount starting1, starting2;
+
+ check_sequence_range (array1, start1, end1, make_int (len1));
+ check_sequence_range (array2, start2, end2, make_int (len2));
+
+ starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX;
+ starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX;
+
+ if (!NILP (end1))
+ {
+ ending1 = INTP (end1) ? XINT (end1) : 1 + EMACS_INT_MAX;
+ }
+
+ if (!NILP (end2))
+ {
+ ending2 = INTP (end2) ? XINT (end2) : 1 + EMACS_INT_MAX;
+ }
+
+ ending1 = min (ending1, len1);
+ ending2 = min (ending2, len2);
+
+ while (starting1 < ending1 && starting2 < ending2)
+ {
+ if (check_match (test, key, Faref (array1, make_int (starting1)),
+ Faref (array2, make_int (starting2)))
+ != test_not_unboundp)
+ {
+ return make_integer (starting1);
+ }
+ starting1++;
+ starting2++;
+ }
+
+ if (starting1 < ending1 || starting2 < ending2)
+ {
+ return make_integer (starting1);
+ }
+
+ return Qnil;
+}
+
+typedef Lisp_Object
+(*mismatch_func_t) (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
+ Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
+ check_test_func_t check_match, Boolint test_not_unboundp,
+ Lisp_Object test, Lisp_Object key,
+ Boolint return_list_index);
+
+static mismatch_func_t
+get_mismatch_func (Lisp_Object sequence1, Lisp_Object sequence2,
+ Lisp_Object from_end, Boolint *return_sequence1_index_out)
+{
+ CHECK_SEQUENCE (sequence1);
+ CHECK_SEQUENCE (sequence2);
+
+ if (!NILP (from_end))
+ {
+ *return_sequence1_index_out = 1;
+ return mismatch_from_end;
+ }
+
+ if (LISTP (sequence1))
+ {
+ if (LISTP (sequence2))
+ {
+ *return_sequence1_index_out = 1;
+ return mismatch_list_list;
+ }
+
+ if (STRINGP (sequence2))
+ {
+ *return_sequence1_index_out = 1;
+ return mismatch_list_string;
+ }
+
+ *return_sequence1_index_out = 1;
+ return mismatch_list_array;
+ }
+
+ if (STRINGP (sequence1))
+ {
+ if (STRINGP (sequence2))
+ {
+ *return_sequence1_index_out = 1;
+ return mismatch_string_string;
+ }
+
+ if (LISTP (sequence2))
+ {
+ *return_sequence1_index_out = 0;
+ return mismatch_list_string;
+ }
+
+ *return_sequence1_index_out = 1;
+ return mismatch_string_array;
+ }
+
+ if (ARRAYP (sequence1))
+ {
+ if (STRINGP (sequence2))
+ {
+ *return_sequence1_index_out = 0;
+ return mismatch_string_array;
+ }
+
+ if (LISTP (sequence2))
+ {
+ *return_sequence1_index_out = 0;
+ return mismatch_list_array;
+ }
+
+ *return_sequence1_index_out = 1;
+ return mismatch_array_array;
+ }
+
+ RETURN_NOT_REACHED (NULL);
+ return NULL;
+}
+
+DEFUN ("mismatch", Fmismatch, 2, MANY, 0, /*
+Compare SEQUENCE1 with SEQUENCE2, return index of first mismatching element.
+
+Return nil if the sequences match. If one sequence is a prefix of the
+other, the return value indicates the end of the shorter sequence. A
+non-nil return value always reflects an index into SEQUENCE1.
+
+See `search' for the meaning of the keywords."
+
+arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence1 = args[0], sequence2 = args[1];
+ Boolint test_not_unboundp = 1, return_first_index = 0;
+ check_test_func_t check_match = NULL;
+ mismatch_func_t mismatch = NULL;
+
+ PARSE_KEYWORDS (Fmismatch, nargs, args, 8,
+ (test, key, from_end, start1, end1, start2, end2, test_not),
+ (start1 = start2 = Qzero));
+
+ CHECK_SEQUENCE (sequence1);
+ CHECK_SEQUENCE (sequence2);
+
+ CHECK_NATNUM (start1);
+ CHECK_NATNUM (start2);
+
+ if (!NILP (end1))
+ {
+ CHECK_NATNUM (end1);
+ }
+
+ if (!NILP (end2))
+ {
+ CHECK_NATNUM (end2);
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, NULL);
+ mismatch = get_mismatch_func (sequence1, sequence2, from_end,
+ &return_first_index);
+
+ if (return_first_index)
+ {
+ return mismatch (sequence1, start1, end1, sequence2, start2, end2,
+ check_match, test_not_unboundp, test, key, 1);
+ }
+
+ return mismatch (sequence2, start2, end2, sequence1, start1, end1,
+ check_match, test_not_unboundp, test, key, 0);
+}
+
+DEFUN ("search", Fsearch, 2, MANY, 0, /*
+Search for SEQUENCE1 as a subsequence of SEQUENCE2.
+
+Return the index of the leftmost element of the first match found; return
+nil if there are no matches.
+
+In this function, :start1 and :end1 specify a subsequence of SEQUENCE1, and
+:start2 and :end2 specify a subsequence of SEQUENCE2. See `remove*' for
+details of the other keywords.
+
+arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence1 = args[0], sequence2 = args[1], position0 = Qnil;
+ Boolint test_not_unboundp = 1, return_first = 0;
+ check_test_func_t check_test = NULL, check_match = NULL;
+ mismatch_func_t mismatch = NULL;
+ Elemcount starting1 = 0, ending1 = 1 + EMACS_INT_MAX, starting2 = 0;
+ Elemcount ending2 = 1 + EMACS_INT_MAX, ii = 0;
+ Elemcount length1;
+ Lisp_Object object = Qnil;
+ struct gcpro gcpro1, gcpro2;
+
+ PARSE_KEYWORDS (Fsearch, nargs, args, 8,
+ (test, key, from_end, start1, end1, start2, end2, test_not),
+ (start1 = start2 = Qzero));
+
+ CHECK_SEQUENCE (sequence1);
+ CHECK_SEQUENCE (sequence2);
+ CHECK_KEY_ARGUMENT (key);
+
+ CHECK_NATNUM (start1);
+ starting1 = INTP (start1) ? XINT (start1) : 1 + EMACS_INT_MAX;
+ CHECK_NATNUM (start2);
+ starting2 = INTP (start2) ? XINT (start2) : 1 + EMACS_INT_MAX;
+
+ if (!NILP (end1))
+ {
+ Lisp_Object len1 = Flength (sequence1);
+
+ CHECK_NATNUM (end1);
+ check_sequence_range (sequence1, start1, end1, len1);
+ ending1 = min (XINT (end1), XINT (len1));
+ }
+ else
+ {
+ end1 = Flength (sequence1);
+ check_sequence_range (sequence1, start1, end1, end1);
+ ending1 = XINT (end1);
+ }
+
+ length1 = ending1 - starting1;
+
+ if (!NILP (end2))
+ {
+ Lisp_Object len2 = Flength (sequence2);
+
+ CHECK_NATNUM (end2);
+ check_sequence_range (sequence2, start2, end2, len2);
+ ending2 = min (XINT (end2), XINT (len2));
+ }
+ else
+ {
+ end2 = Flength (sequence2);
+ check_sequence_range (sequence2, start2, end2, end2);
+ ending2 = XINT (end2);
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+ mismatch = get_mismatch_func (sequence1, sequence2, from_end, &return_first);
+
+ if (bytecode_arithcompare (start1, make_integer (ending1)) >= 0)
+ {
+ if (NILP (from_end))
+ {
+ return start2;
+ }
+
+ if (NILP (end2))
+ {
+ return Flength (sequence2);
+ }
+
+ return end2;
+ }
+
+ if (NILP (from_end))
+ {
+ Lisp_Object mismatch_start1 = Fadd1 (start1);
+ Lisp_Object first = KEY (key, Felt (sequence1, start1));
+ GCPRO2 (first, mismatch_start1);
+
+ ii = starting2;
+ while (ii < ending2)
+ {
+ position0 = position (&object, first, sequence2, check_test,
+ test_not_unboundp, test, key, make_int (ii),
+ end2, Qnil, Qnil, Qsearch);
+ if (NILP (position0))
+ {
+ UNGCPRO;
+ return Qnil;
+ }
+
+ if (length1 + XINT (position0) <= ending2 &&
+ (return_first ?
+ NILP (mismatch (sequence1, mismatch_start1, end1,
+ sequence2,
+ make_int (1 + XINT (position0)),
+ make_int (length1 + XINT (position0)),
+ check_match, test_not_unboundp, test, key, 1)) :
+ NILP (mismatch (sequence2,
+ make_int (1 + XINT (position0)),
+ make_int (length1 + XINT (position0)),
+ sequence1, mismatch_start1, end1,
+ check_match, test_not_unboundp, test, key, 0))))
+
+
+ {
+ UNGCPRO;
+ return position0;
+ }
+
+ ii = XINT (position0) + 1;
+ }
+
+ UNGCPRO;
+ }
+ else
+ {
+ Lisp_Object mismatch_end1 = make_integer (ending1 - 1);
+ Lisp_Object last = KEY (key, Felt (sequence1, mismatch_end1));
+ GCPRO2 (last, mismatch_end1);
+
+ ii = ending2;
+ while (ii > starting2)
+ {
+ position0 = position (&object, last, sequence2, check_test,
+ test_not_unboundp, test, key, start2,
+ make_int (ii), Qt, Qnil, Qsearch);
+
+ if (NILP (position0))
+ {
+ UNGCPRO;
+ return Qnil;
+ }
+
+ if (XINT (position0) - length1 + 1 >= starting2 &&
+ (return_first ?
+ NILP (mismatch (sequence1, start1, mismatch_end1,
+ sequence2,
+ make_int (XINT (position0) - length1 + 1),
+ make_int (XINT (position0)),
+ check_match, test_not_unboundp, test, key, 1)) :
+ NILP (mismatch (sequence2,
+ make_int (XINT (position0) - length1 + 1),
+ make_int (XINT (position0)),
+ sequence1, start1, mismatch_end1,
+ check_match, test_not_unboundp, test, key, 0))))
+ {
+ UNGCPRO;
+ return make_int (XINT (position0) - length1 + 1);
+ }
+
+ ii = XINT (position0);
+ }
+
+ UNGCPRO;
+ }
+
+ return Qnil;
+}
+
+/* These two functions do set operations, those that can be visualised with
+ Venn diagrams. */
+static Lisp_Object
+venn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp)
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil;
+ Lisp_Object result = EQ (caller, Qsubsetp) ? Qt : Qnil, result_tail = Qnil;
+ Lisp_Object keyed = Qnil, ignore = Qnil;
+ Elemcount len;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS_8 (caller, nargs, args, 4, (test, key, test_not, stable),
+ NULL, 2, 0);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt1) && intersectionp)
+ {
+ return Qnil;
+ }
+
+ if (NILP (liszt2))
+ {
+ return intersectionp ? Qnil : liszt1;
+ }
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, result);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len)
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil))
+ != intersectionp)
+ {
+ if (EQ (Qsubsetp, caller))
+ {
+ result = Qnil;
+ break;
+ }
+ else if (NILP (stable))
+ {
+ result = Fcons (elt, result);
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ }
+ }
+
+ UNGCPRO;
+
+ return result;
+}
+
+static Lisp_Object
+nvenn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp)
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], tortoise_elt, ignore = Qnil;
+ Lisp_Object elt = Qnil, tail = Qnil, keyed = Qnil, prev_tail = Qnil;
+ Elemcount count;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS_8 (caller, nargs, args, 3, (test, key, test_not),
+ NULL, 2, 0);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt1) && intersectionp)
+ {
+ return Qnil;
+ }
+
+ if (NILP (liszt2))
+ {
+ return intersectionp ? Qnil : liszt1;
+ }
+
+ get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, liszt1);
+
+ tortoise_elt = tail = liszt1, count = 0;
+
+ while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
+ (signal_malformed_list_error (liszt1), 0))
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil))
+ == intersectionp)
+ {
+ if (NILP (prev_tail))
+ {
+ liszt1 = XCDR (tail);
+ }
+ else
+ {
+ XSETCDR (prev_tail, XCDR (tail));
+ }
+
+ tail = XCDR (tail);
+ /* List is definitely not circular now! */
+ count = 0;
+ }
+ else
+ {
+ prev_tail = tail;
+ tail = XCDR (tail);
+ }
+
+ if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ {
+ tortoise_elt = XCDR (tortoise_elt);
+ }
+
+ if (EQ (elt, tortoise_elt))
+ {
+ signal_circular_list_error (liszt1);
+ }
+ }
+
+ UNGCPRO;
+
+ return liszt1;
+}
+
+DEFUN ("intersection", Fintersection, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-intersection operation.
+
+The result list contains all items that appear in both LIST1 and LIST2.
+This is a non-destructive function; it makes a copy of the data if necessary
+to avoid corrupting the original LIST1 and LIST2.
+
+A non-nil value for the :stable keyword, not specified by Common Lisp, means
+return the items in the order they appear in LIST1.
+
+See `union' for the meaning of :test, :test-not and :key."
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return venn (Qintersection, nargs, args, 1);
+}
+
+DEFUN ("nintersection", Fnintersection, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-intersection operation.
+
+The result list contains all items that appear in both LIST1 and LIST2.
+This is a destructive function; it reuses the storage of LIST1 whenever
+possible.
+
+See `union' for the meaning of :test, :test-not and :key."
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return nvenn (Qnintersection, nargs, args, 1);
+}
+
+DEFUN ("subsetp", Fsubsetp, 2, MANY, 0, /*
+Return non-nil if every element of LIST1 also appears in LIST2.
+
+See `union' for the meaning of the keyword arguments.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return venn (Qsubsetp, nargs, args, 0);
+}
+
+DEFUN ("set-difference", Fset_difference, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-difference operation.
+
+The result list contains all items that appear in LIST1 but not LIST2. This
+is a non-destructive function; it makes a copy of the data if necessary to
+avoid corrupting the original LIST1 and LIST2.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+A non-nil value for the :stable keyword, not specified by Common Lisp, means
+return the items in the order they appear in LIST1.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return venn (Qset_difference, nargs, args, 0);
+}
+
+DEFUN ("nset-difference", Fnset_difference, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-difference operation.
+
+The result list contains all items that appear in LIST1 but not LIST2. This
+is a destructive function; it reuses the storage of LIST1 whenever possible.
+
+See `union' for the meaning of :test, :test-not and :key."
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return nvenn (Qnset_difference, nargs, args, 0);
+}
+
+DEFUN ("nunion", Fnunion, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-union operation.
+The result list contains all items that appear in either LIST1 or LIST2.
+
+This is a destructive function, it reuses the storage of LIST1 whenever
+possible.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ args[0] = nvenn (Qnunion, nargs, args, 0);
+ return bytecode_nconc2 (args);
+}
+
+DEFUN ("union", Funion, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-union operation.
+The result list contains all items that appear in either LIST1 or LIST2.
+This is a non-destructive function; it makes a copy of the data if necessary
+to avoid corrupting the original LIST1 and LIST2.
+
+The keywords :test and :test-not specify two-argument test and negated-test
+predicates, respectively; :test defaults to `eql'. See `member*' for more
+information.
+
+:key specifies a one-argument function that transforms elements of LIST1
+and LIST2 into \"comparison keys\" before the test predicate is applied.
+For example, if :key is #'car, then the car of elements from LIST1 is
+compared with the car of elements from LIST2. The :key function, however,
+does not affect the elements in the returned list, which are taken directly
+from the elements in LIST1 and LIST2.
+
+A non-nil value for the :stable keyword, not specified by Common Lisp, means
+return the items of LIST1 in order, followed by the remaining items of LIST2
+in the order they occur in LIST2.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], ignore = Qnil;
+ Lisp_Object elt = Qnil, tail = Qnil, keyed = Qnil, result, result_tail;
+ Elemcount len;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL, check_match = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS (Funion, nargs, args, 4, (test, key, test_not, stable), NULL);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt1))
+ {
+ return liszt2;
+ }
+
+ if (NILP (liszt2))
+ {
+ return liszt1;
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, result);
+
+ if (NILP (stable))
+ {
+ result = liszt2;
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len)
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil)))
+ {
+ /* The Lisp version of #'union used to check which list was
+ longer, and use that as the tail of the constructed
+ list. That fails when the order of arguments to TEST is
+ specified, as is the case for these functions. We could
+ pass the reverse_check argument to
+ list_position_cons_before, but that means any key argument
+ is called an awful lot more, so it's a space win but not
+ a time win. */
+ result = Fcons (elt, result);
+ }
+ }
+ }
+ }
+ else
+ {
+ result = result_tail = Qnil;
+
+ /* The standard `union' doesn't produce a "stable" union -- it
+ iterates over the second list instead of the first one, and returns
+ the values in backwards order. According to the CLTL2
+ documentation, `union' is not required to preserve the ordering of
+ elements in any fashion; providing the functionality for a stable
+ union is an XEmacs extension. */
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt2, tail, len)
+ {
+ if (NILP (list_position_cons_before (&ignore, elt, liszt1,
+ check_match, test_not_unboundp,
+ test, key, 1, Qzero, Qnil)))
+ {
+ if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ }
+ }
+
+ result = NILP (result) ? liszt1 : nconc2 (Fcopy_list (liszt1), result);
+ }
+
+ UNGCPRO;
+
+ return result;
+}
+
+DEFUN ("set-exclusive-or", Fset_exclusive_or, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-exclusive-or operation.
+
+The result list contains all items that appear in exactly one of LIST1, LIST2.
+This is a non-destructive function; it makes a copy of the data if necessary
+to avoid corrupting the original LIST1 and LIST2.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+A non-nil value for the :stable keyword, not specified by Common Lisp, means
+return the items in the order they appear in LIST1, followed by the
+remaining items in the order they appear in LIST2.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil;
+ Lisp_Object result = Qnil, result_tail = Qnil, keyed = Qnil, ignore = Qnil;
+ Elemcount len;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_match = NULL, check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS (Fset_exclusive_or, nargs, args, 4,
+ (test, key, test_not, stable), NULL);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt2))
+ {
+ return liszt1;
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, result);
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt1, tail, len)
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil)))
+ {
+ if (NILP (stable))
+ {
+ result = Fcons (elt, result);
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ }
+ }
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, liszt2, tail, len)
+ {
+ if (NILP (list_position_cons_before (&ignore, elt, liszt1,
+ check_match, test_not_unboundp,
+ test, key, 1, Qzero, Qnil)))
+ {
+ if (NILP (stable))
+ {
+ result = Fcons (elt, result);
+ }
+ else if (NILP (result))
+ {
+ result = result_tail = Fcons (elt, Qnil);
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (elt, Qnil));
+ result_tail = XCDR (result_tail);
+ }
+ }
+ }
+ }
+ UNGCPRO;
+
+ return result;
+}
+
+DEFUN ("nset-exclusive-or", Fnset_exclusive_or, 2, MANY, 0, /*
+Combine LIST1 and LIST2 using a set-exclusive-or operation.
+
+The result list contains all items that appear in exactly one of LIST1 and
+LIST2. This is a destructive function; it reuses the storage of LIST1 and
+LIST2 whenever possible.
+
+See `union' for the meaning of :test, :test-not and :key.
+
+arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil;
+ Lisp_Object result = Qnil, tortoise_elt = Qnil, keyed = Qnil, swap;
+ Lisp_Object prev_tail = Qnil, ignore = Qnil;
+ Elemcount count;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_match = NULL, check_test = NULL;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ PARSE_KEYWORDS (Fnset_exclusive_or, nargs, args, 4,
+ (test, key, test_not, stable), NULL);
+
+ CHECK_LIST (liszt1);
+ CHECK_LIST (liszt2);
+
+ CHECK_KEY_ARGUMENT (key);
+
+ if (NILP (liszt2))
+ {
+ return liszt1;
+ }
+
+ check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
+ &test_not_unboundp, &check_test);
+
+ GCPRO3 (tail, keyed, result);
+
+ tortoise_elt = tail = liszt1, count = 0;
+
+ while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
+ (signal_malformed_list_error (liszt1), 0))
+ {
+ keyed = KEY (key, elt);
+ if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
+ check_test, test_not_unboundp,
+ test, key, 0, Qzero, Qnil)))
+ {
+ swap = XCDR (tail);
+
+ if (NILP (prev_tail))
+ {
+ liszt1 = XCDR (tail);
+ }
+ else
+ {
+ XSETCDR (prev_tail, swap);
+ }
+
+ XSETCDR (tail, result);
+ result = tail;
+ tail = swap;
+
+ /* List is definitely not circular now! */
+ count = 0;
+ }
+ else
+ {
+ prev_tail = tail;
+ tail = XCDR (tail);
+ }
+
+ if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ {
+ tortoise_elt = XCDR (tortoise_elt);
+ }
+
+ if (EQ (elt, tortoise_elt))
+ {
+ signal_circular_list_error (liszt1);
+ }
+ }
+
+ tortoise_elt = tail = liszt2, count = 0;
+
+ while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
+ (signal_malformed_list_error (liszt2), 0))
+ {
+ /* Need to leave the key calculation to list_position_cons_before(). */
+ if (NILP (list_position_cons_before (&ignore, elt, liszt1,
+ check_match, test_not_unboundp,
+ test, key, 1, Qzero, Qnil)))
+ {
+ swap = XCDR (tail);
+ XSETCDR (tail, result);
+ result = tail;
+ tail = swap;
+ count = 0;
+ }
+ else
+ {
+ tail = XCDR (tail);
+ }
+
+ if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ {
+ tortoise_elt = XCDR (tortoise_elt);
+ }
+
+ if (EQ (elt, tortoise_elt))
+ {
+ signal_circular_list_error (liszt1);
+ }
+ }
+
+ UNGCPRO;
+
+ return result;
+}
+
+
Lisp_Object
add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string)
{
＠＠ -6203,7 +11067,6 ＠＠
Fsymbol_name (symbol)),
Qnil);
}
-
/* #### this function doesn't belong in this file! */
＠＠ -6821,7 +11684,6 ＠＠
INIT_LISP_OBJECT (bit_vector);
DEFSYMBOL (Qstring_lessp);
- DEFSYMBOL (Qsort);
DEFSYMBOL (Qmerge);
DEFSYMBOL (Qfill);
DEFSYMBOL (Qidentity);
＠＠ -6833,6 +11695,10 ＠＠
defsymbol (&QsortX, "sort*");
DEFSYMBOL (Qreduce);
DEFSYMBOL (Qreplace);
+ DEFSYMBOL (Qposition);
+ DEFSYMBOL (Qfind);
+ defsymbol (&QdeleteX, "delete*");
+ defsymbol (&QremoveX, "remove*");
DEFSYMBOL (Qmapconcat);
defsymbol (&QmapcarX, "mapcar*");
＠＠ -6846,6 +11712,19 ＠＠
DEFSYMBOL (Qmaplist);
DEFSYMBOL (Qmapl);
DEFSYMBOL (Qmapcon);
+ DEFSYMBOL (Qnsubstitute);
+ DEFSYMBOL (Qdelete_duplicates);
+ DEFSYMBOL (Qsubstitute);
+ DEFSYMBOL (Qmismatch);
+ DEFSYMBOL (Qintersection);
+ DEFSYMBOL (Qnintersection);
+ DEFSYMBOL (Qsubsetp);
+ DEFSYMBOL (Qset_difference);
+ DEFSYMBOL (Qnset_difference);
+ DEFSYMBOL (Qnunion);
+ DEFSYMBOL (Qnintersection);
+ DEFSYMBOL (Qset_difference);
+ DEFSYMBOL (Qnset_difference);
DEFKEYWORD (Q_from_end);
DEFKEYWORD (Q_initial_value);
＠＠ -6853,6 +11732,11 ＠＠
DEFKEYWORD (Q_start2);
DEFKEYWORD (Q_end1);
DEFKEYWORD (Q_end2);
+ defkeyword (&Q_if_, ":if");
+ DEFKEYWORD (Q_if_not);
+ DEFKEYWORD (Q_test_not);
+ DEFKEYWORD (Q_count);
+ DEFKEYWORD (Q_stable);
DEFSYMBOL (Qyes_or_no_p);
＠＠ -6863,6 +11747,7 ＠＠
DEFSUBR (Flength);
DEFSUBR (Fsafe_length);
DEFSUBR (Flist_length);
+ DEFSUBR (Fcount);
DEFSUBR (Fstring_equal);
DEFSUBR (Fcompare_strings);
DEFSUBR (Fstring_lessp);
＠＠ -6886,6 +11771,8 ＠＠
DEFSUBR (Fold_member);
DEFSUBR (Fmemq);
DEFSUBR (Fold_memq);
+ DEFSUBR (FmemberX);
+ DEFSUBR (Fadjoin);
DEFSUBR (Fassoc);
DEFSUBR (Fold_assoc);
DEFSUBR (Fassq);
＠＠ -6894,18 +11781,25 ＠＠
DEFSUBR (Fold_rassoc);
DEFSUBR (Frassq);
DEFSUBR (Fold_rassq);
+
+ DEFSUBR (Fposition);
+ DEFSUBR (Ffind);
+
DEFSUBR (Fdelete);
DEFSUBR (Fold_delete);
DEFSUBR (Fdelq);
DEFSUBR (Fold_delq);
+ DEFSUBR (FdeleteX);
+ DEFSUBR (FremoveX);
DEFSUBR (Fremassoc);
DEFSUBR (Fremassq);
DEFSUBR (Fremrassoc);
DEFSUBR (Fremrassq);
+ DEFSUBR (Fdelete_duplicates);
+ DEFSUBR (Fremove_duplicates);
DEFSUBR (Fnreverse);
DEFSUBR (Freverse);
DEFSUBR (FsortX);
- Ffset (intern ("sort"), QsortX);
DEFSUBR (Fmerge);
DEFSUBR (Fplists_eq);
DEFSUBR (Fplists_equal);
＠＠ -6933,7 +11827,9 ＠＠
DEFSUBR (Fequalp);
DEFSUBR (Fold_equal);
DEFSUBR (Ffill);
- Ffset (intern ("fillarray"), Qfill);
+
+ DEFSUBR (FassocX);
+ DEFSUBR (FrassocX);
DEFSUBR (Fnconc);
DEFSUBR (FmapcarX);
＠＠ -6945,8 +11841,8 ＠＠
DEFSUBR (Fmap_into);
DEFSUBR (Fsome);
DEFSUBR (Fevery);
- Ffset (intern ("mapc-internal"), Fsymbol_function (intern ("mapc")));
- Ffset (intern ("mapcar"), Fsymbol_function (intern ("mapcar*")));
+ Ffset (intern ("mapc-internal"), Qmapc);
+ Ffset (intern ("mapcar"), QmapcarX);
DEFSUBR (Fmaplist);
DEFSUBR (Fmapl);
DEFSUBR (Fmapcon);
＠＠ -6954,6 +11850,25 ＠＠
DEFSUBR (Freduce);
DEFSUBR (Freplace_list);
DEFSUBR (Freplace);
+ DEFSUBR (Fsubsetp);
+ DEFSUBR (Fnsubstitute);
+ DEFSUBR (Fsubstitute);
+ DEFSUBR (Fsublis);
+ DEFSUBR (Fnsublis);
+ DEFSUBR (Fsubst);
+ DEFSUBR (Fnsubst);
+ DEFSUBR (Ftree_equal);
+ DEFSUBR (Fmismatch);
+ DEFSUBR (Fsearch);
+ DEFSUBR (Funion);
+ DEFSUBR (Fnunion);
+ DEFSUBR (Fintersection);
+ DEFSUBR (Fnintersection);
+ DEFSUBR (Fset_difference);
+ DEFSUBR (Fnset_difference);
+ DEFSUBR (Fset_exclusive_or);
+ DEFSUBR (Fnset_exclusive_or);
+
DEFSUBR (Fload_average);
DEFSUBR (Ffeaturep);
DEFSUBR (Frequire);
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [PATCH] Move the heavy lifting from cl-seq.el to C.
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
Ar an t-aonú lá is triochad de mí na Nollaig, scríobh Stephen J. Turnbull:
> Aidan Kehoe writes:
>
> > build. There may still be incompatibilities, and I will be watching the
> > buildbots once I commit it.
>
> Windows builds (Cygwin and native)?
Nope, not yet; as I said, though, I don’t get warnings about statements
interleaving with declarations, which has been the main issue with the
Windows builds recently.
> Benchmarks? Is there a perceptible speedup?
Remember that the code we inherit from GNU never uses the CL functions, and
that they’ve not been in C in XEmacs up to now, so the XEmacs-specific code
doesn’t use them much either, there’s not much opportunity for a speedup. I
*think* I saw a speedup with one specific change to the #'member* compiler
macro that meant most of the time the member bytecode was used in
#'add-to-list, but that’s gone in already.
With a few very rough-and-ready benchmarks, I see a twenty-fold speedup in
#'delete-duplicates and #'remove-duplicates. The other functions won’t be as
dramatic.
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Use defmacro* when defining dolist, dotimes, do-symbols, macrolet, cl-macs.el
13 years, 3 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1293926774 0
# Node ID 60ba780f9078f5fcd9529fcec6389fded2f9a1fc
# Parent 47298dcf2e8f5c682b0de506fe079c93d9e639d1
Use defmacro* when defining dolist, dotimes, do-symbols, macrolet, cl-macs.el
2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
diff -r 47298dcf2e8f -r 60ba780f9078 lisp/ChangeLog
--- a/lisp/ChangeLog Sat Jan 01 20:08:44 2011 +0000
+++ b/lisp/ChangeLog Sun Jan 02 00:06:14 2011 +0000
＠＠ -1,3 +1,12 ＠＠
+2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (dolist, dotimes, do-symbols, macrolet)
+ (symbol-macrolet):
+ Define these macros with defmacro* instead of parsing the argument
+ list by hand, for the sake of style and readability; use backquote
+ where appropriate, instead of calling #'list and and friends, for
+ the same reason.
+
2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* x-misc.el (device-x-display):
diff -r 47298dcf2e8f -r 60ba780f9078 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sat Jan 01 20:08:44 2011 +0000
+++ b/lisp/cl-macs.el Sun Jan 02 00:06:14 2011 +0000
＠＠ -1679,51 +1679,42 ＠＠
(or (cdr endtest) '(nil)))))
;;;###autoload
-(defmacro dolist (spec &rest body)
+(defmacro* dolist ((var list &optional result) &body body)
"Loop over a list.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
-Then evaluate RESULT to get return value, default nil.
-
-arguments: ((VAR LIST &optional RESULT) &body BODY)"
- (let ((temp (gensym "--dolist-temp--")))
- (list 'block nil
- (list* 'let (list (list temp (nth 1 spec)) (car spec))
- (list* 'while temp (list 'setq (car spec) (list 'car temp))
- (append body (list (list 'setq temp
- (list 'cdr temp)))))
- (if (cdr (cdr spec))
- (cons (list 'setq (car spec) nil) (cdr (cdr spec)))
- '(nil))))))
+Then evaluate RESULT to get return value, default nil."
+ (let ((gensym (gensym)))
+ `(block nil
+ (let ((,gensym ,list) ,var)
+ (while ,gensym
+ (setq ,var (car ,gensym))
+ ,＠body
+ (setq ,gensym (cdr ,gensym)))
+ ,＠(if result `((setq ,var nil) ,result))))))
;;;###autoload
-(defmacro dotimes (spec &rest body)
+(defmacro* dotimes ((var count &optional result) &body body)
"Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers from 0, inclusive,
to COUNT, exclusive. Then evaluate RESULT to get return value, default
-nil.
-
-arguments: ((VAR COUNT &optional RESULT) &body BODY)"
- (let ((temp (gensym "--dotimes-temp--")))
- (list 'block nil
- (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
- (list* 'while (list '< (car spec) temp)
- (append body (list (list 'incf (car spec)))))
- (or (cdr (cdr spec)) '(nil))))))
+nil."
+ (let* ((limit (if (cl-const-expr-p count) count (gensym)))
+ (bind (if (cl-const-expr-p count) nil `((,limit ,count)))))
+ `(block nil
+ (let ((,var 0) ,＠bind)
+ (while (< ,var ,limit)
+ ,＠body
+ (setq ,var (1+ ,var)))
+ ,＠(if result (list result))))))
;;;###autoload
-(defmacro do-symbols (spec &rest body)
- "Loop over all symbols.
+(defmacro* do-symbols ((var &optional obarray result) &rest body)
+ "Loop over all interned symbols.
Evaluate BODY with VAR bound to each interned symbol, or to each symbol
-from OBARRAY.
-
-arguments: ((VAR &optional OBARRAY RESULT) &body BODY)"
- ;; Apparently this doesn't have an implicit block.
- (list 'block nil
- (list 'let (list (car spec))
- (list* 'mapatoms
- (list 'function (list* 'lambda (list (car spec)) body))
- (and (cadr spec) (list (cadr spec))))
- (caddr spec))))
+from OBARRAY."
+ `(block nil
+ (mapatoms #'(lambda (,var) ,＠body) ,＠(and obarray (list obarray)))
+ ,＠(if result `((let (,var) ,result)))))
;;;###autoload
(defmacro do-all-symbols (spec &rest body)
＠＠ -1806,37 +1797,34 ＠＠
;; The following ought to have a better definition for use with newer
;; byte compilers.
;;;###autoload
-(defmacro macrolet (bindings &rest body)
+(defmacro* macrolet (((name arglist &optional docstring &body body)
+ &rest macros) &body form)
"Make temporary macro definitions.
-This is like `flet', but for macros instead of functions.
-
-arguments: (((NAME ARGLIST &optional DOCSTRING &body body) &rest MACROS) &body FORM)"
- (if (cdr bindings)
- (list 'macrolet
- (list (car bindings)) (list* 'macrolet (cdr bindings) body))
- (if (null bindings) (cons 'progn body)
- (let* ((name (caar bindings))
- (res (cl-transform-lambda (cdar bindings) name)))
- (eval (car res))
- (cl-macroexpand-all (cons 'progn body)
- (cons (list* name 'lambda (cdr res))
- cl-macro-environment))))))
+This is like `flet', but for macros instead of functions."
+ (cl-macroexpand-all (cons 'progn form)
+ (nconc
+ (loop
+ for (name . details)
+ in (cons (list* name arglist docstring body) macros)
+ collect
+ (list* name 'lambda
+ (prog1
+ (cdr (setq details (cl-transform-lambda
+ details name)))
+ (eval (car details)))))
+ cl-macro-environment)))
;;;###autoload
-(defmacro symbol-macrolet (bindings &rest body)
+(defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form)
"Make symbol macro definitions.
Within the body FORMs, references to the variable NAME will be replaced
-by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
-
-arguments: (((NAME EXPANSION) &rest SYMBOL-MACROS) &body FORM)"
- (if (cdr bindings)
- (list 'symbol-macrolet
- (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
- (if (null bindings) (cons 'progn body)
- (cl-macroexpand-all (cons 'progn body)
- (cons (list (symbol-name (caar bindings))
- (cadar bindings))
- cl-macro-environment)))))
+by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)."
+ (cl-macroexpand-all (cons 'progn form)
+ (append (list (list (symbol-name name) expansion))
+ (loop
+ for (name expansion) in symbol-macros
+ collect (list (symbol-name name) expansion))
+ cl-macro-environment)))
(defvar cl-closure-vars nil)
;;;###autoload
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments