annotate lisp/cl-seq.el @ 826:6728e641994e

[xemacs-hg @ 2002-05-05 11:30:15 by ben] syntax cache, 8-bit-format, lots of code cleanup README.packages: Update info about --package-path. i.c: Create an inheritable event and pass it on to XEmacs, so that ^C can be handled properly. Intercept ^C and signal the event. "Stop Build" in VC++ now works. bytecomp-runtime.el: Doc string changes. compat.el: Some attempts to redo this to make it truly useful and fix the "multiple versions interacting with each other" problem. Not yet done. Currently doesn't work. files.el: Use with-obsolete-variable to avoid warnings in new revert-buffer code. xemacs.mak: Split up CFLAGS into a version without flags specifying the C library. The problem seems to be that minitar depends on zlib, which depends specifically on libc.lib, not on any of the other C libraries. Unless you compile with libc.lib, you get errors -- specifically, no _errno in the other libraries, which must make it something other than an int. (#### But this doesn't seem to obtain in XEmacs, which also uses zlib, and can be linked with any of the C libraries. Maybe zlib is used differently and doesn't need errno, or maybe XEmacs provides an int errno; ... I don't understand. Makefile.in.in: Fix so that packages are around when testing. abbrev.c, alloc.c, buffer.c, buffer.h, bytecode.c, callint.c, casefiddle.c, casetab.c, casetab.h, charset.h, chartab.c, chartab.h, cmds.c, console-msw.h, console-stream.c, console-x.c, console.c, console.h, data.c, device-msw.c, device.c, device.h, dialog-msw.c, dialog-x.c, dired-msw.c, dired.c, doc.c, doprnt.c, dumper.c, editfns.c, elhash.c, emacs.c, eval.c, event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, events.c, events.h, extents.c, extents.h, faces.c, file-coding.c, file-coding.h, fileio.c, fns.c, font-lock.c, frame-gtk.c, frame-msw.c, frame-x.c, frame.c, frame.h, glade.c, glyphs-gtk.c, glyphs-msw.c, glyphs-msw.h, glyphs-x.c, glyphs.c, glyphs.h, gui-msw.c, gui-x.c, gui.h, gutter.h, hash.h, indent.c, insdel.c, intl-win32.c, intl.c, keymap.c, lisp-disunion.h, lisp-union.h, lisp.h, lread.c, lrecord.h, lstream.c, lstream.h, marker.c, menubar-gtk.c, menubar-msw.c, menubar-x.c, menubar.c, minibuf.c, mule-ccl.c, mule-charset.c, mule-coding.c, mule-wnnfns.c, nas.c, objects-msw.c, objects-x.c, opaque.c, postgresql.c, print.c, process-nt.c, process-unix.c, process.c, process.h, profile.c, rangetab.c, redisplay-gtk.c, redisplay-msw.c, redisplay-output.c, redisplay-x.c, redisplay.c, redisplay.h, regex.c, regex.h, scrollbar-msw.c, search.c, select-x.c, specifier.c, specifier.h, symbols.c, symsinit.h, syntax.c, syntax.h, syswindows.h, tests.c, text.c, text.h, tooltalk.c, ui-byhand.c, ui-gtk.c, unicode.c, win32.c, window.c: Another big Ben patch. -- FUNCTIONALITY CHANGES: add partial support for 8-bit-fixed, 16-bit-fixed, and 32-bit-fixed formats. not quite done yet. (in particular, needs functions to actually convert the buffer.) NOTE: lots of changes to regex.c here. also, many new *_fmt() inline funs that take an Internal_Format argument. redo syntax cache code. make the cache per-buffer; keep the cache valid across calls to functions that use it. also keep it valid across insertions/deletions and extent changes, as much as is possible. eliminate the junky regex-reentrancy code by passing in the relevant lisp info to the regex routines as local vars. add general mechanism in extents code for signalling extent changes. fix numerous problems with the case-table implementation; yoshiki never properly transferred many algorithms from old-style to new-style case tables. redo char tables to support a default argument, so that mapping only occurs over changed args. change many chartab functions to accept Lisp_Object instead of Lisp_Char_Table *. comment out the code in font-lock.c by default, because font-lock.el no longer uses it. we should consider eliminating it entirely. Don't output bell as ^G in console-stream when not a TTY. add -mswindows-termination-handle to interface with i.c, so we can properly kill a build. add more error-checking to buffer/string macros. add some additional buffer_or_string_() funs. -- INTERFACE CHANGES AFFECTING MORE CODE: switch the arguments of write_c_string and friends to be consistent with write_fmt_string, which must have printcharfun first. change BI_* macros to BYTE_* for increased clarity; similarly for bi_* local vars. change VOID_TO_LISP to be a one-argument function. eliminate no-longer-needed CVOID_TO_LISP. -- char/string macro changes: rename MAKE_CHAR() to make_emchar() for slightly less confusion with make_char(). (The former generates an Emchar, the latter a Lisp object. Conceivably we should rename make_char() -> wrap_char() and similarly for make_int(), make_float().) Similar changes for other *CHAR* macros -- we now consistently use names with `emchar' whenever we are working with Emchars. Any remaining name with just `char' always refers to a Lisp object. rename macros with XSTRING_* to string_* except for those that reference actual fields in the Lisp_String object, following conventions used elsewhere. rename set_string_{data,length} macros (the only ones to work with a Lisp_String_* instead of a Lisp_Object) to set_lispstringp_* to make the difference clear. try to be consistent about caps vs. lowercase in macro/inline-fun names for chars and such, which wasn't the case before. we now reserve caps either for XFOO_ macros that reference object fields (e.g. XSTRING_DATA) or for things that have non-function semantics, e.g. directly modifying an arg (BREAKUP_EMCHAR) or evaluating an arg (any arg) more than once. otherwise, use lowercase. here is a summary of most of the macros/inline funs changed by all of the above changes: BYTE_*_P -> byte_*_p XSTRING_BYTE -> string_byte set_string_data/length -> set_lispstringp_data/length XSTRING_CHAR_LENGTH -> string_char_length XSTRING_CHAR -> string_emchar INTBYTE_FIRST_BYTE_P -> intbyte_first_byte_p INTBYTE_LEADING_BYTE_P -> intbyte_leading_byte_p charptr_copy_char -> charptr_copy_emchar LEADING_BYTE_* -> leading_byte_* CHAR_* -> EMCHAR_* *_CHAR_* -> *_EMCHAR_* *_CHAR -> *_EMCHAR CHARSET_BY_ -> charset_by_* BYTE_SHIFT_JIS* -> byte_shift_jis* BYTE_BIG5* -> byte_big5* REP_BYTES_BY_FIRST_BYTE -> rep_bytes_by_first_byte char_to_unicode -> emchar_to_unicode valid_char_p -> valid_emchar_p Change intbyte_strcmp -> qxestrcmp_c (duplicated functionality). -- INTERFACE CHANGES AFFECTING LESS CODE: use DECLARE_INLINE_HEADER in various places. remove '#ifdef emacs' from XEmacs-only files. eliminate CHAR_TABLE_VALUE(), which duplicated the functionality of get_char_table(). add BUFFER_TEXT_LOOP to simplify iterations over buffer text. define typedefs for signed and unsigned types of fixed sizes (INT_32_BIT, UINT_32_BIT, etc.). create ALIGN_FOR_TYPE as a higher-level interface onto ALIGN_SIZE; fix code to use it. add charptr_emchar_len to return the text length of the character pointed to by a ptr; use it in place of charcount_to_bytecount(..., 1). add emchar_len to return the text length of a given character. add types Bytexpos and Charxpos to generalize Bytebpos/Bytecount and Charbpos/Charcount, in code (particularly, the extents code and redisplay code) that works with either kind of index. rename redisplay struct params with names such as `charbpos' to e.g. `charpos' when they are e.g. a Charxpos, not a Charbpos. eliminate xxDEFUN in place of DEFUN; no longer necessary with changes awhile back to doc.c. split up big ugly combined list of EXFUNs in lisp.h on a file-by-file basis, since other prototypes are similarly split. rewrite some "*_UNSAFE" macros as inline funs and eliminate the _UNSAFE suffix. move most string code from lisp.h to text.h; the string code and text.h code is now intertwined in such a fashion that they need to be in the same place and partially interleaved. (you can't create forward references for inline funs) automated/lisp-tests.el, automated/symbol-tests.el, automated/test-harness.el: Fix test harness to output FAIL messages to stderr when in batch mode. Fix up some problems in lisp-tests/symbol-tests that were causing spurious failures.
author ben
date Sun, 05 May 2002 11:33:57 +0000
parents 023b83f4e54b
children 393039450288
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
613
023b83f4e54b [xemacs-hg @ 2001-06-10 10:42:16 by ben]
ben
parents: 442
diff changeset
1 ;;; cl-seq.el --- Common Lisp extensions for XEmacs Lisp (part three)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 ;; Copyright (C) 1993 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5 ;; Author: Dave Gillespie <daveg@synaptics.com>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Version: 2.02
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 ;; Keywords: extensions, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; along with XEmacs; see the file COPYING. If not, write to the Free
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 ;; 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27 ;;; Synched up with: FSF 19.34.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 ;; This file is dumped with XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 ;; These are extensions to Emacs Lisp that provide a degree of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 ;; Common Lisp compatibility, beyond what is already built-in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 ;; in Emacs Lisp.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 ;; This package was written by Dave Gillespie; it is a complete
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 ;; Bug reports, comments, and suggestions are welcome!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 ;; This file contains the Common Lisp sequence and list functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 ;; which take keyword arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 ;; See cl.el for Change Log.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 ;;; Code:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 (or (memq 'cl-19 features)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 (error "Tried to load `cl-seq' before `cl'!"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 ;;; We define these here so that this file can compile without having
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 ;;; loaded the cl.el file already.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 (defmacro cl-pop (place)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 ;;; Keyword parsing. This is special-cased here so that we can compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 ;;; this file independent from cl-macs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 (defmacro cl-parsing-keywords (kwords other-keys &rest body)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
68 "Helper macro for functions with keyword arguments.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
69 This is a temporary solution, until keyword arguments are natively supported.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
70 Declare your function ending with (... &rest cl-keys), then wrap the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
71 function body in a call to `cl-parsing-keywords'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
72
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
73 KWORDS is a list of keyword definitions. Each definition should be
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
74 either a keyword or a list (KEYWORD DEFAULT-VALUE). In the former case,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
75 the default value is nil. The keywords are available in BODY as the name
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
76 of the keyword, minus its initial colon and prepended with `cl-'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
77
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
78 OTHER-KEYS specifies other keywords that are accepted but ignored. It
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
79 is either the value 't' (ignore all other keys, equivalent to the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
80 &allow-other-keys argument declaration in Common Lisp) or a list in the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
81 same format as KWORDS. If keywords are given that are not in KWORDS
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
82 and not allowed by OTHER-KEYS, an error will normally be signalled; but
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
83 the caller can override this by specifying a non-nil value for the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
84 keyword :allow-other-keys (which defaults to t)."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 (cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 'let*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 (cons (mapcar
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 (function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 (lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 (let* ((var (if (consp x) (car x) x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 (mem (list 'car (list 'cdr (list 'memq (list 'quote var)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 'cl-keys)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 (if (eq var ':test-not)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 (if (eq var ':if-not)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 (list (intern
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (format "cl-%s" (substring (symbol-name var) 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 (if (consp x) (list 'or mem (car (cdr x))) mem)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 kwords)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 (and (not (eq other-keys t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 (list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 (list 'let '((cl-keys-temp cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 (list 'while 'cl-keys-temp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 (list 'or (list 'memq '(car cl-keys-temp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 (list 'quote
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 (mapcar
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 (function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 (lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 (if (consp x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 (car x) x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 (append kwords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 other-keys))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 '(car (cdr (memq (quote :allow-other-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 cl-keys)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 '(error "Bad keyword argument %s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 (car cl-keys-temp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 body))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 (put 'cl-parsing-keywords 'lisp-indent-function 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 (defmacro cl-check-key (x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 (list 'if 'cl-key (list 'funcall 'cl-key x) x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 (defmacro cl-check-test-nokey (item x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (list 'cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 (list 'cl-test
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 (list 'eq (list 'not (list 'funcall 'cl-test item x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 'cl-test-not))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 (list 'cl-if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 (list 't (list 'if (list 'numberp item)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 (list 'equal item x) (list 'eq item x)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 (defmacro cl-check-test (item x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 (list 'cl-check-test-nokey item (list 'cl-check-key x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 (defmacro cl-check-match (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 (setq x (list 'cl-check-key x) y (list 'cl-check-key y))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 (list 'if 'cl-test
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 (list 'if (list 'numberp x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 (list 'equal x y) (list 'eq x y))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 (put 'cl-check-key 'edebug-form-spec 'edebug-forms)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 (put 'cl-check-test 'edebug-form-spec 'edebug-forms)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 (put 'cl-check-match 'edebug-form-spec 'edebug-forms)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 (defvar cl-test) (defvar cl-test-not)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 (defvar cl-if) (defvar cl-if-not)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 (defvar cl-key)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 (defun reduce (cl-func cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 "Reduce two-argument FUNCTION across SEQUENCE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 Keywords supported: :start :end :from-end :initial-value :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 (or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 (setq cl-seq (subseq cl-seq cl-start cl-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 (if cl-from-end (setq cl-seq (nreverse cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 (cl-seq (cl-check-key (cl-pop cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 (t (funcall cl-func)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 (if cl-from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 (while cl-seq
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 cl-accum)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 (while cl-seq
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 (setq cl-accum (funcall cl-func cl-accum
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 (cl-check-key (cl-pop cl-seq))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 cl-accum)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 (defun fill (seq item &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 "Fill the elements of SEQ with ITEM.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 Keywords supported: :start :end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 (cl-parsing-keywords ((:start 0) :end) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 (if (listp seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 (let ((p (nthcdr cl-start seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 (n (if cl-end (- cl-end cl-start) 8000000)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 (while (and p (>= (setq n (1- n)) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 (setcar p item)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 (setq p (cdr p))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 (or cl-end (setq cl-end (length seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 (if (and (= cl-start 0) (= cl-end (length seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 (fillarray seq item)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 (while (< cl-start cl-end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 (aset seq cl-start item)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 (setq cl-start (1+ cl-start)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 (defun replace (cl-seq1 cl-seq2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 "Replace the elements of SEQ1 with the elements of SEQ2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 SEQ1 is destructively modified, then returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 Keywords supported: :start1 :end1 :start2 :end2"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 (or (= cl-start1 cl-start2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 (let* ((cl-len (length cl-seq1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 (cl-n (min (- (or cl-end1 cl-len) cl-start1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 (- (or cl-end2 cl-len) cl-start2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 (while (>= (setq cl-n (1- cl-n)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 (cl-set-elt cl-seq1 (+ cl-start1 cl-n)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 (elt cl-seq2 (+ cl-start2 cl-n))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 (if (listp cl-seq1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 (if (listp cl-seq2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 (cl-n (min cl-n1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 (if cl-end2 (- cl-end2 cl-start2) 4000000))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 (setcar cl-p1 (car cl-p2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 (setq cl-end2 (min (or cl-end2 (length cl-seq2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 (+ cl-start2 cl-n1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 (while (and cl-p1 (< cl-start2 cl-end2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 (setcar cl-p1 (aref cl-seq2 cl-start2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 (setq cl-end1 (min (or cl-end1 (length cl-seq1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 (+ cl-start1 (- (or cl-end2 (length cl-seq2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 cl-start2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 (if (listp cl-seq2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 (while (< cl-start1 cl-end1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 (aset cl-seq1 cl-start1 (car cl-p2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 (while (< cl-start1 cl-end1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 cl-seq1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 (defun remove* (cl-item cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 "Remove all occurrences of ITEM in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 This is a non-destructive function; it makes a copy of SEQ if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 to avoid corrupting the original SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 Keywords supported: :test :test-not :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 (:start 0) :end) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 (if (<= (or cl-count (setq cl-count 8000000)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 cl-seq
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 cl-from-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 (if cl-i
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 (append (if cl-from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 (list ':end (1+ cl-i))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 (list ':start cl-i))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 cl-keys))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 (if (listp cl-seq) cl-res
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 (setq cl-end (- (or cl-end 8000000) cl-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 (if (= cl-start 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 (while (and cl-seq (> cl-end 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 (cl-check-test cl-item (car cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 (> (setq cl-count (1- cl-count)) 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 (if (and (> cl-count 0) (> cl-end 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 (setq cl-end (1- cl-end)) (cdr cl-seq))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 (while (and cl-p (> cl-end 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 (not (cl-check-test cl-item (car cl-p))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 (if (and cl-p (> cl-end 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 (nconc (ldiff cl-seq cl-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 (if (= cl-count 1) (cdr cl-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 (and (cdr cl-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 (apply 'delete* cl-item
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 (copy-sequence (cdr cl-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 ':start 0 ':end (1- cl-end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 ':count (1- cl-count) cl-keys))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 cl-seq)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 (defun remove-if (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 "Remove all items satisfying PREDICATE in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 This is a non-destructive function; it makes a copy of SEQ if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 to avoid corrupting the original SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 Keywords supported: :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 (apply 'remove* nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 (defun remove-if-not (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 "Remove all items not satisfying PREDICATE in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 This is a non-destructive function; it makes a copy of SEQ if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 to avoid corrupting the original SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 Keywords supported: :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 (apply 'remove* nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 (defun delete* (cl-item cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 "Remove all occurrences of ITEM in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 This is a destructive function; it reuses the storage of SEQ whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 Keywords supported: :test :test-not :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 (:start 0) :end) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 (if (<= (or cl-count (setq cl-count 8000000)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 cl-seq
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 (if (listp cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 (if (and cl-from-end (< cl-count 4000000))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 (let (cl-i)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 (while (and (>= (setq cl-count (1- cl-count)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 (setq cl-i (cl-position cl-item cl-seq cl-start
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 cl-end cl-from-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 (if (= cl-i 0) (setq cl-seq (cdr cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 (let ((cl-tail (nthcdr (1- cl-i) cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 (setcdr cl-tail (cdr (cdr cl-tail)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 (setq cl-end cl-i))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 (setq cl-end (- (or cl-end 8000000) cl-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 (if (= cl-start 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 (while (and cl-seq
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 (> cl-end 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 (cl-check-test cl-item (car cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 (> (setq cl-count (1- cl-count)) 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 (setq cl-end (1- cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 (setq cl-start (1- cl-start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 (if (and (> cl-count 0) (> cl-end 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 (let ((cl-p (nthcdr cl-start cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 (while (and (cdr cl-p) (> cl-end 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 (if (cl-check-test cl-item (car (cdr cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 (setcdr cl-p (cdr (cdr cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 (if (= (setq cl-count (1- cl-count)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 (setq cl-end 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 (setq cl-p (cdr cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 (setq cl-end (1- cl-end)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 (apply 'remove* cl-item cl-seq cl-keys)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 (defun delete-if (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 "Remove all items satisfying PREDICATE in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 This is a destructive function; it reuses the storage of SEQ whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 Keywords supported: :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 (apply 'delete* nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 (defun delete-if-not (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 "Remove all items not satisfying PREDICATE in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 This is a destructive function; it reuses the storage of SEQ whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 Keywords supported: :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 (apply 'delete* nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 (or (and (fboundp 'delete) (subrp (symbol-function 'delete)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 (defun remove (cl-item cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 "Remove all occurrences of ITEM in SEQ, testing with `equal'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 This is a non-destructive function; it makes a copy of SEQ if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 to avoid corrupting the original SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 Also see: `remove*', `delete', `delete*'"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 (remove* cl-item cl-seq ':test 'equal))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 (defun remq (cl-elt cl-list)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
358 "Remove all occurrences of ELT in LIST, comparing with `eq'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 This is a non-destructive function; it makes a copy of LIST to avoid
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 corrupting the original LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 Also see: `delq', `delete', `delete*', `remove', `remove*'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 (if (memq cl-elt cl-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 (delq cl-elt (copy-list cl-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 cl-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 (defun remove-duplicates (cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 "Return a copy of SEQ with all duplicate elements removed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 Keywords supported: :test :test-not :key :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 (cl-delete-duplicates cl-seq cl-keys t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 (defun delete-duplicates (cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 "Remove all duplicate elements from SEQ (destructively).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 Keywords supported: :test :test-not :key :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 (cl-delete-duplicates cl-seq cl-keys nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 (defun cl-delete-duplicates (cl-seq cl-keys cl-copy)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 (if (listp cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 (if cl-from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 (while (> cl-end 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 (setq cl-i 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 (while (setq cl-i (cl-position (cl-check-key (car cl-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 (cdr cl-p) cl-i (1- cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 (if cl-copy (setq cl-seq (copy-sequence cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 cl-p (nthcdr cl-start cl-seq) cl-copy nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 (let ((cl-tail (nthcdr cl-i cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 (setcdr cl-tail (cdr (cdr cl-tail))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 (setq cl-end (1- cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 (setq cl-p (cdr cl-p) cl-end (1- cl-end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 cl-start (1+ cl-start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 (cl-position (cl-check-key (car cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 (cdr cl-seq) 0 (1- cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 (while (and (cdr (cdr cl-p)) (> cl-end 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 (if (cl-position (cl-check-key (car (cdr cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 (cdr (cdr cl-p)) 0 (1- cl-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 (if cl-copy (setq cl-seq (copy-sequence cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 cl-p (nthcdr (1- cl-start) cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 cl-copy nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 (setcdr cl-p (cdr (cdr cl-p))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 (setq cl-p (cdr cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 (setq cl-end (1- cl-end) cl-start (1+ cl-start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 (defun substitute (cl-new cl-old cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 "Substitute NEW for OLD in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 This is a non-destructive function; it makes a copy of SEQ if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 to avoid corrupting the original SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 Keywords supported: :test :test-not :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 (cl-parsing-keywords (:test :test-not :key :if :if-not :count
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 (:start 0) :end :from-end) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 (if (or (eq cl-old cl-new)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 cl-seq
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 (if (not cl-i)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 cl-seq
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 (setq cl-seq (copy-sequence cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 (or cl-from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 (progn (cl-set-elt cl-seq cl-i cl-new)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 ':start cl-i cl-keys))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 "Substitute NEW for all items satisfying PREDICATE in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 This is a non-destructive function; it makes a copy of SEQ if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 to avoid corrupting the original SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 Keywords supported: :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 "Substitute NEW for all items not satisfying PREDICATE in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 This is a non-destructive function; it makes a copy of SEQ if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 to avoid corrupting the original SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 Keywords supported: :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 "Substitute NEW for OLD in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 This is a destructive function; it reuses the storage of SEQ whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 Keywords supported: :test :test-not :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 (cl-parsing-keywords (:test :test-not :key :if :if-not :count
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 (:start 0) :end :from-end) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 (let ((cl-p (nthcdr cl-start cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 (setq cl-end (- (or cl-end 8000000) cl-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 (while (and cl-p (> cl-end 0) (> cl-count 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 (if (cl-check-test cl-old (car cl-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 (setcar cl-p cl-new)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 (setq cl-count (1- cl-count))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 (setq cl-p (cdr cl-p) cl-end (1- cl-end))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 (or cl-end (setq cl-end (length cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 (if cl-from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 (while (and (< cl-start cl-end) (> cl-count 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 (setq cl-end (1- cl-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 (if (cl-check-test cl-old (elt cl-seq cl-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 (cl-set-elt cl-seq cl-end cl-new)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 (setq cl-count (1- cl-count)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 (while (and (< cl-start cl-end) (> cl-count 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 (if (cl-check-test cl-old (aref cl-seq cl-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 (aset cl-seq cl-start cl-new)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 (setq cl-count (1- cl-count))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 (setq cl-start (1+ cl-start))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 cl-seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 "Substitute NEW for all items satisfying PREDICATE in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 This is a destructive function; it reuses the storage of SEQ whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 Keywords supported: :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 "Substitute NEW for all items not satisfying PREDICATE in SEQ.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 This is a destructive function; it reuses the storage of SEQ whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 Keywords supported: :key :count :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 (defun find (cl-item cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 "Find the first occurrence of ITEM in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 Return the matching ITEM, or nil if not found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 Keywords supported: :test :test-not :key :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 (and cl-pos (elt cl-seq cl-pos))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 (defun find-if (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 "Find the first item satisfying PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 Return the matching ITEM, or nil if not found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 Keywords supported: :key :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 (apply 'find nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 (defun find-if-not (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 "Find the first item not satisfying PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 Return the matching ITEM, or nil if not found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 Keywords supported: :key :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 (apply 'find nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 (defun position (cl-item cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 "Find the first occurrence of ITEM in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 Return the index of the matching item, or nil if not found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 Keywords supported: :test :test-not :key :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 (cl-parsing-keywords (:test :test-not :key :if :if-not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 (:start 0) :end :from-end) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 (cl-position cl-item cl-seq cl-start cl-end cl-from-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 (if (listp cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 (let ((cl-p (nthcdr cl-start cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 (or cl-end (setq cl-end 8000000))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525 (let ((cl-res nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 (if (cl-check-test cl-item (car cl-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 (setq cl-res cl-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 cl-res))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 (or cl-end (setq cl-end (length cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 (if cl-from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 (while (and (>= (setq cl-end (1- cl-end)) cl-start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 (not (cl-check-test cl-item (aref cl-seq cl-end)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 (and (>= cl-end cl-start) cl-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 (while (and (< cl-start cl-end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 (not (cl-check-test cl-item (aref cl-seq cl-start))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 (setq cl-start (1+ cl-start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 (and (< cl-start cl-end) cl-start))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 (defun position-if (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 "Find the first item satisfying PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 Return the index of the matching item, or nil if not found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 Keywords supported: :key :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 (apply 'position nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 (defun position-if-not (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 "Find the first item not satisfying PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 Return the index of the matching item, or nil if not found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 Keywords supported: :key :start :end :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 (apply 'position nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 (defun count (cl-item cl-seq &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 "Count the number of occurrences of ITEM in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 Keywords supported: :test :test-not :key :start :end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 (let ((cl-count 0) cl-x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 (or cl-end (setq cl-end (length cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 (while (< cl-start cl-end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 (setq cl-start (1+ cl-start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 cl-count)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 (defun count-if (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 "Count the number of items satisfying PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 Keywords supported: :key :start :end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 (apply 'count nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 (defun count-if-not (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 "Count the number of items not satisfying PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 Keywords supported: :key :start :end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 (apply 'count nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 "Compare SEQ1 with SEQ2, return index of first mismatching element.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 Return nil if the sequences match. If one sequence is a prefix of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 other, the return value indicates the end of the shorted sequence.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 (cl-parsing-keywords (:test :test-not :key :from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 (:start1 0) :end1 (:start2 0) :end2) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 (or cl-end1 (setq cl-end1 (length cl-seq1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 (or cl-end2 (setq cl-end2 (length cl-seq2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 (if cl-from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 (cl-check-match (elt cl-seq1 (1- cl-end1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 (elt cl-seq2 (1- cl-end2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 (1- cl-end1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 (cl-check-match (if cl-p1 (car cl-p1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 (aref cl-seq1 cl-start1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 (if cl-p2 (car cl-p2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 (aref cl-seq2 cl-start2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 cl-start1)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 (defun search (cl-seq1 cl-seq2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 "Search for SEQ1 as a subsequence of SEQ2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 Return the index of the leftmost element of the first match found;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 return nil if there are no matches.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 (cl-parsing-keywords (:test :test-not :key :from-end
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 (:start1 0) :end1 (:start2 0) :end2) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 (or cl-end1 (setq cl-end1 (length cl-seq1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 (or cl-end2 (setq cl-end2 (length cl-seq2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 (if (>= cl-start1 cl-end1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 (if cl-from-end cl-end2 cl-start2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 (let* ((cl-len (- cl-end1 cl-start1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 (cl-first (cl-check-key (elt cl-seq1 cl-start1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 (cl-if nil) cl-pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 (setq cl-end2 (- cl-end2 (1- cl-len)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 (while (and (< cl-start2 cl-end2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 (setq cl-pos (cl-position cl-first cl-seq2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 cl-start2 cl-end2 cl-from-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 (apply 'mismatch cl-seq1 cl-seq2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 ':start1 (1+ cl-start1) ':end1 cl-end1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 ':from-end nil cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 (and (< cl-start2 cl-end2) cl-pos)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 (defun sort* (cl-seq cl-pred &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 "Sort the argument SEQUENCE according to PREDICATE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 This is a destructive function; it reuses the storage of SEQUENCE if possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 (if (nlistp cl-seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 (cl-parsing-keywords (:key) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 (if (memq cl-key '(nil identity))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 (sort cl-seq cl-pred)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 (sort cl-seq (function (lambda (cl-x cl-y)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 (funcall cl-pred (funcall cl-key cl-x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 (funcall cl-key cl-y)))))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 (defun stable-sort (cl-seq cl-pred &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 "Sort the argument SEQUENCE stably according to PREDICATE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 This is a destructive function; it reuses the storage of SEQUENCE if possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 (apply 'sort* cl-seq cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 "Destructively merge the two sequences to produce a new sequence.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 TYPE is the sequence type to return, SEQ1 and SEQ2 are the two
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 argument sequences, and PRED is a `less-than' predicate on the elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 (cl-parsing-keywords (:key) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 (let ((cl-res nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 (while (and cl-seq1 cl-seq2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 (if (funcall cl-pred (cl-check-key (car cl-seq2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 (cl-check-key (car cl-seq1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 (cl-push (cl-pop cl-seq2) cl-res)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 (cl-push (cl-pop cl-seq1) cl-res)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 ;;; See compiler macro in cl-macs.el
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 (defun member* (cl-item cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 "Find the first occurrence of ITEM in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 Return the sublist of LIST whose car is ITEM.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 (if cl-keys
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 (while (and cl-list (not (cl-check-test cl-item (car cl-list))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 (setq cl-list (cdr cl-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 cl-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 (if (and (numberp cl-item) (not (integerp cl-item)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 (member cl-item cl-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 (memq cl-item cl-list))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 (defun member-if (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 "Find the first item satisfying PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 Return the sublist of LIST whose car matches.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 (apply 'member* nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 (defun member-if-not (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 "Find the first item not satisfying PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 Return the sublist of LIST whose car matches.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 (apply 'member* nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 (defun cl-adjoin (cl-item cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 (if (cl-parsing-keywords (:key) t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 cl-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 (cons cl-item cl-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 ;;; See compiler macro in cl-macs.el
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 (defun assoc* (cl-item cl-alist &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 "Find the first item whose car matches ITEM in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 (if cl-keys
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 (while (and cl-alist
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 (or (not (consp (car cl-alist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 (not (cl-check-test cl-item (car (car cl-alist))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 (setq cl-alist (cdr cl-alist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 (and cl-alist (car cl-alist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 (if (and (numberp cl-item) (not (integerp cl-item)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 (assoc cl-item cl-alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 (assq cl-item cl-alist))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 (defun assoc-if (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 "Find the first item whose car satisfies PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 (apply 'assoc* nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 (defun assoc-if-not (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 "Find the first item whose car does not satisfy PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721 (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 (defun rassoc* (cl-item cl-alist &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 "Find the first item whose cdr matches ITEM in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 (if (or cl-keys (numberp cl-item))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 (while (and cl-alist
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 (or (not (consp (car cl-alist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 (not (cl-check-test cl-item (cdr (car cl-alist))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 (setq cl-alist (cdr cl-alist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 (and cl-alist (car cl-alist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 (rassq cl-item cl-alist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 (defun rassoc-if (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 "Find the first item whose cdr satisfies PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 (apply 'rassoc* nil cl-list ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 (defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 "Find the first item whose cdr does not satisfy PREDICATE in LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 (defun union (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 "Combine LIST1 and LIST2 using a set-union operation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 The result list contains all items that appear in either LIST1 or LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 This is a non-destructive function; it makes a copy of the data if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 to avoid corrupting the original LIST1 and LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 ((equal cl-list1 cl-list2) cl-list1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 (or (>= (length cl-list1) (length cl-list2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 (while cl-list2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 (if (or cl-keys (numberp (car cl-list2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 (or (memq (car cl-list2) cl-list1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 (cl-push (car cl-list2) cl-list1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 (cl-pop cl-list2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 cl-list1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 (defun nunion (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 "Combine LIST1 and LIST2 using a set-union operation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 The result list contains all items that appear in either LIST1 or LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 This is a destructive function; it reuses the storage of LIST1 and LIST2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 (t (apply 'union cl-list1 cl-list2 cl-keys))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 (defun intersection (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 "Combine LIST1 and LIST2 using a set-intersection operation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 The result list contains all items that appear in both LIST1 and LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 This is a non-destructive function; it makes a copy of the data if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 to avoid corrupting the original LIST1 and LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 (and cl-list1 cl-list2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 (if (equal cl-list1 cl-list2) cl-list1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781 (cl-parsing-keywords (:key) (:test :test-not)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 (let ((cl-res nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 (or (>= (length cl-list1) (length cl-list2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 (while cl-list2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 (if (if (or cl-keys (numberp (car cl-list2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 (apply 'member* (cl-check-key (car cl-list2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 cl-list1 cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 (memq (car cl-list2) cl-list1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 (cl-push (car cl-list2) cl-res))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 (cl-pop cl-list2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 cl-res)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 (defun nintersection (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 "Combine LIST1 and LIST2 using a set-intersection operation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796 The result list contains all items that appear in both LIST1 and LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 This is a destructive function; it reuses the storage of LIST1 and LIST2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 (defun set-difference (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 "Combine LIST1 and LIST2 using a set-difference operation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 The result list contains all items that appear in LIST1 but not LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 This is a non-destructive function; it makes a copy of the data if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 to avoid corrupting the original LIST1 and LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 (if (or (null cl-list1) (null cl-list2)) cl-list1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 (cl-parsing-keywords (:key) (:test :test-not)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 (let ((cl-res nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 (while cl-list1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 (or (if (or cl-keys (numberp (car cl-list1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 (apply 'member* (cl-check-key (car cl-list1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 cl-list2 cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 (memq (car cl-list1) cl-list2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 (cl-push (car cl-list1) cl-res))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 (cl-pop cl-list1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 cl-res))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 (defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 "Combine LIST1 and LIST2 using a set-difference operation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 The result list contains all items that appear in LIST1 but not LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 This is a destructive function; it reuses the storage of LIST1 and LIST2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 (if (or (null cl-list1) (null cl-list2)) cl-list1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 (apply 'set-difference cl-list1 cl-list2 cl-keys)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 "Combine LIST1 and LIST2 using a set-exclusive-or operation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 The result list contains all items that appear in exactly one of LIST1, LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 This is a non-destructive function; it makes a copy of the data if necessary
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 to avoid corrupting the original LIST1 and LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 ((equal cl-list1 cl-list2) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 "Combine LIST1 and LIST2 using a set-exclusive-or operation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 The result list contains all items that appear in exactly one of LIST1, LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 This is a destructive function; it reuses the storage of LIST1 and LIST2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 whenever possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 ((equal cl-list1 cl-list2) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 (defun subsetp (cl-list1 cl-list2 &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 "True if LIST1 is a subset of LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 I.e., if every element of LIST1 also appears in LIST2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 (cond ((null cl-list1) t) ((null cl-list2) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 ((equal cl-list1 cl-list2) t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 (t (cl-parsing-keywords (:key) (:test :test-not)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 (while (and cl-list1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 (apply 'member* (cl-check-key (car cl-list1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 cl-list2 cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 (cl-pop cl-list1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 (null cl-list1)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 Return a copy of TREE with all matching elements replaced by NEW.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 Return a copy of TREE with all non-matching elements replaced by NEW.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 (defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 "Substitute NEW for OLD everywhere in TREE (destructively).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 Any element of TREE which is `eql' to OLD is changed to NEW (via a call
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 to `setcar').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 "Substitute NEW for elements matching PREDICATE in TREE (destructively).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 Any element of TREE which matches is changed to NEW (via a call to `setcar').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 "Substitute NEW for elements not matching PREDICATE in TREE (destructively).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 Any element of TREE which matches is changed to NEW (via a call to `setcar').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 Keywords supported: :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 (defun sublis (cl-alist cl-tree &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 "Perform substitutions indicated by ALIST in TREE (non-destructively).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 Return a copy of TREE with all matching elements replaced.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 (cl-sublis-rec cl-tree)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 (defvar cl-alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 (defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 (setq cl-p (cdr cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 (if cl-p (cdr (car cl-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 (if (consp cl-tree)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 (let ((cl-a (cl-sublis-rec (car cl-tree)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 (cl-d (cl-sublis-rec (cdr cl-tree))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 cl-tree
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913 (cons cl-a cl-d)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 cl-tree))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 (defun nsublis (cl-alist cl-tree &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 "Perform substitutions indicated by ALIST in TREE (destructively).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 Any matching element of TREE is changed via a call to `setcar'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 (let ((cl-hold (list cl-tree)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 (cl-nsublis-rec cl-hold)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 (car cl-hold))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 (defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 (while (consp cl-tree)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 (setq cl-p (cdr cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 (if cl-p (setcar cl-tree (cdr (car cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 (setq cl-p (cdr cl-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 (if cl-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 (setq cl-tree (cdr cl-tree))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 (defun tree-equal (cl-x cl-y &rest cl-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 "Return t if trees X and Y have `eql' leaves.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 Atoms are compared by `eql'; cons cells are compared recursively.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 Keywords supported: :test :test-not :key"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 (cl-parsing-keywords (:test :test-not :key) ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 (cl-tree-equal-rec cl-x cl-y)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 (defun cl-tree-equal-rec (cl-x cl-y)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 (while (and (consp cl-x) (consp cl-y)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 (cl-tree-equal-rec (car cl-x) (car cl-y)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 (run-hooks 'cl-seq-load-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 ;;; cl-seq.el ends here