commit/XEmacs: 2 new changesets
12 years, 8 months
Bitbucket
Bitbucket
2 new commits in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/3df910176b6a/
changeset: 3df910176b6a
user: kehoea
date: 2012-05-04 22:12:02
summary: Support predefined character classes in #'skip-chars-{forward,backward}, too
src/ChangeLog addition:
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* regex.c:
Move various #defines and enums to regex.h, since we need them
when implementing #'skip-chars-{backward,forward}.
* regex.c (re_wctype):
* regex.c (re_iswctype):
Be more robust about case insensitivity here.
* regex.c (regex_compile):
* regex.h:
* regex.h (RE_ISWCTYPE_ARG_DECL):
* regex.h (CHAR_CLASS_MAX_LENGTH):
* search.c (skip_chars):
Implement support for the predefined character classes in this
function.
tests/ChangeLog addition:
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/regexp-tests.el (equal):
* automated/regexp-tests.el (Assert-char-class):
Correct a stray parenthesis; add tests for the predefined
character classes with #'skip-chars-{forward,backward}; update the
tests to reflect some changed design decisions on my part.
man/ChangeLog addition:
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/searching.texi (Regular Expressions):
* lispref/searching.texi (Syntax of Regexps):
* lispref/searching.texi (Char Classes):
* lispref/searching.texi (Regexp Example):
Document the predefined character classes in this file.
affected #: 8 files
diff -r d026b665014fda7a8d6148e8cc8fb9d046bff7f7 -r 3df910176b6abc7d66f691cc8cff97498bf5d419 man/ChangeLog
--- a/man/ChangeLog
+++ b/man/ChangeLog
＠＠ -1,3 +1,11 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/searching.texi (Regular Expressions):
+ * lispref/searching.texi (Syntax of Regexps):
+ * lispref/searching.texi (Char Classes):
+ * lispref/searching.texi (Regexp Example):
+ Document the predefined character classes in this file.
+
2011-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.texi (Top):
diff -r d026b665014fda7a8d6148e8cc8fb9d046bff7f7 -r 3df910176b6abc7d66f691cc8cff97498bf5d419 man/lispref/searching.texi
--- a/man/lispref/searching.texi
+++ b/man/lispref/searching.texi
＠＠ -180,6 +180,7 ＠＠
＠menu
* Syntax of Regexps:: Rules for writing regular expressions.
+* Char Classes:: Predefined character classes for searching.
* Regexp Example:: Illustrates regular expression syntax.
＠end menu
＠＠ -335,6 +336,11 ＠＠
To include ＠samp{^} in a set, put it anywhere but at the beginning of
the set.
+It is also possible to specify named character classes as part of your
+character set; for example, ＠samp{[:xdigit:]} will match hexadecimal
+digits, ＠samp{[:nonascii:]} will match characters outside the basic
+ASCII set. These are documented elsewhere, ＠pxref{Char Classes}.
+
＠item [^ ＠dots{} ]
＠cindex ＠samp{^} in regexp
＠samp{[^} begins a ＠dfn{complement character set}, which matches any
＠＠ -604,6 +610,61 ＠＠
＠end example
＠end defun
+＠node Char Classes
+＠subsection Char Classes
+
+These are the predefined character classes available within regular
+expression character sets, and within ＠samp{skip-chars-forward} and
+＠samp{skip-chars-backward}, ＠xref{Skipping Characters}.
+
+＠table ＠samp
+＠item [:alnum:]
+This matches any ASCII letter or digit, or any non-ASCII character
+with word syntax.
+＠item [:alpha:]
+This matches any ASCII letter, or any non-ASCII character with word syntax.
+＠item [:ascii:]
+This matches any character with a numeric value below ＠samp{?\x80}.
+＠item [:blank:]
+This matches space or tab.
+＠item [:cntrl:]
+This matches any character with a numeric value below ＠samp{?\x20},
+the code for space; these are the ASCII control characters.
+＠item [:digit:]
+This matches the characters ＠samp{?0} to ＠samp{?9}, inclusive.
+＠item [:graph:]
+This matches ``graphic'' characters, with numeric values greater than
+＠samp{?\x20}, exclusive of ＠samp{?\x7f}, the delete character.
+＠item [:lower:]
+This matches minuscule characters, or any character with case
+information if ＠samp{case-fold-search} is non-nil.
+＠item [:multibyte:]
+This matches non-ASCII characters, that is, any character with a
+numeric value above ＠samp{?\x7f}.
+＠item [:nonascii:]
+This is equivalent to ＠samp{[:multibyte:]}.
+＠item [:print:]
+This is equivalent to [:graph:], but also matches the space character,
+＠samp{?\x20}.
+＠item [:punct:]
+This matches non-control, non-alphanumeric ASCII characters, or any
+non-ASCII character without word syntax.
+＠item [:space:]
+This matches any character with whitespace syntax.
+＠item [:unibyte:]
+This is a GNU Emacs extension; in XEmacs it is equivalent to
+＠samp{[:ascii:]}. Note that this means it is not equivalent to
+＠samp{"\x00-\xff"}, which one might have assumed to be the case.
+＠item [:upper:]
+This matches majuscule characters, or any character with case
+information if ＠samp{case-fold-search} is non-nil.
+＠item [:word:]
+This matches any character with word syntax.
+＠item [:xdigit:]
+This matches hexadecimal digits, so the decimal digits ＠samp{0-9} and the
+letters ＠samp{a-F} and ＠samp{A-F}.
+＠end table
+
＠node Regexp Example
＠subsection Complex Regexp Example
diff -r d026b665014fda7a8d6148e8cc8fb9d046bff7f7 -r 3df910176b6abc7d66f691cc8cff97498bf5d419 src/ChangeLog
--- a/src/ChangeLog
+++ b/src/ChangeLog
＠＠ -1,3 +1,19 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * regex.c:
+ Move various #defines and enums to regex.h, since we need them
+ when implementing #'skip-chars-{backward,forward}.
+ * regex.c (re_wctype):
+ * regex.c (re_iswctype):
+ Be more robust about case insensitivity here.
+ * regex.c (regex_compile):
+ * regex.h:
+ * regex.h (RE_ISWCTYPE_ARG_DECL):
+ * regex.h (CHAR_CLASS_MAX_LENGTH):
+ * search.c (skip_chars):
+ Implement support for the predefined character classes in this
+ function.
+
2012-04-25 Aidan Kehoe <kehoea(a)parhasard.net>
* search.c (string_match_1): Actually use the POSIX argument here,
diff -r d026b665014fda7a8d6148e8cc8fb9d046bff7f7 -r 3df910176b6abc7d66f691cc8cff97498bf5d419 src/regex.c
--- a/src/regex.c
+++ b/src/regex.c
＠＠ -178,51 +178,7 ＠＠
/* isalpha etc. are used for the character classes. */
#include <ctype.h>
-#ifdef emacs
-
-/* 1 if C is an ASCII character. */
-#define ISASCII(c) ((c) < 0x80)
-
-/* 1 if C is a unibyte character. */
-#define ISUNIBYTE(c) 0
-
-/* The Emacs definitions should not be directly affected by locales. */
-
-/* In Emacs, these are only used for single-byte characters. */
-#define ISDIGIT(c) ((c) >= '0' && (c) <= '9')
-#define ISCNTRL(c) ((c) < ' ')
-#define ISXDIGIT(c) (ISDIGIT (c) || ((c) >= 'a' && (c) <= 'f') \
- || ((c) >= 'A' && (c) <= 'F'))
-
-/* This is only used for single-byte characters. */
-#define ISBLANK(c) ((c) == ' ' || (c) == '\t')
-
-/* The rest must handle multibyte characters. */
-
-#define ISGRAPH(c) ((c) > ' ' && (c) != 0x7f)
-#define ISPRINT(c) ((c) == ' ' || ISGRAPH (c))
-#define ISALPHA(c) (ISASCII (c) ? (((c) >= 'a' && (c) <= 'z') \
- || ((c) >= 'A' && (c) <= 'Z')) \
- : ISWORD (c))
-#define ISALNUM(c) (ISALPHA (c) || ISDIGIT (c))
-
-#define ISLOWER(c) LOWERCASEP (lispbuf, c)
-
-#define ISPUNCT(c) (ISASCII (c) \
- ? ((c) > ' ' && (c) < 0x7F \
- && !(((c) >= 'a' && (c) <= 'z') \
- || ((c) >= 'A' && (c) <= 'Z') \
- || ((c) >= '0' && (c) <= '9'))) \
- : !ISWORD (c))
-
-#define ISSPACE(c) \
- (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Swhitespace)
-
-#define ISUPPER(c) UPPERCASEP (lispbuf, c)
-
-#define ISWORD(c) (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Sword)
-
-#else /* not emacs */
+#ifndef emacs /* For the emacs build, we need these in the header. */
/* 1 if C is an ASCII character. */
#define ISASCII(c) ((c) < 0200)
＠＠ -2013,23 +1969,6 ＠＠
/* The next available element. */
#define COMPILE_STACK_TOP (compile_stack.stack[compile_stack.avail])
-/* Bits used to implement the multibyte-part of the various character
- classes such as [:alnum:] in a charset's range table. XEmacs; use an
- enum, so they're visible in the debugger. */
-enum
-{
- BIT_WORD = (1 << 0),
- BIT_LOWER = (1 << 1),
- BIT_PUNCT = (1 << 2),
- BIT_SPACE = (1 << 3),
- BIT_UPPER = (1 << 4),
- /* XEmacs; we need this, because we unify treatment of ASCII and non-ASCII
- (possible matches) in charset_mule. [:alpha:] matches all characters
- with word syntax, with the exception of [0-9]. We don't need
- BIT_MULTIBYTE. */
- BIT_ALPHA = (1 << 5)
-};
-
/* Set the bit for character C in a bit vector. */
#define SET_LIST_BIT(c) \
(buf_end[((unsigned char) (c)) / BYTEWIDTH] \
＠＠ -2059,10 +1998,8 ＠＠
} \
}
-#define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */
-
/* Map a string to the char class it names (if any). */
-static re_wctype_t
+re_wctype_t
re_wctype (const char *string)
{
if (STREQ (string, "alnum")) return RECC_ALNUM;
＠＠ -2086,17 +2023,10 ＠＠
}
/* True if CH is in the char class CC. */
-static re_bool
-re_iswctype (int ch, re_wctype_t cc)
+int
+re_iswctype (int ch, re_wctype_t cc
+ RE_ISWCTYPE_ARG_DECL)
{
-#ifdef emacs
- /* This is cheesy, lispbuf isn't available to us when compiling the
- pattern. It's effectively only called (on Mule builds) when the current
- buffer doesn't matter (e.g. for RECC_ASCII, RECC_CNTRL), so it's not a
- big deal. */
- struct buffer *lispbuf = current_buffer;
-#endif
-
switch (cc)
{
case RECC_ALNUM: return ISALNUM (ch) != 0;
＠＠ -2105,11 +2035,20 ＠＠
case RECC_CNTRL: return ISCNTRL (ch) != 0;
case RECC_DIGIT: return ISDIGIT (ch) != 0;
case RECC_GRAPH: return ISGRAPH (ch) != 0;
- case RECC_LOWER: return ISLOWER (ch) != 0;
case RECC_PRINT: return ISPRINT (ch) != 0;
case RECC_PUNCT: return ISPUNCT (ch) != 0;
case RECC_SPACE: return ISSPACE (ch) != 0;
+#ifdef emacs
+ case RECC_UPPER:
+ return NILP (lispbuf->case_fold_search) ? ISUPPER (ch) != 0
+: !NOCASEP (lispbuf, ch);
+ case RECC_LOWER:
+ return NILP (lispbuf->case_fold_search) ? ISLOWER (ch) != 0
+: !NOCASEP (lispbuf, ch);
+#else
case RECC_UPPER: return ISUPPER (ch) != 0;
+ case RECC_LOWER: return ISLOWER (ch) != 0;
+#endif
case RECC_XDIGIT: return ISXDIGIT (ch) != 0;
case RECC_ASCII: return ISASCII (ch) != 0;
case RECC_NONASCII: case RECC_MULTIBYTE: return !ISASCII (ch);
＠＠ -2140,6 +2079,10 ＠＠
}
}
+#endif /* MULE */
+
+#ifdef emacs
+
/* Return a bit-pattern to use in the range-table bits to match multibyte
chars of class CC. */
static unsigned char
＠＠ -2158,7 +2101,8 ＠＠
case RECC_ASCII: case RECC_DIGIT: case RECC_XDIGIT: case RECC_CNTRL:
case RECC_BLANK: case RECC_UNIBYTE: case RECC_ERROR: return 0;
default:
- abort ();
+ ABORT ();
+ return 0;
}
}
＠＠ -2185,9 +2129,12 ＠＠
RE_TRANSLATE_TYPE translate,
reg_syntax_t syntax,
Lisp_Object rtab);
-static reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
- Bitbyte *flags_out);
#endif /* MULE */
+#ifdef emacs
+reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
+ Bitbyte *flags_out);
+#endif
+
static re_bool group_match_null_string_p (unsigned char **p,
unsigned char *end,
register_info_type *reg_info);
＠＠ -2814,7 +2761,8 ＠＠
#endif /* MULE */
for (ch = 0; ch < (1 << BYTEWIDTH); ++ch)
{
- if (re_iswctype (ch, cc))
+ if (re_iswctype (ch, cc
+ RE_ISWCTYPE_ARG (current_buffer)))
{
SET_LIST_BIT (ch);
}
＠＠ -3938,7 +3886,11 ＠＠
return REG_NOERROR;
}
-static reg_errcode_t
+#endif /* MULE */
+
+#ifdef emacs
+
+reg_errcode_t
compile_char_class (re_wctype_t cc, Lisp_Object rtab, Bitbyte *flags_out)
{
*flags_out |= re_wctype_to_bit (cc);
diff -r d026b665014fda7a8d6148e8cc8fb9d046bff7f7 -r 3df910176b6abc7d66f691cc8cff97498bf5d419 src/regex.h
--- a/src/regex.h
+++ b/src/regex.h
＠＠ -30,6 +30,8 ＠＠
#define RE_LISP_CONTEXT_ARGS_DECL , Lisp_Object lispobj, struct buffer *lispbuf, struct syntax_cache *scache
#define RE_LISP_CONTEXT_ARGS_MULE_DECL , Lisp_Object lispobj, struct buffer *USED_IF_MULE (lispbuf), struct syntax_cache *scache
#define RE_LISP_CONTEXT_ARGS , lispobj, lispbuf, scache
+#define RE_ISWCTYPE_ARG_DECL , struct buffer *lispbuf
+#define RE_ISWCTYPE_ARG(varname) , varname
#else
#define RE_TRANSLATE_TYPE char *
#define RE_LISP_SHORT_CONTEXT_ARGS_DECL
＠＠ -37,6 +39,8 ＠＠
#define RE_LISP_CONTEXT_ARGS_DECL
#define RE_LISP_CONTEXT_ARGS_MULE_DECL
#define RE_LISP_CONTEXT_ARGS
+#define RE_ISWCTYPE_ARG_DECL
+#define RE_ISWCTYPE_ARG(varname)
#define Elemcount ssize_t
#define Bytecount ssize_t
#endif /* emacs */
＠＠ -559,6 +563,86 ＠＠
RECC_ASCII, RECC_UNIBYTE
} re_wctype_t;
+#define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */
+
+/* Map a string to the char class it names (if any). */
+re_wctype_t re_wctype (const char *);
+
+/* Is character CH a member of the character class CC? */
+int re_iswctype (int ch, re_wctype_t cc RE_ISWCTYPE_ARG_DECL);
+
+/* Bits used to implement the multibyte-part of the various character
+ classes such as [:alnum:] in a charset's range table. XEmacs; use an
+ enum, so they're visible in the debugger. */
+enum
+{
+ BIT_WORD = (1 << 0),
+ BIT_LOWER = (1 << 1),
+ BIT_PUNCT = (1 << 2),
+ BIT_SPACE = (1 << 3),
+ BIT_UPPER = (1 << 4),
+ /* XEmacs; we need this, because we unify treatment of ASCII and non-ASCII
+ (possible matches) in charset_mule. [:alpha:] matches all characters
+ with word syntax, with the exception of [0-9]. We don't need
+ BIT_MULTIBYTE. */
+ BIT_ALPHA = (1 << 5)
+};
+
+#ifdef emacs
+reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
+ Bitbyte *flags_out);
+
+#endif
+
+/* isalpha etc. are used for the character classes. */
+#include <ctype.h>
+
+#ifdef emacs
+
+/* 1 if C is an ASCII character. */
+#define ISASCII(c) ((c) < 0x80)
+
+/* 1 if C is a unibyte character. */
+#define ISUNIBYTE ISASCII
+
+/* The Emacs definitions should not be directly affected by locales. */
+
+/* In Emacs, these are only used for single-byte characters. */
+#define ISDIGIT(c) ((c) >= '0' && (c) <= '9')
+#define ISCNTRL(c) ((c) < ' ')
+#define ISXDIGIT(c) (ISDIGIT (c) || ((c) >= 'a' && (c) <= 'f') \
+ || ((c) >= 'A' && (c) <= 'F'))
+
+/* This is only used for single-byte characters. */
+#define ISBLANK(c) ((c) == ' ' || (c) == '\t')
+
+/* The rest must handle multibyte characters. */
+
+#define ISGRAPH(c) ((c) > ' ' && (c) != 0x7f)
+#define ISPRINT(c) ((c) == ' ' || ISGRAPH (c))
+#define ISALPHA(c) (ISASCII (c) ? (((c) >= 'a' && (c) <= 'z') \
+ || ((c) >= 'A' && (c) <= 'Z')) \
+ : ISWORD (c))
+#define ISALNUM(c) (ISALPHA (c) || ISDIGIT (c))
+
+#define ISLOWER(c) LOWERCASEP (lispbuf, c)
+
+#define ISPUNCT(c) (ISASCII (c) \
+ ? ((c) > ' ' && (c) < 0x7F \
+ && !(((c) >= 'a' && (c) <= 'z') \
+ || ((c) >= 'A' && (c) <= 'Z') \
+ || ((c) >= '0' && (c) <= '9'))) \
+ : !ISWORD (c))
+
+#define ISSPACE(c) \
+ (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Swhitespace)
+
+#define ISUPPER(c) UPPERCASEP (lispbuf, c)
+
+#define ISWORD(c) (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Sword)
+
+#endif
+
END_C_DECLS
#endif /* INCLUDED_regex_h_ */
diff -r d026b665014fda7a8d6148e8cc8fb9d046bff7f7 -r 3df910176b6abc7d66f691cc8cff97498bf5d419 src/search.c
--- a/src/search.c
+++ b/src/search.c
＠＠ -887,9 +887,9 ＠＠
a range table. */
unsigned char fastmap[0400];
int negate = 0;
- REGISTER int i;
Charbpos limit;
struct syntax_cache *scache;
+ Bitbyte class_bits = 0;
if (NILP (lim))
limit = forwardp ? BUF_ZV (buf) : BUF_BEGV (buf);
＠＠ -957,6 +957,51 ＠＠
Vskip_chars_range_table);
INC_IBYTEPTR (p);
}
+ else if ('[' == c && p != pend && *p == ':')
+ {
+ Ibyte *colonp;
+ Extbyte *classname;
+ int ch = 0;
+ re_wctype_t cc;
+
+ INC_IBYTEPTR (p);
+
+ if (p == pend)
+ {
+ fastmap ['['] = fastmap[':'] = 1;
+ break;
+ }
+
+ colonp = memchr (p, ':', pend - p);
+ if (NULL == colonp || (colonp + 1) == pend || colonp[1] != ']')
+ {
+ fastmap ['['] = fastmap[':'] = 1;
+ continue;
+ }
+
+ classname = alloca_extbytes (colonp - p + 1);
+ memmove (classname, p, colonp - p);
+ classname[colonp - p] = '\0';
+ cc = re_wctype (classname);
+
+ if (cc == RECC_ERROR)
+ {
+ invalid_argument ("Invalid character class",
+ build_extstring (classname, Qbinary));
+ }
+
+ for (ch = 0; ch < countof (fastmap); ++ch)
+ {
+ if (re_iswctype (ch, cc, buf))
+ {
+ fastmap[ch] = 1;
+ }
+ }
+
+ compile_char_class (cc, Vskip_chars_range_table, &class_bits);
+
+ p = colonp + 2;
+ }
else
{
if (c < 0400)
＠＠ -972,14 +1017,6 ＠＠
if (syntaxp && fastmap['-'] != 0)
fastmap[' '] = 1;
- /* If ^ was the first character, complement the fastmap.
- We don't complement the range table, however; we just use negate
- in the comparisons below. */
-
- if (negate)
- for (i = 0; i < (int) (sizeof (fastmap)); i++)
- fastmap[i] ^= 1;
-
{
Charbpos start_point = BUF_PT (buf);
Charbpos pos = start_point;
＠＠ -996,7 +1033,8 ＠＠
while (fastmap[(unsigned char)
syntax_code_spec
[(int) SYNTAX_FROM_CACHE
- (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]])
+ (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]]
+ != negate)
{
pos++;
INC_BYTEBPOS (buf, pos_byte);
＠＠ -1013,10 +1051,11 ＠＠
pos--;
DEC_BYTEBPOS (buf, pos_byte);
UPDATE_SYNTAX_CACHE_BACKWARD (scache, pos);
- if (!fastmap[(unsigned char)
- syntax_code_spec
- [(int) SYNTAX_FROM_CACHE
- (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]])
+ if (fastmap[(unsigned char)
+ syntax_code_spec
+ [(int) SYNTAX_FROM_CACHE
+ (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]]
+ == negate)
{
pos++;
pos_byte = savepos;
＠＠ -1027,16 +1066,30 ＠＠
}
else
{
+ struct buffer *lispbuf = buf;
+
+#define CLASS_BIT_CHECK(c) \
+ (class_bits && ((class_bits & BIT_ALPHA && ISALPHA (c)) \
+ || (class_bits & BIT_SPACE && ISSPACE (c)) \
+ || (class_bits & BIT_PUNCT && ISPUNCT (c)) \
+ || (class_bits & BIT_WORD && ISWORD (c)) \
+ || (NILP (buf->case_fold_search) ? \
+ ((class_bits & BIT_UPPER && ISUPPER (c)) \
+ || (class_bits & BIT_LOWER && ISLOWER (c))) \
+: (class_bits & (BIT_UPPER | BIT_LOWER) \
+ && !NOCASEP (buf, c)))))
if (forwardp)
{
while (pos < limit)
{
Ichar ch = BYTE_BUF_FETCH_CHAR (buf, pos_byte);
- if ((ch < 0400) ? fastmap[ch] :
- (NILP (Fget_range_table (make_fixnum (ch),
- Vskip_chars_range_table,
- Qnil))
- == negate))
+
+ if ((ch < countof (fastmap) ? fastmap[ch]
+: (CLASS_BIT_CHECK (ch) ||
+ (EQ (Qt, Fget_range_table (make_fixnum (ch),
+ Vskip_chars_range_table,
+ Qnil)))))
+ != negate)
{
pos++;
INC_BYTEBPOS (buf, pos_byte);
＠＠ -1054,11 +1107,12 ＠＠
DEC_BYTEBPOS (buf, prev_pos_byte);
ch = BYTE_BUF_FETCH_CHAR (buf, prev_pos_byte);
- if ((ch < 0400) ? fastmap[ch] :
- (NILP (Fget_range_table (make_fixnum (ch),
- Vskip_chars_range_table,
- Qnil))
- == negate))
+ if ((ch < countof (fastmap) ? fastmap[ch]
+: (CLASS_BIT_CHECK (ch) ||
+ (EQ (Qt, Fget_range_table (make_fixnum (ch),
+ Vskip_chars_range_table,
+ Qnil)))))
+ != negate)
{
pos--;
pos_byte = prev_pos_byte;
diff -r d026b665014fda7a8d6148e8cc8fb9d046bff7f7 -r 3df910176b6abc7d66f691cc8cff97498bf5d419 tests/ChangeLog
--- a/tests/ChangeLog
+++ b/tests/ChangeLog
＠＠ -1,3 +1,11 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/regexp-tests.el (equal):
+ * automated/regexp-tests.el (Assert-char-class):
+ Correct a stray parenthesis; add tests for the predefined
+ character classes with #'skip-chars-{forward,backward}; update the
+ tests to reflect some changed design decisions on my part.
+
2012-04-25 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/regexp-tests.el: Check that #'posix-string-match
diff -r d026b665014fda7a8d6148e8cc8fb9d046bff7f7 -r 3df910176b6abc7d66f691cc8cff97498bf5d419 tests/automated/regexp-tests.el
--- a/tests/automated/regexp-tests.el
+++ b/tests/automated/regexp-tests.el
＠＠ -76,7 +76,7 ＠＠
(save-match-data
(progn (posix-string-match "i\\|ii" "ii") (match-data)))
'(0 2))
- "checking #'posix-string-match actually returns the longest match"))
+ "checking #'posix-string-match actually returns the longest match")
;; looking-at
(with-temp-buffer
＠＠ -665,7 +665,25 ＠＠
(Assert (null (string-match ,(concat "[^" class
(string non-matching-char) "]")
,(concat (string matching-char)
- (string non-matching-char)))))))
+ (string non-matching-char)))))
+ (let ((old-case-fold-search case-fold-search))
+ (with-temp-buffer
+ (setq case-fold-search old-case-fold-search)
+ (insert-char ,matching-char 20)
+ (insert-char ,non-matching-char 20)
+ (goto-char (point-min))
+ (Assert (eql (skip-chars-forward ,class) 20)
+ ,(format "making sure %s skips %S forward"
+ class matching-char))
+ (Assert (eql (skip-chars-forward ,(concat "^" class)) 20)
+ ,(format "making sure ^%s skips %S forward"
+ class non-matching-char))
+ (Assert (eql (skip-chars-backward ,(concat "^" class)) -20)
+ ,(format "making sure ^%s skips %S backward"
+ class non-matching-char))
+ (Assert (eql (skip-chars-backward ,class) -20)
+ ,(format "making sure %s skips %S backward"
+ class matching-char))))))
(Assert-never-matching (class &rest characters)
(cons
'progn
＠＠ -706,7 +724,7 ＠＠
(Assert-char-class "[:alnum:]" ?A ?/)
(Assert-char-class "[:alnum:]" ?Z ?!)
(Assert-char-class "[:alnum:]" ?0 ?,)
- (Assert-char-class "[:alnum:]" ?9 ?$)
+ (Assert-char-class "[:alnum:]" ?9 ?\t)
(Assert-char-class "[:alnum:]" ?b ?\x00)
(Assert-char-class "[:alnum:]" ?c ?\x09)
(Assert-char-class "[:alnum:]" ?d ?\ )
＠＠ -724,13 +742,12 ＠＠
(decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA
(decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS
- ;; Word is equivalent to alnum in this implementation.
(Assert-char-class "[:word:]" ?a ?.)
(Assert-char-class "[:word:]" ?z ?')
(Assert-char-class "[:word:]" ?A ?/)
(Assert-char-class "[:word:]" ?Z ?!)
(Assert-char-class "[:word:]" ?0 ?,)
- (Assert-char-class "[:word:]" ?9 ?$)
+ (Assert-char-class "[:word:]" ?9 ?\t)
(Assert-char-class "[:word:]" ?b ?\x00)
(Assert-char-class "[:word:]" ?c ?\x09)
(Assert-char-class "[:word:]" ?d ?\ )
＠＠ -1083,7 +1100,7 ＠＠
(Assert-never-matching
"[:unibyte:]"
- ?\x01 ?\t ?A ?B ?C ?\x7f
+ ?\x80 ?\xe4 ?\xdf ?\xf8
(decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA
(decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A
(decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A
https://bitbucket.org/xemacs/xemacs/changeset/ddf56c45634e/
changeset: ddf56c45634e
user: kehoea
date: 2012-05-04 22:12:51
summary: Automated merge with file:///Sources/xemacs-21.5-checked-out
affected #: 8 files
diff -r cc6f0266bc367884f3d0d8cda3f82528935743ef -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 man/ChangeLog
--- a/man/ChangeLog
+++ b/man/ChangeLog
＠＠ -1,3 +1,11 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/searching.texi (Regular Expressions):
+ * lispref/searching.texi (Syntax of Regexps):
+ * lispref/searching.texi (Char Classes):
+ * lispref/searching.texi (Regexp Example):
+ Document the predefined character classes in this file.
+
2011-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.texi (Top):
diff -r cc6f0266bc367884f3d0d8cda3f82528935743ef -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 man/lispref/searching.texi
--- a/man/lispref/searching.texi
+++ b/man/lispref/searching.texi
＠＠ -180,6 +180,7 ＠＠
＠menu
* Syntax of Regexps:: Rules for writing regular expressions.
+* Char Classes:: Predefined character classes for searching.
* Regexp Example:: Illustrates regular expression syntax.
＠end menu
＠＠ -335,6 +336,11 ＠＠
To include ＠samp{^} in a set, put it anywhere but at the beginning of
the set.
+It is also possible to specify named character classes as part of your
+character set; for example, ＠samp{[:xdigit:]} will match hexadecimal
+digits, ＠samp{[:nonascii:]} will match characters outside the basic
+ASCII set. These are documented elsewhere, ＠pxref{Char Classes}.
+
＠item [^ ＠dots{} ]
＠cindex ＠samp{^} in regexp
＠samp{[^} begins a ＠dfn{complement character set}, which matches any
＠＠ -604,6 +610,61 ＠＠
＠end example
＠end defun
+＠node Char Classes
+＠subsection Char Classes
+
+These are the predefined character classes available within regular
+expression character sets, and within ＠samp{skip-chars-forward} and
+＠samp{skip-chars-backward}, ＠xref{Skipping Characters}.
+
+＠table ＠samp
+＠item [:alnum:]
+This matches any ASCII letter or digit, or any non-ASCII character
+with word syntax.
+＠item [:alpha:]
+This matches any ASCII letter, or any non-ASCII character with word syntax.
+＠item [:ascii:]
+This matches any character with a numeric value below ＠samp{?\x80}.
+＠item [:blank:]
+This matches space or tab.
+＠item [:cntrl:]
+This matches any character with a numeric value below ＠samp{?\x20},
+the code for space; these are the ASCII control characters.
+＠item [:digit:]
+This matches the characters ＠samp{?0} to ＠samp{?9}, inclusive.
+＠item [:graph:]
+This matches ``graphic'' characters, with numeric values greater than
+＠samp{?\x20}, exclusive of ＠samp{?\x7f}, the delete character.
+＠item [:lower:]
+This matches minuscule characters, or any character with case
+information if ＠samp{case-fold-search} is non-nil.
+＠item [:multibyte:]
+This matches non-ASCII characters, that is, any character with a
+numeric value above ＠samp{?\x7f}.
+＠item [:nonascii:]
+This is equivalent to ＠samp{[:multibyte:]}.
+＠item [:print:]
+This is equivalent to [:graph:], but also matches the space character,
+＠samp{?\x20}.
+＠item [:punct:]
+This matches non-control, non-alphanumeric ASCII characters, or any
+non-ASCII character without word syntax.
+＠item [:space:]
+This matches any character with whitespace syntax.
+＠item [:unibyte:]
+This is a GNU Emacs extension; in XEmacs it is equivalent to
+＠samp{[:ascii:]}. Note that this means it is not equivalent to
+＠samp{"\x00-\xff"}, which one might have assumed to be the case.
+＠item [:upper:]
+This matches majuscule characters, or any character with case
+information if ＠samp{case-fold-search} is non-nil.
+＠item [:word:]
+This matches any character with word syntax.
+＠item [:xdigit:]
+This matches hexadecimal digits, so the decimal digits ＠samp{0-9} and the
+letters ＠samp{a-F} and ＠samp{A-F}.
+＠end table
+
＠node Regexp Example
＠subsection Complex Regexp Example
diff -r cc6f0266bc367884f3d0d8cda3f82528935743ef -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 src/ChangeLog
--- a/src/ChangeLog
+++ b/src/ChangeLog
＠＠ -1,3 +1,19 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * regex.c:
+ Move various #defines and enums to regex.h, since we need them
+ when implementing #'skip-chars-{backward,forward}.
+ * regex.c (re_wctype):
+ * regex.c (re_iswctype):
+ Be more robust about case insensitivity here.
+ * regex.c (regex_compile):
+ * regex.h:
+ * regex.h (RE_ISWCTYPE_ARG_DECL):
+ * regex.h (CHAR_CLASS_MAX_LENGTH):
+ * search.c (skip_chars):
+ Implement support for the predefined character classes in this
+ function.
+
2012-04-25 Aidan Kehoe <kehoea(a)parhasard.net>
* search.c (string_match_1): Actually use the POSIX argument here,
diff -r cc6f0266bc367884f3d0d8cda3f82528935743ef -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 src/regex.c
--- a/src/regex.c
+++ b/src/regex.c
＠＠ -178,51 +178,7 ＠＠
/* isalpha etc. are used for the character classes. */
#include <ctype.h>
-#ifdef emacs
-
-/* 1 if C is an ASCII character. */
-#define ISASCII(c) ((c) < 0x80)
-
-/* 1 if C is a unibyte character. */
-#define ISUNIBYTE(c) 0
-
-/* The Emacs definitions should not be directly affected by locales. */
-
-/* In Emacs, these are only used for single-byte characters. */
-#define ISDIGIT(c) ((c) >= '0' && (c) <= '9')
-#define ISCNTRL(c) ((c) < ' ')
-#define ISXDIGIT(c) (ISDIGIT (c) || ((c) >= 'a' && (c) <= 'f') \
- || ((c) >= 'A' && (c) <= 'F'))
-
-/* This is only used for single-byte characters. */
-#define ISBLANK(c) ((c) == ' ' || (c) == '\t')
-
-/* The rest must handle multibyte characters. */
-
-#define ISGRAPH(c) ((c) > ' ' && (c) != 0x7f)
-#define ISPRINT(c) ((c) == ' ' || ISGRAPH (c))
-#define ISALPHA(c) (ISASCII (c) ? (((c) >= 'a' && (c) <= 'z') \
- || ((c) >= 'A' && (c) <= 'Z')) \
- : ISWORD (c))
-#define ISALNUM(c) (ISALPHA (c) || ISDIGIT (c))
-
-#define ISLOWER(c) LOWERCASEP (lispbuf, c)
-
-#define ISPUNCT(c) (ISASCII (c) \
- ? ((c) > ' ' && (c) < 0x7F \
- && !(((c) >= 'a' && (c) <= 'z') \
- || ((c) >= 'A' && (c) <= 'Z') \
- || ((c) >= '0' && (c) <= '9'))) \
- : !ISWORD (c))
-
-#define ISSPACE(c) \
- (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Swhitespace)
-
-#define ISUPPER(c) UPPERCASEP (lispbuf, c)
-
-#define ISWORD(c) (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Sword)
-
-#else /* not emacs */
+#ifndef emacs /* For the emacs build, we need these in the header. */
/* 1 if C is an ASCII character. */
#define ISASCII(c) ((c) < 0200)
＠＠ -2013,23 +1969,6 ＠＠
/* The next available element. */
#define COMPILE_STACK_TOP (compile_stack.stack[compile_stack.avail])
-/* Bits used to implement the multibyte-part of the various character
- classes such as [:alnum:] in a charset's range table. XEmacs; use an
- enum, so they're visible in the debugger. */
-enum
-{
- BIT_WORD = (1 << 0),
- BIT_LOWER = (1 << 1),
- BIT_PUNCT = (1 << 2),
- BIT_SPACE = (1 << 3),
- BIT_UPPER = (1 << 4),
- /* XEmacs; we need this, because we unify treatment of ASCII and non-ASCII
- (possible matches) in charset_mule. [:alpha:] matches all characters
- with word syntax, with the exception of [0-9]. We don't need
- BIT_MULTIBYTE. */
- BIT_ALPHA = (1 << 5)
-};
-
/* Set the bit for character C in a bit vector. */
#define SET_LIST_BIT(c) \
(buf_end[((unsigned char) (c)) / BYTEWIDTH] \
＠＠ -2059,10 +1998,8 ＠＠
} \
}
-#define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */
-
/* Map a string to the char class it names (if any). */
-static re_wctype_t
+re_wctype_t
re_wctype (const char *string)
{
if (STREQ (string, "alnum")) return RECC_ALNUM;
＠＠ -2086,17 +2023,10 ＠＠
}
/* True if CH is in the char class CC. */
-static re_bool
-re_iswctype (int ch, re_wctype_t cc)
+int
+re_iswctype (int ch, re_wctype_t cc
+ RE_ISWCTYPE_ARG_DECL)
{
-#ifdef emacs
- /* This is cheesy, lispbuf isn't available to us when compiling the
- pattern. It's effectively only called (on Mule builds) when the current
- buffer doesn't matter (e.g. for RECC_ASCII, RECC_CNTRL), so it's not a
- big deal. */
- struct buffer *lispbuf = current_buffer;
-#endif
-
switch (cc)
{
case RECC_ALNUM: return ISALNUM (ch) != 0;
＠＠ -2105,11 +2035,20 ＠＠
case RECC_CNTRL: return ISCNTRL (ch) != 0;
case RECC_DIGIT: return ISDIGIT (ch) != 0;
case RECC_GRAPH: return ISGRAPH (ch) != 0;
- case RECC_LOWER: return ISLOWER (ch) != 0;
case RECC_PRINT: return ISPRINT (ch) != 0;
case RECC_PUNCT: return ISPUNCT (ch) != 0;
case RECC_SPACE: return ISSPACE (ch) != 0;
+#ifdef emacs
+ case RECC_UPPER:
+ return NILP (lispbuf->case_fold_search) ? ISUPPER (ch) != 0
+: !NOCASEP (lispbuf, ch);
+ case RECC_LOWER:
+ return NILP (lispbuf->case_fold_search) ? ISLOWER (ch) != 0
+: !NOCASEP (lispbuf, ch);
+#else
case RECC_UPPER: return ISUPPER (ch) != 0;
+ case RECC_LOWER: return ISLOWER (ch) != 0;
+#endif
case RECC_XDIGIT: return ISXDIGIT (ch) != 0;
case RECC_ASCII: return ISASCII (ch) != 0;
case RECC_NONASCII: case RECC_MULTIBYTE: return !ISASCII (ch);
＠＠ -2140,6 +2079,10 ＠＠
}
}
+#endif /* MULE */
+
+#ifdef emacs
+
/* Return a bit-pattern to use in the range-table bits to match multibyte
chars of class CC. */
static unsigned char
＠＠ -2158,7 +2101,8 ＠＠
case RECC_ASCII: case RECC_DIGIT: case RECC_XDIGIT: case RECC_CNTRL:
case RECC_BLANK: case RECC_UNIBYTE: case RECC_ERROR: return 0;
default:
- abort ();
+ ABORT ();
+ return 0;
}
}
＠＠ -2185,9 +2129,12 ＠＠
RE_TRANSLATE_TYPE translate,
reg_syntax_t syntax,
Lisp_Object rtab);
-static reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
- Bitbyte *flags_out);
#endif /* MULE */
+#ifdef emacs
+reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
+ Bitbyte *flags_out);
+#endif
+
static re_bool group_match_null_string_p (unsigned char **p,
unsigned char *end,
register_info_type *reg_info);
＠＠ -2814,7 +2761,8 ＠＠
#endif /* MULE */
for (ch = 0; ch < (1 << BYTEWIDTH); ++ch)
{
- if (re_iswctype (ch, cc))
+ if (re_iswctype (ch, cc
+ RE_ISWCTYPE_ARG (current_buffer)))
{
SET_LIST_BIT (ch);
}
＠＠ -3938,7 +3886,11 ＠＠
return REG_NOERROR;
}
-static reg_errcode_t
+#endif /* MULE */
+
+#ifdef emacs
+
+reg_errcode_t
compile_char_class (re_wctype_t cc, Lisp_Object rtab, Bitbyte *flags_out)
{
*flags_out |= re_wctype_to_bit (cc);
diff -r cc6f0266bc367884f3d0d8cda3f82528935743ef -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 src/regex.h
--- a/src/regex.h
+++ b/src/regex.h
＠＠ -30,6 +30,8 ＠＠
#define RE_LISP_CONTEXT_ARGS_DECL , Lisp_Object lispobj, struct buffer *lispbuf, struct syntax_cache *scache
#define RE_LISP_CONTEXT_ARGS_MULE_DECL , Lisp_Object lispobj, struct buffer *USED_IF_MULE (lispbuf), struct syntax_cache *scache
#define RE_LISP_CONTEXT_ARGS , lispobj, lispbuf, scache
+#define RE_ISWCTYPE_ARG_DECL , struct buffer *lispbuf
+#define RE_ISWCTYPE_ARG(varname) , varname
#else
#define RE_TRANSLATE_TYPE char *
#define RE_LISP_SHORT_CONTEXT_ARGS_DECL
＠＠ -37,6 +39,8 ＠＠
#define RE_LISP_CONTEXT_ARGS_DECL
#define RE_LISP_CONTEXT_ARGS_MULE_DECL
#define RE_LISP_CONTEXT_ARGS
+#define RE_ISWCTYPE_ARG_DECL
+#define RE_ISWCTYPE_ARG(varname)
#define Elemcount ssize_t
#define Bytecount ssize_t
#endif /* emacs */
＠＠ -559,6 +563,86 ＠＠
RECC_ASCII, RECC_UNIBYTE
} re_wctype_t;
+#define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */
+
+/* Map a string to the char class it names (if any). */
+re_wctype_t re_wctype (const char *);
+
+/* Is character CH a member of the character class CC? */
+int re_iswctype (int ch, re_wctype_t cc RE_ISWCTYPE_ARG_DECL);
+
+/* Bits used to implement the multibyte-part of the various character
+ classes such as [:alnum:] in a charset's range table. XEmacs; use an
+ enum, so they're visible in the debugger. */
+enum
+{
+ BIT_WORD = (1 << 0),
+ BIT_LOWER = (1 << 1),
+ BIT_PUNCT = (1 << 2),
+ BIT_SPACE = (1 << 3),
+ BIT_UPPER = (1 << 4),
+ /* XEmacs; we need this, because we unify treatment of ASCII and non-ASCII
+ (possible matches) in charset_mule. [:alpha:] matches all characters
+ with word syntax, with the exception of [0-9]. We don't need
+ BIT_MULTIBYTE. */
+ BIT_ALPHA = (1 << 5)
+};
+
+#ifdef emacs
+reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
+ Bitbyte *flags_out);
+
+#endif
+
+/* isalpha etc. are used for the character classes. */
+#include <ctype.h>
+
+#ifdef emacs
+
+/* 1 if C is an ASCII character. */
+#define ISASCII(c) ((c) < 0x80)
+
+/* 1 if C is a unibyte character. */
+#define ISUNIBYTE ISASCII
+
+/* The Emacs definitions should not be directly affected by locales. */
+
+/* In Emacs, these are only used for single-byte characters. */
+#define ISDIGIT(c) ((c) >= '0' && (c) <= '9')
+#define ISCNTRL(c) ((c) < ' ')
+#define ISXDIGIT(c) (ISDIGIT (c) || ((c) >= 'a' && (c) <= 'f') \
+ || ((c) >= 'A' && (c) <= 'F'))
+
+/* This is only used for single-byte characters. */
+#define ISBLANK(c) ((c) == ' ' || (c) == '\t')
+
+/* The rest must handle multibyte characters. */
+
+#define ISGRAPH(c) ((c) > ' ' && (c) != 0x7f)
+#define ISPRINT(c) ((c) == ' ' || ISGRAPH (c))
+#define ISALPHA(c) (ISASCII (c) ? (((c) >= 'a' && (c) <= 'z') \
+ || ((c) >= 'A' && (c) <= 'Z')) \
+ : ISWORD (c))
+#define ISALNUM(c) (ISALPHA (c) || ISDIGIT (c))
+
+#define ISLOWER(c) LOWERCASEP (lispbuf, c)
+
+#define ISPUNCT(c) (ISASCII (c) \
+ ? ((c) > ' ' && (c) < 0x7F \
+ && !(((c) >= 'a' && (c) <= 'z') \
+ || ((c) >= 'A' && (c) <= 'Z') \
+ || ((c) >= '0' && (c) <= '9'))) \
+ : !ISWORD (c))
+
+#define ISSPACE(c) \
+ (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Swhitespace)
+
+#define ISUPPER(c) UPPERCASEP (lispbuf, c)
+
+#define ISWORD(c) (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Sword)
+
+#endif
+
END_C_DECLS
#endif /* INCLUDED_regex_h_ */
diff -r cc6f0266bc367884f3d0d8cda3f82528935743ef -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 src/search.c
--- a/src/search.c
+++ b/src/search.c
＠＠ -887,9 +887,9 ＠＠
a range table. */
unsigned char fastmap[0400];
int negate = 0;
- REGISTER int i;
Charbpos limit;
struct syntax_cache *scache;
+ Bitbyte class_bits = 0;
if (NILP (lim))
limit = forwardp ? BUF_ZV (buf) : BUF_BEGV (buf);
＠＠ -957,6 +957,51 ＠＠
Vskip_chars_range_table);
INC_IBYTEPTR (p);
}
+ else if ('[' == c && p != pend && *p == ':')
+ {
+ Ibyte *colonp;
+ Extbyte *classname;
+ int ch = 0;
+ re_wctype_t cc;
+
+ INC_IBYTEPTR (p);
+
+ if (p == pend)
+ {
+ fastmap ['['] = fastmap[':'] = 1;
+ break;
+ }
+
+ colonp = memchr (p, ':', pend - p);
+ if (NULL == colonp || (colonp + 1) == pend || colonp[1] != ']')
+ {
+ fastmap ['['] = fastmap[':'] = 1;
+ continue;
+ }
+
+ classname = alloca_extbytes (colonp - p + 1);
+ memmove (classname, p, colonp - p);
+ classname[colonp - p] = '\0';
+ cc = re_wctype (classname);
+
+ if (cc == RECC_ERROR)
+ {
+ invalid_argument ("Invalid character class",
+ build_extstring (classname, Qbinary));
+ }
+
+ for (ch = 0; ch < countof (fastmap); ++ch)
+ {
+ if (re_iswctype (ch, cc, buf))
+ {
+ fastmap[ch] = 1;
+ }
+ }
+
+ compile_char_class (cc, Vskip_chars_range_table, &class_bits);
+
+ p = colonp + 2;
+ }
else
{
if (c < 0400)
＠＠ -972,14 +1017,6 ＠＠
if (syntaxp && fastmap['-'] != 0)
fastmap[' '] = 1;
- /* If ^ was the first character, complement the fastmap.
- We don't complement the range table, however; we just use negate
- in the comparisons below. */
-
- if (negate)
- for (i = 0; i < (int) (sizeof (fastmap)); i++)
- fastmap[i] ^= 1;
-
{
Charbpos start_point = BUF_PT (buf);
Charbpos pos = start_point;
＠＠ -996,7 +1033,8 ＠＠
while (fastmap[(unsigned char)
syntax_code_spec
[(int) SYNTAX_FROM_CACHE
- (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]])
+ (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]]
+ != negate)
{
pos++;
INC_BYTEBPOS (buf, pos_byte);
＠＠ -1013,10 +1051,11 ＠＠
pos--;
DEC_BYTEBPOS (buf, pos_byte);
UPDATE_SYNTAX_CACHE_BACKWARD (scache, pos);
- if (!fastmap[(unsigned char)
- syntax_code_spec
- [(int) SYNTAX_FROM_CACHE
- (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]])
+ if (fastmap[(unsigned char)
+ syntax_code_spec
+ [(int) SYNTAX_FROM_CACHE
+ (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]]
+ == negate)
{
pos++;
pos_byte = savepos;
＠＠ -1027,16 +1066,30 ＠＠
}
else
{
+ struct buffer *lispbuf = buf;
+
+#define CLASS_BIT_CHECK(c) \
+ (class_bits && ((class_bits & BIT_ALPHA && ISALPHA (c)) \
+ || (class_bits & BIT_SPACE && ISSPACE (c)) \
+ || (class_bits & BIT_PUNCT && ISPUNCT (c)) \
+ || (class_bits & BIT_WORD && ISWORD (c)) \
+ || (NILP (buf->case_fold_search) ? \
+ ((class_bits & BIT_UPPER && ISUPPER (c)) \
+ || (class_bits & BIT_LOWER && ISLOWER (c))) \
+: (class_bits & (BIT_UPPER | BIT_LOWER) \
+ && !NOCASEP (buf, c)))))
if (forwardp)
{
while (pos < limit)
{
Ichar ch = BYTE_BUF_FETCH_CHAR (buf, pos_byte);
- if ((ch < 0400) ? fastmap[ch] :
- (NILP (Fget_range_table (make_fixnum (ch),
- Vskip_chars_range_table,
- Qnil))
- == negate))
+
+ if ((ch < countof (fastmap) ? fastmap[ch]
+: (CLASS_BIT_CHECK (ch) ||
+ (EQ (Qt, Fget_range_table (make_fixnum (ch),
+ Vskip_chars_range_table,
+ Qnil)))))
+ != negate)
{
pos++;
INC_BYTEBPOS (buf, pos_byte);
＠＠ -1054,11 +1107,12 ＠＠
DEC_BYTEBPOS (buf, prev_pos_byte);
ch = BYTE_BUF_FETCH_CHAR (buf, prev_pos_byte);
- if ((ch < 0400) ? fastmap[ch] :
- (NILP (Fget_range_table (make_fixnum (ch),
- Vskip_chars_range_table,
- Qnil))
- == negate))
+ if ((ch < countof (fastmap) ? fastmap[ch]
+: (CLASS_BIT_CHECK (ch) ||
+ (EQ (Qt, Fget_range_table (make_fixnum (ch),
+ Vskip_chars_range_table,
+ Qnil)))))
+ != negate)
{
pos--;
pos_byte = prev_pos_byte;
diff -r cc6f0266bc367884f3d0d8cda3f82528935743ef -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 tests/ChangeLog
--- a/tests/ChangeLog
+++ b/tests/ChangeLog
＠＠ -1,3 +1,11 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/regexp-tests.el (equal):
+ * automated/regexp-tests.el (Assert-char-class):
+ Correct a stray parenthesis; add tests for the predefined
+ character classes with #'skip-chars-{forward,backward}; update the
+ tests to reflect some changed design decisions on my part.
+
2012-04-25 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/regexp-tests.el: Check that #'posix-string-match
diff -r cc6f0266bc367884f3d0d8cda3f82528935743ef -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 tests/automated/regexp-tests.el
--- a/tests/automated/regexp-tests.el
+++ b/tests/automated/regexp-tests.el
＠＠ -76,7 +76,7 ＠＠
(save-match-data
(progn (posix-string-match "i\\|ii" "ii") (match-data)))
'(0 2))
- "checking #'posix-string-match actually returns the longest match"))
+ "checking #'posix-string-match actually returns the longest match")
;; looking-at
(with-temp-buffer
＠＠ -665,7 +665,25 ＠＠
(Assert (null (string-match ,(concat "[^" class
(string non-matching-char) "]")
,(concat (string matching-char)
- (string non-matching-char)))))))
+ (string non-matching-char)))))
+ (let ((old-case-fold-search case-fold-search))
+ (with-temp-buffer
+ (setq case-fold-search old-case-fold-search)
+ (insert-char ,matching-char 20)
+ (insert-char ,non-matching-char 20)
+ (goto-char (point-min))
+ (Assert (eql (skip-chars-forward ,class) 20)
+ ,(format "making sure %s skips %S forward"
+ class matching-char))
+ (Assert (eql (skip-chars-forward ,(concat "^" class)) 20)
+ ,(format "making sure ^%s skips %S forward"
+ class non-matching-char))
+ (Assert (eql (skip-chars-backward ,(concat "^" class)) -20)
+ ,(format "making sure ^%s skips %S backward"
+ class non-matching-char))
+ (Assert (eql (skip-chars-backward ,class) -20)
+ ,(format "making sure %s skips %S backward"
+ class matching-char))))))
(Assert-never-matching (class &rest characters)
(cons
'progn
＠＠ -706,7 +724,7 ＠＠
(Assert-char-class "[:alnum:]" ?A ?/)
(Assert-char-class "[:alnum:]" ?Z ?!)
(Assert-char-class "[:alnum:]" ?0 ?,)
- (Assert-char-class "[:alnum:]" ?9 ?$)
+ (Assert-char-class "[:alnum:]" ?9 ?\t)
(Assert-char-class "[:alnum:]" ?b ?\x00)
(Assert-char-class "[:alnum:]" ?c ?\x09)
(Assert-char-class "[:alnum:]" ?d ?\ )
＠＠ -724,13 +742,12 ＠＠
(decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA
(decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS
- ;; Word is equivalent to alnum in this implementation.
(Assert-char-class "[:word:]" ?a ?.)
(Assert-char-class "[:word:]" ?z ?')
(Assert-char-class "[:word:]" ?A ?/)
(Assert-char-class "[:word:]" ?Z ?!)
(Assert-char-class "[:word:]" ?0 ?,)
- (Assert-char-class "[:word:]" ?9 ?$)
+ (Assert-char-class "[:word:]" ?9 ?\t)
(Assert-char-class "[:word:]" ?b ?\x00)
(Assert-char-class "[:word:]" ?c ?\x09)
(Assert-char-class "[:word:]" ?d ?\ )
＠＠ -1083,7 +1100,7 ＠＠
(Assert-never-matching
"[:unibyte:]"
- ?\x01 ?\t ?A ?B ?C ?\x7f
+ ?\x80 ?\xe4 ?\xdf ?\xf8
(decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA
(decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A
(decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
12 years, 8 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1335885462 -3600
# Node ID cc6f0266bc367884f3d0d8cda3f82528935743ef
# Parent ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
lisp/ChangeLog addition:
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
Avoid #'delq in core code, for the sake of style and a (very
slightly) smaller binary.
* behavior.el (disable-behavior):
* behavior.el (compute-behavior-group-children):
* buff-menu.el (buffers-tab-items):
* byte-optimize.el (byte-optimize-delay-constants-math):
* byte-optimize.el (byte-optimize-logmumble):
* byte-optimize.el (byte-decompile-bytecode-1):
* byte-optimize.el (byte-optimize-lapcode):
* bytecomp.el:
* bytecomp.el (byte-compile-arglist-warn):
* bytecomp.el (byte-compile-warn-about-unresolved-functions):
* bytecomp.el (byte-compile-lambda):
* bytecomp.el (byte-compile-out-toplevel):
* bytecomp.el (byte-compile-insert):
* bytecomp.el (byte-compile-defalias-warn):
* cl-macs.el (cl-upcase-arg):
* cl-macs.el (cl-transform-lambda):
* cl-macs.el (cl-do-proclaim):
* cl-macs.el (defstruct):
* cl-macs.el (cl-make-type-test):
* cl-macs.el (define-compiler-macro):
* cl-macs.el (delete-duplicates):
* cus-edit.el (widget-face-value-delete):
* cus-edit.el (face-history):
* easymenu.el (easy-menu-remove):
* files.el (files-fetch-hook-value):
* files.el (file-expand-wildcards):
* font-lock.el (font-lock-update-removed-keyword-alist):
* font-lock.el (font-lock-remove-keywords):
* frame.el (frame-initialize):
* frame.el (frame-notice-user-settings):
* frame.el (set-frame-font):
* frame.el (delete-other-frames):
* frame.el (get-frame-for-buffer-noselect):
* gnuserv.el (gnuserv-kill-buffer-function):
* gnuserv.el (gnuserv-check-device):
* gnuserv.el (gnuserv-kill-client):
* gnuserv.el (gnuserv-buffer-done-1):
* gtk-font-menu.el (gtk-reset-device-font-menus):
* gutter-items.el (buffers-tab-items):
* gutter.el (set-gutter-element-visible-p):
* info.el (Info-find-file-node):
* info.el (Info-history-add):
* info.el (Info-build-annotation-completions):
* info.el (Info-index):
* info.el (Info-reannotate-node):
* itimer.el (delete-itimer):
* itimer.el (start-itimer):
* lib-complete.el (lib-complete:cache-completions):
* loadhist.el (unload-feature):
* menubar-items.el (build-buffers-menu-internal):
* menubar.el (delete-menu-item):
* menubar.el (relabel-menu-item):
* msw-font-menu.el (mswindows-reset-device-font-menus):
* mule/make-coding-system.el (fixed-width-generate-helper):
* next-error.el (next-error-find-buffer):
* obsolete.el:
* obsolete.el (find-non-ascii-charset-string):
* obsolete.el (find-non-ascii-charset-region):
* occur.el (multi-occur-by-filename-regexp):
* occur.el (occur-1):
* packages.el (packages-package-hierarchy-directory-names):
* packages.el (package-get-key-1):
* process.el (setenv):
* simple.el (undo):
* simple.el (handle-pre-motion-command-current-command-is-motion):
* sound.el (load-sound-file):
* wid-edit.el (widget-field-value-delete):
* wid-edit.el (widget-checklist-match-inline):
* wid-edit.el (widget-checklist-match-find):
* wid-edit.el (widget-editable-list-delete-at):
* wid-edit.el (widget-editable-list-entry-create):
* window.el (quit-window):
* x-font-menu.el (x-reset-device-font-menus-core):
1. Replace (delq nil (mapcar ....)) with analogous (mapcan ...)
forms; this is in non-dumped files, it was done previously in
dumped files.
2. Replace (delq FOO (copy-sequence BAR)) with (remove* FOO BAR),
where #'eq and #'eql are equivalent
3. Replace (delq FOO BAR) with (delete* FOO BAR), where FOO is not
a non-fixnum number. Saves a little space in the dumped file
(since the compiler macro adds :test #'eq to the delete* call if
it's not clear that FOO is not a non-fixnum number).
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/ChangeLog
--- a/lisp/ChangeLog Tue May 01 12:43:22 2012 +0100
+++ b/lisp/ChangeLog Tue May 01 16:17:42 2012 +0100
＠＠ -1,3 +1,92 ＠＠
+2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Avoid #'delq in core code, for the sake of style and a (very
+ slightly) smaller binary.
+
+ * behavior.el (disable-behavior):
+ * behavior.el (compute-behavior-group-children):
+ * buff-menu.el (buffers-tab-items):
+ * byte-optimize.el (byte-optimize-delay-constants-math):
+ * byte-optimize.el (byte-optimize-logmumble):
+ * byte-optimize.el (byte-decompile-bytecode-1):
+ * byte-optimize.el (byte-optimize-lapcode):
+ * bytecomp.el:
+ * bytecomp.el (byte-compile-arglist-warn):
+ * bytecomp.el (byte-compile-warn-about-unresolved-functions):
+ * bytecomp.el (byte-compile-lambda):
+ * bytecomp.el (byte-compile-out-toplevel):
+ * bytecomp.el (byte-compile-insert):
+ * bytecomp.el (byte-compile-defalias-warn):
+ * cl-macs.el (cl-upcase-arg):
+ * cl-macs.el (cl-transform-lambda):
+ * cl-macs.el (cl-do-proclaim):
+ * cl-macs.el (defstruct):
+ * cl-macs.el (cl-make-type-test):
+ * cl-macs.el (define-compiler-macro):
+ * cl-macs.el (delete-duplicates):
+ * cus-edit.el (widget-face-value-delete):
+ * cus-edit.el (face-history):
+ * easymenu.el (easy-menu-remove):
+ * files.el (files-fetch-hook-value):
+ * files.el (file-expand-wildcards):
+ * font-lock.el (font-lock-update-removed-keyword-alist):
+ * font-lock.el (font-lock-remove-keywords):
+ * frame.el (frame-initialize):
+ * frame.el (frame-notice-user-settings):
+ * frame.el (set-frame-font):
+ * frame.el (delete-other-frames):
+ * frame.el (get-frame-for-buffer-noselect):
+ * gnuserv.el (gnuserv-kill-buffer-function):
+ * gnuserv.el (gnuserv-check-device):
+ * gnuserv.el (gnuserv-kill-client):
+ * gnuserv.el (gnuserv-buffer-done-1):
+ * gtk-font-menu.el (gtk-reset-device-font-menus):
+ * gutter-items.el (buffers-tab-items):
+ * gutter.el (set-gutter-element-visible-p):
+ * info.el (Info-find-file-node):
+ * info.el (Info-history-add):
+ * info.el (Info-build-annotation-completions):
+ * info.el (Info-index):
+ * info.el (Info-reannotate-node):
+ * itimer.el (delete-itimer):
+ * itimer.el (start-itimer):
+ * lib-complete.el (lib-complete:cache-completions):
+ * loadhist.el (unload-feature):
+ * menubar-items.el (build-buffers-menu-internal):
+ * menubar.el (delete-menu-item):
+ * menubar.el (relabel-menu-item):
+ * msw-font-menu.el (mswindows-reset-device-font-menus):
+ * mule/make-coding-system.el (fixed-width-generate-helper):
+ * next-error.el (next-error-find-buffer):
+ * obsolete.el:
+ * obsolete.el (find-non-ascii-charset-string):
+ * obsolete.el (find-non-ascii-charset-region):
+ * occur.el (multi-occur-by-filename-regexp):
+ * occur.el (occur-1):
+ * packages.el (packages-package-hierarchy-directory-names):
+ * packages.el (package-get-key-1):
+ * process.el (setenv):
+ * simple.el (undo):
+ * simple.el (handle-pre-motion-command-current-command-is-motion):
+ * sound.el (load-sound-file):
+ * wid-edit.el (widget-field-value-delete):
+ * wid-edit.el (widget-checklist-match-inline):
+ * wid-edit.el (widget-checklist-match-find):
+ * wid-edit.el (widget-editable-list-delete-at):
+ * wid-edit.el (widget-editable-list-entry-create):
+ * window.el (quit-window):
+ * x-font-menu.el (x-reset-device-font-menus-core):
+
+ 1. Replace (delq nil (mapcar ....)) with analogous (mapcan ...)
+ forms; this is in non-dumped files, it was done previously in
+ dumped files.
+ 2. Replace (delq FOO (copy-sequence BAR)) with (remove* FOO BAR),
+ where #'eq and #'eql are equivalent
+ 3. Replace (delq FOO BAR) with (delete* FOO BAR), where FOO is not
+ a non-fixnum number. Saves a little space in the dumped file
+ (since the compiler macro adds :test #'eq to the delete* call if
+ it's not clear that FOO is not a non-fixnum number).
+
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/behavior.el
--- a/lisp/behavior.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/behavior.el Tue May 01 16:17:42 2012 +0100
＠＠ -403,7 +403,7 ＠＠
(message "Disabling behavior %s...done" behavior)
(let ((within-behavior-enabling-disabling t))
(customize-set-variable 'enabled-behavior-list
- (delq behavior enabled-behavior-list))))))
+ (delete* behavior enabled-behavior-list))))))
(defun compute-behavior-group-children (group hash)
"Compute the actual children for GROUP and its subgroups.
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/buff-menu.el
--- a/lisp/buff-menu.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/buff-menu.el Tue May 01 16:17:42 2012 +0100
＠＠ -860,10 +860,10 ＠＠
(not in-deletion)
(not (eq first-buf (window-buffer (selected-window frame)))))
(setq buffers (cons (window-buffer (selected-window frame))
- (delq first-buf buffers))))
+ (delete* first-buf buffers))))
;; if we're in deletion ignore the current buffer
(when in-deletion
- (setq buffers (delq (current-buffer) buffers))
+ (setq buffers (delete* (current-buffer) buffers))
(setq first-buf (car buffers)))
;; filter buffers
(when buffers-tab-filter-functions
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/byte-optimize.el Tue May 01 16:17:42 2012 +0100
＠＠ -710,7 +710,7 ＠＠
(apply fun (mapcar 'float constants))
(float (apply fun constants)))))
(setq form orig)
- (setq form (nconc (delq nil form)
+ (setq form (nconc (delete* nil form)
(list (apply fun (nreverse constants)))))))))
form))
＠＠ -787,7 +787,7 ＠＠
(cond ((memq 0 form)
(setq form (if (eq (car form) 'logand)
(cons 'progn (cdr form))
- (delq 0 (copy-sequence form)))))
+ (remove* 0 form))))
((and (eq (car-safe form) 'logior)
(memq -1 form))
(cons 'progn (cdr form)))
＠＠ -1462,7 +1462,7 ＠＠
;; this addr is jumped to
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
- (setq tags (delq tmp tags))
+ (setq tags (delete* tmp tags))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
＠＠ -1591,11 +1591,11 ＠＠
(cond ((= tmp 1)
(byte-compile-log-lap
" %s discard\t-->\t<deleted>" lap0)
- (setq lap (delq lap0 (delq lap1 lap))))
+ (setq lap (delete* lap0 (delete* lap1 lap))))
((= tmp 0)
(byte-compile-log-lap
" %s discard\t-->\t<deleted> discard" lap0)
- (setq lap (delq lap0 lap)))
+ (setq lap (delete* lap0 lap)))
((= tmp -1)
(byte-compile-log-lap
" %s discard\t-->\tdiscard discard" lap0)
＠＠ -1608,7 +1608,7 ＠＠
((and (memq (car lap0) byte-goto-ops)
(eq (cdr lap0) lap1))
(cond ((eq (car lap0) 'byte-goto)
- (setq lap (delq lap0 lap))
+ (setq lap (delete* lap0 lap))
(setq tmp "<deleted>"))
((memq (car lap0) byte-goto-always-pop-ops)
(setcar lap0 (setq tmp 'byte-discard))
＠＠ -1665,7 +1665,7 ＠＠
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
(setq keep-going t
rest (cdr rest))
- (setq lap (delq lap0 (delq lap2 lap))))
+ (setq lap (delete* lap0 (delete* lap2 lap))))
;;
;; not goto-X-if-nil --> goto-X-if-non-nil
;; not goto-X-if-non-nil --> goto-X-if-nil
＠＠ -1685,7 +1685,7 ＠＠
(setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
'byte-goto-if-not-nil
'byte-goto-if-nil))
- (setq lap (delq lap0 lap))
+ (setq lap (delete* lap0 lap))
(setq keep-going t))
;;
;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
＠＠ -1702,7 +1702,7 ＠＠
(byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
lap0 lap1 lap2
(cons inverse (cdr lap1)) lap2)
- (setq lap (delq lap0 lap))
+ (setq lap (delete* lap0 lap))
(setcar lap1 inverse)
(setq keep-going t)))
;;
＠＠ -1717,13 +1717,13 ＠＠
(byte-compile-log-lap " %s %s\t-->\t<deleted>"
lap0 lap1)
(setq rest (cdr rest)
- lap (delq lap0 (delq lap1 lap))))
+ lap (delete* lap0 (delete* lap1 lap))))
(t
(if (memq (car lap1) byte-goto-always-pop-ops)
(progn
(byte-compile-log-lap " %s %s\t-->\t%s"
lap0 lap1 (cons 'byte-goto (cdr lap1)))
- (setq lap (delq lap0 lap)))
+ (setq lap (delete* lap0 lap)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
(cons 'byte-goto (cdr lap1))))
(setcar lap1 'byte-goto)))
＠＠ -1768,7 +1768,7 ＠＠
(while (setq tmp2 (rassq lap0 tmp3))
(setcdr tmp2 lap1)
(setq tmp3 (cdr (memq tmp2 tmp3))))
- (setq lap (delq lap0 lap)
+ (setq lap (delete* lap0 lap)
keep-going t))
;;
;; unused-TAG: --> <deleted>
＠＠ -1777,7 +1777,7 ＠＠
(not (rassq lap0 lap)))
(and (memq byte-optimize-log '(t byte))
(byte-compile-log " unused tag %d removed" (nth 1 lap0)))
- (setq lap (delq lap0 lap)
+ (setq lap (delete* lap0 lap)
keep-going t))
;;
;; goto ... --> goto <delete until TAG or end>
＠＠ -1832,10 +1832,10 ＠＠
byte-save-restriction))
(< 0 (cdr lap1)))
(if (zerop (setcdr lap1 (1- (cdr lap1))))
- (delq lap1 rest))
+ (delete* lap1 rest))
(if (eq (car lap0) 'byte-varbind)
(setcar rest (cons 'byte-discard 0))
- (setq lap (delq lap0 lap)))
+ (setq lap (delete* lap0 lap)))
(byte-compile-log-lap " %s %s\t-->\t%s %s"
lap0 (cons (car lap1) (1+ (cdr lap1)))
(if (eq (car lap0) 'byte-varbind)
＠＠ -1922,7 +1922,7 ＠＠
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))))
+ (setq lap (delete* lap0 lap))))
(setq keep-going t))
;;
;; X: varref-Y ... varset-Y goto-X -->
＠＠ -2058,7 +2058,7 ＠＠
(cons 'byte-unbind
(+ (cdr lap0) (cdr lap1))))
(setq keep-going t)
- (setq lap (delq lap0 lap))
+ (setq lap (delete* lap0 lap))
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
)
(setq rest (cdr rest)))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/bytecomp.el
--- a/lisp/bytecomp.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/bytecomp.el Tue May 01 16:17:42 2012 +0100
＠＠ -1488,7 +1488,7 ＠＠
(byte-compile-arglist-signature-string (cons min max))))
(setq byte-compile-unresolved-functions
- (delq calls byte-compile-unresolved-functions)))))
+ (delete* calls byte-compile-unresolved-functions)))))
)))
;; If we have compiled any calls to functions which are not known to be
＠＠ -1503,7 +1503,7 ＠＠
(while rest
(if (assq (car (car rest)) byte-compile-autoload-environment)
(setq byte-compile-unresolved-functions
- (delq (car rest) byte-compile-unresolved-functions)))
+ (delete* (car rest) byte-compile-unresolved-functions)))
(setq rest (cdr rest)))))
;; Now warn.
(if (cdr byte-compile-unresolved-functions)
＠＠ -2757,8 +2757,7 ＠＠
(let ((new-bindings
(mapcar #'(lambda (x) (cons x byte-compile-arglist-bit))
(and (memq 'free-vars byte-compile-warnings)
- (delq '&rest (delq '&optional
- (copy-sequence arglist)))))))
+ (remove* '&rest (remove* '&optional arglist))))))
(nconc new-bindings
(cons 'new-scope byte-compile-bound-variables))))
(body (cdr (cdr fun)))
＠＠ -2963,7 +2962,7 ＠＠
(cons (nth 1 (car body)) (cdr body))
(cons tmp body))))
(or (eq output-type 'file)
- (not (delq nil (mapcar 'consp (cdr (car body))))))))
+ (notany #'consp (cdar body)))))
(setq rest (cdr rest)))
rest))
(let ((byte-compile-vector (byte-compile-constants-vector)))
＠＠ -3814,7 +3813,7 ＠＠
(if (cdr (cdr form))
(byte-compile-out 'byte-insertN (length (cdr form)))
(byte-compile-out 'byte-insert 0)))
- ((memq t (mapcar 'consp (cdr (cdr form))))
+ ((some #'consp (cddr form))
(byte-compile-normal-call form))
;; We can split it; there is no function call after inserting 1st arg.
(t
＠＠ -4669,7 +4668,7 ＠＠
(let ((calls (assq new byte-compile-unresolved-functions)))
(if calls
(setq byte-compile-unresolved-functions
- (delq calls byte-compile-unresolved-functions)))))
+ (delete* calls byte-compile-unresolved-functions)))))
;;; tags
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/cl-macs.el
--- a/lisp/cl-macs.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/cl-macs.el Tue May 01 16:17:42 2012 +0100
＠＠ -299,9 +299,9 ＠＠
;; Clean the list
(let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(if (setq junk (cadr (memq '&cl-defs arg)))
- (setq arg (delq '&cl-defs (delq junk arg))))
+ (setq arg (delete* '&cl-defs (delete* junk arg))))
(if (memq '&cl-quote arg)
- (setq arg (delq '&cl-quote arg)))
+ (setq arg (delete* '&cl-quote arg)))
(mapcar 'cl-upcase-arg arg)))
(t arg))) ; Maybe we are in initializer
＠＠ -346,13 +346,13 ＠＠
(setq args (if (listp args) (copy-list args) (list '&rest args)))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(if (setq bind-defs (cadr (memq '&cl-defs args)))
- (setq args (delq '&cl-defs (delq bind-defs args))
+ (setq args (delete* '&cl-defs (delete* bind-defs args))
bind-defs (cadr bind-defs)))
(if (setq bind-enquote (memq '&cl-quote args))
- (setq args (delq '&cl-quote args)))
+ (setq args (delete* '&cl-quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
(let* ((p (memq '&environment args)) (v (cadr p)))
- (if p (setq args (nconc (delq (car p) (delq v args))
+ (if p (setq args (nconc (delete* (car p) (delete* v args))
`(&aux (,v byte-compile-macro-environment))))))
(while (and args (symbolp (car args))
(not (memq (car args) '(nil &rest &body &key &aux)))
＠＠ -1916,7 +1916,7 ＠＠
(if (consp (car spec))
(if (eq (cadar spec) 0)
(setq byte-compile-warnings
- (delq (caar spec) byte-compile-warnings))
+ (delete* (caar spec) byte-compile-warnings))
(setq byte-compile-warnings
(adjoin (caar spec) byte-compile-warnings)))))))
nil)
＠＠ -2806,7 +2806,7 ＠＠
(caar include-descs) include))
old-descs)
(pop include-descs)))
- (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
+ (setq descs (append old-descs (delete* (assq 'cl-tag-slot descs) descs))
type (car inc-type)
named (assq 'cl-tag-slot descs))
(if (cadr inc-type) (setq tag name named t))
＠＠ -2822,7 +2822,7 ＠＠
(error "Illegal :type specifier: %s" type))
(if named (setq tag name)))
(setq type 'vector named 'true)))
- (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
+ (or named (setq descs (delete* (assq 'cl-tag-slot descs) descs)))
(push (list 'defvar tag-symbol) forms)
(setq pred-form (and named
(let ((pos (- (length descs)
＠＠ -2896,8 +2896,8 ＠＠
(push (cons copier t) side-eff)))
(if constructor
(push (list constructor
- (cons '&key (delq nil (copy-sequence slots))))
- constrs))
+ (cons '&key (remove* nil slots)))
+ constrs))
(while constrs
(let* ((name (caar constrs))
(args (cadr (pop constrs)))
＠＠ -2988,7 +2988,7 ＠＠
(cl-make-type-test val (apply (get (car type) 'cl-deftype-handler)
(cdr type))))
((memq (car-safe type) '(integer float real number))
- (delq t (list 'and (cl-make-type-test val (car type))
+ (delete* t (list 'and (cl-make-type-test val (car type))
(if (memq (cadr type) '(* nil)) t
(if (consp (cadr type)) (list '> val (caadr type))
(list '>= val (cadr type))))
＠＠ -3086,7 +3086,7 ＠＠
(list 'eval-when '(compile load eval)
(cl-transform-function-property
func 'cl-compiler-macro
- (cons (if (memq '&whole args) (delq '&whole args)
+ (cons (if (memq '&whole args) (delete* '&whole args)
(cons '--cl-whole-arg-- args)) body))
(list 'or (list 'get (list 'quote func) '(quote byte-compile))
(list 'put (list 'quote func) '(quote byte-compile)
＠＠ -3519,7 +3519,7 ＠＠
(cl-seq begin))
(while cl-seq
(setq cl-seq (setcdr cl-seq
- (delq (car cl-seq) (cdr cl-seq)))))
+ (delete* (car cl-seq) (cdr cl-seq)))))
begin))
((or (plists-equal cl-keys '(:test 'equal) t)
(plists-equal cl-keys '(:test #'equal) t))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/cus-edit.el
--- a/lisp/cus-edit.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/cus-edit.el Tue May 01 16:17:42 2012 +0100
＠＠ -2964,7 +2964,7 ＠＠
(defun widget-face-value-delete (widget)
;; Remove the child from the options.
(let ((child (car (widget-get widget :children))))
- (setq custom-options (delq child custom-options))
+ (setq custom-options (delete* child custom-options))
(widget-children-value-delete widget)))
(defvar face-history nil
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/easymenu.el
--- a/lisp/easymenu.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/easymenu.el Tue May 01 16:17:42 2012 +0100
＠＠ -223,7 +223,7 ＠＠
(when (featurep 'menubar)
(setq
;; Remove this menu from the list of popups we know about.
- easy-menu-all-popups (delq menu easy-menu-all-popups)
+ easy-menu-all-popups (delete* menu easy-menu-all-popups)
;; If there are multiple popup menus available, make the popup menu
;; normally shown with button-3 a menu of them. If there is just one,
;; make that button show it, and no super-menu.
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/files.el
--- a/lisp/files.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/files.el Tue May 01 16:17:42 2012 +0100
＠＠ -2838,7 +2838,7 ＠＠
(let ((localval (copy-list (symbol-value hook)))
(globalval (copy-list (default-value hook))))
(if (memq t localval)
- (setq localval (append (delq t localval) (delq t globalval))))
+ (setq localval (append (delete* t localval) (delete* t globalval))))
localval))
(defun basic-save-buffer ()
＠＠ -4065,13 +4065,9 ＠＠
(file-directory-p (directory-file-name (car dirs))))
(let ((this-dir-contents
;; Filter out "." and ".."
- (delq nil
- (mapcar #'(lambda (name)
- (unless (string-match "\\`\\.\\.?\\'"
- (file-name-nondirectory name))
- name))
- (directory-files (or (car dirs) ".") full
- (wildcard-to-regexp nondir))))))
+ (nset-difference (directory-files (or (car dirs) ".") full
+ (wildcard-to-regexp nondir))
+ '("." "..") :test #'equal)))
(setq contents
(nconc
(if (and (car dirs) (not full))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/font-lock.el
--- a/lisp/font-lock.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/font-lock.el Tue May 01 16:17:42 2012 +0100
＠＠ -987,14 +987,14 ＠＠
;; A new set of keywords is defined. Forget all about
;; our old keywords that should be removed.
(setq font-lock-removed-keywords-alist
- (delq cell font-lock-removed-keywords-alist))
+ (delete* cell font-lock-removed-keywords-alist))
;; Delete all previously removed keywords.
(dolist (kword keywords)
(setcdr cell (delete kword (cdr cell))))
;; Delete the mode cell if empty.
(if (null (cdr cell))
(setq font-lock-removed-keywords-alist
- (delq cell font-lock-removed-keywords-alist)))))))
+ (delete* cell font-lock-removed-keywords-alist)))))))
;; Written by Anders Lindgren <andersl(a)andersl.com>.
;;
＠＠ -1053,7 +1053,7 ＠＠
;; was deleted.
(if (null (cdr top-cell))
(setq font-lock-keywords-alist
- (delq top-cell font-lock-keywords-alist))))
+ (delete* top-cell font-lock-keywords-alist))))
;; Remember the keyword in case it is not local.
(let ((cell (assq mode font-lock-removed-keywords-alist)))
(if cell
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/frame.el
--- a/lisp/frame.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/frame.el Tue May 01 16:17:42 2012 +0100
＠＠ -218,7 +218,7 ＠＠
;; frame, then we need to create the opening frame. Make sure
;; it has a minibuffer, but let initial-frame-plist omit the
;; minibuffer spec.
- (or (delq terminal-frame (minibuffer-frame-list))
+ (or (delete* terminal-frame (minibuffer-frame-list))
(progn
(setq frame-initial-frame-plist
(append initial-frame-plist default-frame-plist))
＠＠ -230,8 +230,8 ＠＠
(setq default-minibuffer-frame
(setq frame-initial-frame
(make-frame initial-frame-plist
- (car (delq terminal-device
- (device-list))))))
+ (car (delete* terminal-device
+ (device-list))))))
;; Delete any specifications for window geometry properties
;; so that we won't reapply them in frame-notice-user-settings.
;; It would be wrong to reapply them then,
＠＠ -465,7 +465,7 ＠＠
;; The initial frame, which we are about to delete, may be
;; the only frame with a minibuffer. If it is, create a
;; new one.
- (or (delq frame-initial-frame (minibuffer-frame-list))
+ (or (delete* frame-initial-frame (minibuffer-frame-list))
(make-initial-minibuffer-frame nil))
;; If the initial frame is serving as a surrogate
＠＠ -991,7 +991,7 ＠＠
(face-list-to-change (face-list)))
(when (eq (device-type) 'mswindows)
(setq face-list-to-change
- (delq 'border-glyph face-list-to-change)))
+ (delete* 'border-glyph face-list-to-change)))
;; FIXME: Is it sufficient to just change the default face, due to
;; face inheritance?
(dolist (face face-list-to-change)
＠＠ -1325,7 +1325,7 ＠＠
(unless frame
(setq frame (selected-frame)))
(let* ((mini-frame (window-frame (minibuffer-window frame)))
- (frames (delq mini-frame (delq frame (frame-list)))))
+ (frames (delete* mini-frame (delete* frame (frame-list)))))
(mapc 'delete-frame frames)))
;; XEmacs change: we still use delete-frame-hook
＠＠ -1699,7 +1699,7 ＠＠
;; but the selected frame should come first, even if it's occluded,
;; to minimize thrashing.
(setq frames (cons (selected-frame)
- (delq (selected-frame) frames)))
+ (delete* (selected-frame) frames)))
(setq name (symbol-name name))
(while frames
＠＠ -1760,7 +1760,7 ＠＠
(t))))))
;; put the selected frame last. The user wants a new frame,
;; so don't reuse the existing one unless forced to.
- (setq frames (append (delq (selected-frame) frames) (list frames)))
+ (setq frames (append (delete* (selected-frame) frames) (list frames)))
(if (or (eq limit 0) ; means create with reckless abandon
(< (length frames) limit))
(get-frame-for-buffer-make-new-frame buffer)
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/gnuserv.el
--- a/lisp/gnuserv.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/gnuserv.el Tue May 01 16:17:42 2012 +0100
＠＠ -551,7 +551,7 ＠＠
editing has ended."
(let* ((buf (current-buffer)))
(dolist (client (gnuserv-buffer-clients buf))
- (callf2 delq buf (gnuclient-buffers client))
+ (callf2 delete* buf (gnuclient-buffers client))
;; If no more buffers, kill the client.
(when (null (gnuclient-buffers client))
(gnuserv-kill-client client)))))
＠＠ -588,7 +588,7 ＠＠
;; killing the device, because it would cause a device-dead
;; error when `delete-device' tries to do the job later.
(gnuserv-kill-client client t))))
- (callf2 delq device gnuserv-devices))
+ (callf2 delete* device gnuserv-devices))
(add-hook 'delete-device-hook 'gnuserv-check-device)
＠＠ -608,7 +608,7 ＠＠
the function will not remove the frames associated with the client."
;; Order is important: first delete client from gnuserv-clients, to
;; prevent gnuserv-buffer-done-1 calling us recursively.
- (callf2 delq client gnuserv-clients)
+ (callf2 delete* client gnuserv-clients)
;; Process the buffers.
(mapc 'gnuserv-buffer-done-1 (gnuclient-buffers client))
(unless leave-frame
＠＠ -636,7 +636,7 ＠＠
;; Do away with the buffer.
(defun gnuserv-buffer-done-1 (buffer)
(dolist (client (gnuserv-buffer-clients buffer))
- (callf2 delq buffer (gnuclient-buffers client))
+ (callf2 delete* buffer (gnuclient-buffers client))
(when (null (gnuclient-buffers client))
(gnuserv-kill-client client)))
;; Get rid of the buffer.
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/gtk-font-menu.el
--- a/lisp/gtk-font-menu.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/gtk-font-menu.el Tue May 01 16:17:42 2012 +0100
＠＠ -146,7 +146,7 ＠＠
done)
(setq sizes (cons (car common) sizes)))
(setq common (cdr common)))
- (setq sizes (delq 0 sizes))))
+ (setq sizes (delete* 0 sizes))))
(setq families (sort families 'string-lessp)
weights (sort weights 'string-lessp)
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/gutter-items.el
--- a/lisp/gutter-items.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/gutter-items.el Tue May 01 16:17:42 2012 +0100
＠＠ -270,10 +270,10 ＠＠
(not in-deletion)
(not (eq first-buf (window-buffer (selected-window frame)))))
(setq buffers (cons (window-buffer (selected-window frame))
- (delq first-buf buffers))))
+ (delete* first-buf buffers))))
;; if we're in deletion ignore the current buffer
(when in-deletion
- (setq buffers (delq (current-buffer) buffers))
+ (setq buffers (delete* (current-buffer) buffers))
(setq first-buf (car buffers)))
;; filter buffers
(when buffers-tab-filter-functions
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/gutter.el
--- a/lisp/gutter.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/gutter.el Tue May 01 16:17:42 2012 +0100
＠＠ -91,7 +91,7 ＠＠
(if visible-p
(if (memq prop spec) spec
(cons prop spec))
- (delq prop spec))
+ (delete* prop spec))
(if visible-p (list prop))))
(list prop visible-p)
'force nil locale tag-set)
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/info.el
--- a/lisp/info.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/info.el Tue May 01 16:17:42 2012 +0100
＠＠ -798,7 +798,7 ＠＠
(if (re-search-backward regexp beg t)
(throw 'foo t))))
(setq found nil)
- (let ((bufs (delq nil (mapcar 'get-file-buffer
+ (let ((bufs (delete* nil (mapcar 'get-file-buffer
Info-annotations-path)))
(pattern (if (string-match "\\`<<.*>>\\'" qnode) qnode
(format "\"%s\"\\|<<%s>>" qnode qnode)))
＠＠ -1384,7 +1384,7 ＠＠
(let* ((name (format "(%s)%s" (Info-file-name-only file) node))
(found (assoc name Info-history)))
(if found
- (setq Info-history (delq found Info-history)))
+ (setq Info-history (delete* found Info-history)))
(setq Info-history (cons (list name (- point (point-min))
(and (eq (window-buffer)
(current-buffer))
＠＠ -1702,7 +1702,7 ＠＠
(defun Info-build-annotation-completions ()
(or Info-current-annotation-completions
(save-excursion
- (let ((bufs (delq nil (mapcar 'get-file-buffer
+ (let ((bufs (delete* nil (mapcar 'get-file-buffer
Info-annotations-path)))
(compl nil))
(while bufs
＠＠ -2360,7 +2360,7 ＠＠
;; Here it is a feature that assoc is case-sensitive.
(while (setq found (assoc topic matches))
(setq exact (cons found exact)
- matches (delq found matches)))
+ matches (delete* found matches)))
(setq Info-index-alternatives (nconc exact matches)
Info-index-first-alternative (car Info-index-alternatives))
(Info-index-next 0)))
＠＠ -2528,7 +2528,7 ＠＠
(defun Info-reannotate-node ()
- (let ((bufs (delq nil (mapcar 'get-file-buffer Info-annotations-path))))
+ (let ((bufs (delete* nil (mapcar 'get-file-buffer Info-annotations-path))))
(if bufs
(let ((ibuf (current-buffer))
(file (concat "\\(" (regexp-quote
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/itimer.el
--- a/lisp/itimer.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/itimer.el Tue May 01 16:17:42 2012 +0100
＠＠ -316,7 +316,7 ＠＠
(defun delete-itimer (itimer)
"Deletes ITIMER. ITIMER may be an itimer or the name of one."
(check-itimer-coerce-string itimer)
- (setq itimer-list (delq itimer itimer-list)))
+ (setq itimer-list (delete* itimer itimer-list)))
(defun start-itimer (name function value &optional restart
is-idle with-args &rest function-arguments)
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/lib-complete.el
--- a/lisp/lib-complete.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/lib-complete.el Tue May 01 16:17:42 2012 +0100
＠＠ -180,7 +180,7 ＠＠
(new-cache-records (list (list root modtimes table))))
(if (not cache-entry) nil
;; Remove old cache entry
- (setq lib-complete:cache (delq cache-entry lib-complete:cache))
+ (setq lib-complete:cache (delete* cache-entry lib-complete:cache))
;; Copy non-redundant entries from old cache entry
(while cache-records
(if (or (equal root (nth 0 (car cache-records)))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/loadhist.el
--- a/lisp/loadhist.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/loadhist.el Tue May 01 16:17:42 2012 +0100
＠＠ -185,7 +185,7 ＠＠
((consp x)
;; Remove any feature names that this file provided.
(if (eq (car x) 'provide)
- (setq features (delq (cdr x) features))
+ (setq features (delete* (cdr x) features))
(if (eq (car x) 'module)
(setq unloading-module t))))
((and (boundp x)
＠＠ -201,7 +201,7 ＠＠
(cdr flist)))
;; Delete the load-history element for this file.
(let ((elt (assoc file load-history)))
- (setq load-history (delq elt load-history)))
+ (setq load-history (delete* elt load-history)))
;; If it is a module, really unload it.
(if unloading-module
(declare-fboundp (unload-module (symbol-name feature))))))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/menubar-items.el
--- a/lisp/menubar-items.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/menubar-items.el Tue May 01 16:17:42 2012 +0100
＠＠ -1806,7 +1806,7 ＠＠
(funcall fn buffer)
(funcall fn buffer n))))
(if complex-buffers-menu-p
- (delq nil
+ (delete* nil
(list line
(vector "S%_witch to Buffer"
(list buffers-menu-switch-to-buffer-function
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/menubar.el
--- a/lisp/menubar.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/menubar.el Tue May 01 16:17:42 2012 +0100
＠＠ -352,8 +352,8 ＠＠
;; the menubar is the only special case, because other menus begin
;; with their name.
(if (eq parent current-menubar)
- (setq current-menubar (delq item parent))
- (delq item parent))
+ (setq current-menubar (delete* item parent))
+ (delete* item parent))
(set-menubar-dirty-flag)
item)))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/msw-font-menu.el
--- a/lisp/msw-font-menu.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/msw-font-menu.el Tue May 01 16:17:42 2012 +0100
＠＠ -118,7 +118,7 ＠＠
done)
(setq sizes (cons (car common) sizes)))
(setq common (cdr common)))
- (setq sizes (delq 0 sizes))))
+ (setq sizes (delete* 0 sizes))))
(setq families (sort families 'string-lessp)
weights (sort weights 'string-lessp)
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/mule/make-coding-system.el
--- a/lisp/mule/make-coding-system.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/mule/make-coding-system.el Tue May 01 16:17:42 2012 +0100
＠＠ -90,7 +90,7 ＠＠
(loop for char across decode-table
do (pushnew (char-charset char) known-charsets))
- (setq known-charsets (delq 'ascii known-charsets))
+ (setq known-charsets (delete* 'ascii known-charsets))
(loop for known-charset in known-charsets
do
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/next-error.el
--- a/lisp/next-error.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/next-error.el Tue May 01 16:17:42 2012 +0100
＠＠ -137,14 +137,14 ＠＠
(or
;; 1. If one window on the selected frame displays such buffer, return it.
(let ((window-buffers
- (delete-dups
- (delq nil (mapcar (lambda (w)
- (if (next-error-buffer-p
- (window-buffer w)
- avoid-current
- extra-test-inclusive extra-test-exclusive)
- (window-buffer w)))
- (window-list))))))
+ (delete-duplicates
+ (mapcan #'(lambda (w)
+ (if (next-error-buffer-p
+ (window-buffer w)
+ avoid-current
+ extra-test-inclusive extra-test-exclusive)
+ (list (window-buffer w))))
+ (window-list)))))
(if (eq (length window-buffers) 1)
(car window-buffers)))
;; 2. If next-error-last-buffer is an acceptable buffer, use that.
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/obsolete.el
--- a/lisp/obsolete.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/obsolete.el Tue May 01 16:17:42 2012 +0100
＠＠ -410,7 +410,8 ＠＠
"Return a list of charsets in the STRING except ascii.
It might be available for compatibility with Mule 2.3,
because its `find-charset-string' ignores ASCII charset."
- (delq 'ascii (and-fboundp 'charsets-in-string (charsets-in-string string))))
+ (delete* 'ascii
+ (and-fboundp 'charsets-in-string (charsets-in-string string))))
(make-obsolete 'find-non-ascii-charset-string
"use (delq 'ascii (charsets-in-string STRING)) instead.")
＠＠ -418,8 +419,8 ＠＠
"Return a list of charsets except ascii in the region between START and END.
It might be available for compatibility with Mule 2.3,
because its `find-charset-string' ignores ASCII charset."
- (delq 'ascii (and-fboundp 'charsets-in-region
- (charsets-in-region start end))))
+ (delete* 'ascii (and-fboundp 'charsets-in-region
+ (charsets-in-region start end))))
(make-obsolete 'find-non-ascii-charset-region
"use (delq 'ascii (charsets-in-region START END)) instead.")
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/occur.el
--- a/lisp/occur.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/occur.el Tue May 01 16:17:42 2012 +0100
＠＠ -365,24 +365,21 ＠＠
(occur-read-primary-args)))
(when bufregexp
(occur-1 regexp nlines
- (delq nil
- (mapcar (lambda (buf)
- (when (and (buffer-file-name buf)
- (string-match bufregexp
- (buffer-file-name buf)))
- buf))
- (buffer-list))))))
+ (mapcan #'(lambda (buf)
+ (when (and (buffer-file-name buf)
+ (string-match bufregexp
+ (buffer-file-name buf)))
+ (list buf)))
+ (buffer-list)))))
(defun occur-1 (regexp nlines bufs &optional buf-name)
(unless buf-name
(setq buf-name "*Occur*"))
(let (occur-buf
- (active-bufs (delq nil (mapcar #'(lambda (buf)
- (when (buffer-live-p buf) buf))
- bufs))))
+ (active-bufs (remove-if-not #'buffer-live-p bufs)))
;; Handle the case where one of the buffers we're searching is the
;; output buffer. Just rename it.
- (when (member buf-name (mapcar 'buffer-name active-bufs))
+ (when (position buf-name active-bufs :test #'equal :key #'buffer-name)
(with-current-buffer (get-buffer buf-name)
(rename-uniquely)))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/packages.el
--- a/lisp/packages.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/packages.el Tue May 01 16:17:42 2012 +0100
＠＠ -85,12 +85,11 ＠＠
"Load path for packages last in the load path.")
(defun packages-package-hierarchy-directory-names ()
- "Returns a list package hierarchy directory names.
+ "Returns a list of package hierarchy directory names.
These are the valid immediate directory names of package
directories, directories with higher priority first"
- (delq nil `("site-packages"
- ,(when (featurep 'mule) "mule-packages")
- "xemacs-packages")))
+ `("site-packages" ,＠(when (featurep 'mule) '("mule-packages"))
+ "xemacs-packages"))
(defun package-get-key-1 (info key)
"Locate keyword `key' in list."
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/process.el
--- a/lisp/process.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/process.el Tue May 01 16:17:42 2012 +0100
＠＠ -707,7 +707,8 ＠＠
(cond ((string-match pattern (car scan))
(setq found t)
(if (eq nil value)
- (setq process-environment (delq (car scan) process-environment))
+ (setq process-environment
+ (delete* (car scan) process-environment))
(setcar scan (concat variable "=" value)))
(setq scan nil)))
(setq scan (cdr scan)))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/simple.el
--- a/lisp/simple.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/simple.el Tue May 01 16:17:42 2012 +0100
＠＠ -958,7 +958,7 ＠＠
(if (fixnump (car tail))
(progn
(setq done t)
- (setq buffer-undo-list (delq (car tail) buffer-undo-list))))
+ (setq buffer-undo-list (delete* (car tail) buffer-undo-list))))
(setq tail (cdr tail))))
(and modified (not (buffer-modified-p))
(delete-auto-save-file-if-necessary recent-save)))
＠＠ -2100,7 +2100,7 ＠＠
(loop
for keysym in motion-keys-for-shifted-motion
with key = (event-key last-input-event)
- with mods = (delq 'shift (event-modifiers last-input-event))
+ with mods = (delete* 'shift (event-modifiers last-input-event))
with char-list = '(?a) ;; Some random character; the list will be
;; modified in the constants vector over
;; time.
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/sound.el
--- a/lisp/sound.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/sound.el Tue May 01 16:17:42 2012 +0100
＠＠ -174,8 +174,7 ＠＠
(erase-buffer))
(and buf (kill-buffer buf)))
(let ((old (assq sound-name sound-alist)))
- ;; some conses in sound-alist might have been dumped with emacs.
- (if old (setq sound-alist (delq old (copy-sequence sound-alist)))))
+ (if old (setq sound-alist (remove* old sound-alist))))
(setq sound-alist (cons
(nconc (list sound-name)
(if (and volume (not (eq 0 volume)))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/wid-edit.el
--- a/lisp/wid-edit.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/wid-edit.el Tue May 01 16:17:42 2012 +0100
＠＠ -2332,7 +2332,7 ＠＠
(defun widget-field-value-delete (widget)
"Remove the widget from the list of active editing fields."
- (setq widget-field-list (delq widget widget-field-list))
+ (setq widget-field-list (delete* widget widget-field-list))
;; These are nil if the :format string doesn't contain `%v'.
(let ((extent (widget-get widget :field-extent)))
(when extent
＠＠ -2676,7 +2676,7 ＠＠
(let ((vals (widget-match-inline answer values)))
(setq found (append found (car vals))
values (cdr vals)
- args (delq answer args))))
+ args (delete* answer args))))
(greedy
(setq rest (append rest (list (car values)))
values (cdr values)))
＠＠ -2697,7 +2697,7 ＠＠
(let ((match (widget-match-inline answer vals)))
(setq found (cons (cons answer (car match)) found)
vals (cdr match)
- args (delq answer args))))
+ args (delete* answer args))))
(greedy
(setq vals (cdr vals)))
(t
＠＠ -3091,7 +3091,7 ＠＠
buttons (cdr buttons))
(when (eq (widget-get button :widget) child)
(widget-put widget
- :buttons (delq button (widget-get widget :buttons)))
+ :buttons (delete* button (widget-get widget :buttons)))
(widget-delete button))))
(let ((entry-from (widget-get child :entry-from))
(entry-to (widget-get child :entry-to))
＠＠ -3102,7 +3102,7 ＠＠
(delete-region entry-from entry-to)
(set-marker entry-from nil)
(set-marker entry-to nil))
- (widget-put widget :children (delq child (widget-get widget :children))))
+ (widget-put widget :children (delete* child (widget-get widget :children))))
(widget-setup)
(widget-apply widget :notify widget))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/window.el
--- a/lisp/window.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/window.el Tue May 01 16:17:42 2012 +0100
＠＠ -580,7 +580,7 ＠＠
;; Get rid of the frame, if it has just one dedicated window
;; and other visible frames exist.
(and (or (window-minibuffer-p) (window-dedicated-p window))
- (delq frame (visible-frame-list))
+ (delete* frame (visible-frame-list))
window-solitary
(if (and (eq default-minibuffer-frame frame)
(eql 1 (length (minibuffer-frame-list))))
diff -r ae2fdb1fd9e0 -r cc6f0266bc36 lisp/x-font-menu.el
--- a/lisp/x-font-menu.el Tue May 01 12:43:22 2012 +0100
+++ b/lisp/x-font-menu.el Tue May 01 16:17:42 2012 +0100
＠＠ -233,7 +233,7 ＠＠
done)
(setq sizes (cons (car common) sizes)))
(setq common (cdr common)))
- (setq sizes (delq 0 sizes))))
+ (setq sizes (delete* 0 sizes))))
(setq families (sort families 'string-lessp)
weights (sort weights 'string-lessp)
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Improve for-effect handling in a few places, lisp/
12 years, 8 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1335872602 -3600
# Node ID ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6
# Parent 7fa8667cdaa732afd502dd72f088e5f3d9e00478
Improve for-effect handling in a few places, lisp/
lisp/ChangeLog addition:
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
* byte-optimize.el (byte-optimize-or):
Improve handling of for-effect here; we don't need to worry about
discarding multiple values when for-effect is non-nil, this
applies to both #'prog1 and #'or.
* bytecomp.el (progn):
* bytecomp.el (byte-compile-file-form-progn): New.
Put back this function, since it's for-effect there's no need to
worry about passing back multiple values.
* cl-macs.el (cl-pop2):
* cl-macs.el (cl-do-pop):
* cl-macs.el (remf):
* cl.el (pop):
Expand to (prog1 (car-safe PLACE) (setq PLACE (cdr PLACE))) in all
these macros, since that optimizes better (especially for-effect
handling) when byte-compile-delete-errors is nil.
diff -r 7fa8667cdaa7 -r ae2fdb1fd9e0 lisp/ChangeLog
--- a/lisp/ChangeLog Mon Apr 23 10:06:39 2012 +0200
+++ b/lisp/ChangeLog Tue May 01 12:43:22 2012 +0100
＠＠ -1,3 +1,22 ＠＠
+2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ * byte-optimize.el (byte-optimize-or):
+ Improve handling of for-effect here; we don't need to worry about
+ discarding multiple values when for-effect is non-nil, this
+ applies to both #'prog1 and #'or.
+ * bytecomp.el (progn):
+ * bytecomp.el (byte-compile-file-form-progn): New.
+ Put back this function, since it's for-effect there's no need to
+ worry about passing back multiple values.
+ * cl-macs.el (cl-pop2):
+ * cl-macs.el (cl-do-pop):
+ * cl-macs.el (remf):
+ * cl.el (pop):
+ Expand to (prog1 (car-safe PLACE) (setq PLACE (cdr PLACE))) in all
+ these macros, since that optimizes better (especially for-effect
+ handling) when byte-compile-delete-errors is nil.
+
2012-04-23 Michael Sperber <mike(a)xemacs.org>
* bytecomp.el (batch-byte-recompile-directory): Accept an optional
diff -r 7fa8667cdaa7 -r ae2fdb1fd9e0 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Mon Apr 23 10:06:39 2012 +0200
+++ b/lisp/byte-optimize.el Tue May 01 12:43:22 2012 +0100
＠＠ -431,7 +431,7 ＠＠
(byte-optimize-form (nth 1 form) for-effect)))
((eq fn 'prog1)
(if (cdr (cdr form))
- (cons 'prog1
+ (cons (if for-effect 'progn 'prog1)
(cons (byte-optimize-form (nth 1 form) for-effect)
(byte-optimize-body (cdr (cdr form)) t)))
(byte-optimize-form `(or ,(nth 1 form) nil) for-effect)))
＠＠ -537,6 +537,12 ＠＠
(setq tmp (byte-optimize-side-effect-free-p form))
(or byte-compile-delete-errors
(eq tmp 'error-free)
+ ;; XEmacs; GNU handles the expansion of (pop foo) specially
+ ;; here. We changed the macro to expand to (prog1 (car-safe
+ ;; PLACE) (setq PLACE (cdr PLACE))) , which has the same
+ ;; effect. (This only matters when
+ ;; byte-compile-delete-errors is nil, which is usually true
+ ;; for GNU and usually false for XEmacs.)
(progn
(byte-compile-warn "%s called for effect"
(prin1-to-string form))
＠＠ -947,20 +953,17 ＠＠
(defun byte-optimize-or (form)
;; Throw away unneeded nils, and simplify if less than 2 args.
;; XEmacs; change to be more careful about discarding multiple values.
- (let* ((memqueued (memq nil form))
- (trailing-nil (and (cdr memqueued)
- (equal '(nil) (last form))))
- rest)
- ;; A trailing nil indicates to discard multiple values, and we need to
- ;; respect that:
- (when (and memqueued (cdr memqueued))
- (setq form (delq nil (copy-sequence form)))
- (when trailing-nil
- (setcdr (last form) '(nil))))
- (setq rest form)
- ;; If there is a literal non-nil constant in the args to `or', throw
- ;; away all following forms. We can do this because a literal non-nil
- ;; constant cannot be multiple.
+ (if (memq nil form)
+ (setq form (remove* nil form
+ ;; A trailing nil indicates to discard multiple
+ ;; values, and we need to respect that. No need if
+ ;; this is for-effect, though, multiple values
+ ;; will be discarded anyway.
+:end (if (not for-effect) (1- (length form))))))
+ ;; If there is a literal non-nil constant in the args to `or', throw
+ ;; away all following forms. We can do this because a literal non-nil
+ ;; constant cannot be multiple.
+ (let ((rest form))
(while (cdr (setq rest (cdr rest)))
(if (byte-compile-trueconstp (car rest))
(setq form (copy-sequence form)
diff -r 7fa8667cdaa7 -r ae2fdb1fd9e0 lisp/bytecomp.el
--- a/lisp/bytecomp.el Mon Apr 23 10:06:39 2012 +0200
+++ b/lisp/bytecomp.el Tue May 01 12:43:22 2012 +0100
＠＠ -2411,29 +2411,13 ＠＠
(eval form)
(byte-compile-keep-pending form 'byte-compile-normal-call))
-;; XEmacs change: be careful about multiple values with these three forms.
-(put 'progn 'byte-hunk-handler
- #'(lambda (form)
- (mapc 'byte-compile-file-form (cdr form))
- ;; Return nil so the forms are not output twice.
- nil))
-
-(put 'prog1 'byte-hunk-handler
- #'(lambda (form)
- (when (first form)
- (byte-compile-file-form `(or ,(first form) nil))
- (mapc 'byte-compile-file-form (cdr form))
- nil)))
-
-(put 'prog2 'byte-hunk-handler
- #'(lambda (form)
- (when (first form)
- (byte-compile-file-form (first form))
- (when (second form)
- (setq form (cdr form))
- (byte-compile-file-form `(or ,(first form) nil))
- (mapc 'byte-compile-file-form (cdr form))
- nil))))
+(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
+(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
+(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
+(defun byte-compile-file-form-progn (form)
+ (mapc 'byte-compile-file-form (cdr form))
+ ;; Return nil so the forms are not output twice.
+ nil)
;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner.
diff -r 7fa8667cdaa7 -r ae2fdb1fd9e0 lisp/cl-macs.el
--- a/lisp/cl-macs.el Mon Apr 23 10:06:39 2012 +0200
+++ b/lisp/cl-macs.el Tue May 01 12:43:22 2012 +0100
＠＠ -46,7 +46,7 ＠＠
;;; Code:
(defmacro cl-pop2 (place)
- (list 'prog1 (list 'car (list 'cdr place))
+ (list 'prog1 (list 'car-safe (list 'cdr-safe place))
(list 'setq place (list 'cdr (list 'cdr place)))))
(put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
＠＠ -2456,14 +2456,14 ＠＠
;;;###autoload
(defun cl-do-pop (place)
(if (cl-simple-expr-p place)
- (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
+ (list 'prog1 (list 'car-safe place) (list 'setf place (list 'cdr place)))
(let* ((method (cl-setf-do-modify place t))
(temp (gensym "--pop--")))
(list 'let*
(append (car method)
(list (list temp (nth 2 method))))
(list 'prog1
- (list 'car temp)
+ (list 'car-safe temp)
(cl-setf-do-store (nth 1 method) (list 'cdr temp)))))))
;;;###autoload
diff -r 7fa8667cdaa7 -r ae2fdb1fd9e0 lisp/cl.el
--- a/lisp/cl.el Mon Apr 23 10:06:39 2012 +0200
+++ b/lisp/cl.el Tue May 01 12:43:22 2012 +0100
＠＠ -152,7 +152,7 ＠＠
careful about evaluating each argument only once and in the right order.
PLACE may be a symbol, or any generalized variable allowed by `setf'."
(if (symbolp place)
- `(car (prog1 ,place (setq ,place (cdr ,place))))
+ `(car-safe (prog1 ,place (setq ,place (cdr ,place))))
(cl-do-pop place)))
(defmacro push (newelt listname)
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/XEmacs: kehoea: Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
12 years, 8 months
Bitbucket
Bitbucket
1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/cc6f0266bc36/
changeset: cc6f0266bc36
user: kehoea
date: 2012-05-01 17:17:42
summary: Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
lisp/ChangeLog addition:
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
Avoid #'delq in core code, for the sake of style and a (very
slightly) smaller binary.
* behavior.el (disable-behavior):
* behavior.el (compute-behavior-group-children):
* buff-menu.el (buffers-tab-items):
* byte-optimize.el (byte-optimize-delay-constants-math):
* byte-optimize.el (byte-optimize-logmumble):
* byte-optimize.el (byte-decompile-bytecode-1):
* byte-optimize.el (byte-optimize-lapcode):
* bytecomp.el:
* bytecomp.el (byte-compile-arglist-warn):
* bytecomp.el (byte-compile-warn-about-unresolved-functions):
* bytecomp.el (byte-compile-lambda):
* bytecomp.el (byte-compile-out-toplevel):
* bytecomp.el (byte-compile-insert):
* bytecomp.el (byte-compile-defalias-warn):
* cl-macs.el (cl-upcase-arg):
* cl-macs.el (cl-transform-lambda):
* cl-macs.el (cl-do-proclaim):
* cl-macs.el (defstruct):
* cl-macs.el (cl-make-type-test):
* cl-macs.el (define-compiler-macro):
* cl-macs.el (delete-duplicates):
* cus-edit.el (widget-face-value-delete):
* cus-edit.el (face-history):
* easymenu.el (easy-menu-remove):
* files.el (files-fetch-hook-value):
* files.el (file-expand-wildcards):
* font-lock.el (font-lock-update-removed-keyword-alist):
* font-lock.el (font-lock-remove-keywords):
* frame.el (frame-initialize):
* frame.el (frame-notice-user-settings):
* frame.el (set-frame-font):
* frame.el (delete-other-frames):
* frame.el (get-frame-for-buffer-noselect):
* gnuserv.el (gnuserv-kill-buffer-function):
* gnuserv.el (gnuserv-check-device):
* gnuserv.el (gnuserv-kill-client):
* gnuserv.el (gnuserv-buffer-done-1):
* gtk-font-menu.el (gtk-reset-device-font-menus):
* gutter-items.el (buffers-tab-items):
* gutter.el (set-gutter-element-visible-p):
* info.el (Info-find-file-node):
* info.el (Info-history-add):
* info.el (Info-build-annotation-completions):
* info.el (Info-index):
* info.el (Info-reannotate-node):
* itimer.el (delete-itimer):
* itimer.el (start-itimer):
* lib-complete.el (lib-complete:cache-completions):
* loadhist.el (unload-feature):
* menubar-items.el (build-buffers-menu-internal):
* menubar.el (delete-menu-item):
* menubar.el (relabel-menu-item):
* msw-font-menu.el (mswindows-reset-device-font-menus):
* mule/make-coding-system.el (fixed-width-generate-helper):
* next-error.el (next-error-find-buffer):
* obsolete.el:
* obsolete.el (find-non-ascii-charset-string):
* obsolete.el (find-non-ascii-charset-region):
* occur.el (multi-occur-by-filename-regexp):
* occur.el (occur-1):
* packages.el (packages-package-hierarchy-directory-names):
* packages.el (package-get-key-1):
* process.el (setenv):
* simple.el (undo):
* simple.el (handle-pre-motion-command-current-command-is-motion):
* sound.el (load-sound-file):
* wid-edit.el (widget-field-value-delete):
* wid-edit.el (widget-checklist-match-inline):
* wid-edit.el (widget-checklist-match-find):
* wid-edit.el (widget-editable-list-delete-at):
* wid-edit.el (widget-editable-list-entry-create):
* window.el (quit-window):
* x-font-menu.el (x-reset-device-font-menus-core):
1. Replace (delq nil (mapcar ....)) with analogous (mapcan ...)
forms; this is in non-dumped files, it was done previously in
dumped files.
2. Replace (delq FOO (copy-sequence BAR)) with (remove* FOO BAR),
where #'eq and #'eql are equivalent
3. Replace (delq FOO BAR) with (delete* FOO BAR), where FOO is not
a non-fixnum number. Saves a little space in the dumped file
(since the compiler macro adds :test #'eq to the delete* call if
it's not clear that FOO is not a non-fixnum number).
affected #: 33 files
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
＠＠ -1,3 +1,92 ＠＠
+2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Avoid #'delq in core code, for the sake of style and a (very
+ slightly) smaller binary.
+
+ * behavior.el (disable-behavior):
+ * behavior.el (compute-behavior-group-children):
+ * buff-menu.el (buffers-tab-items):
+ * byte-optimize.el (byte-optimize-delay-constants-math):
+ * byte-optimize.el (byte-optimize-logmumble):
+ * byte-optimize.el (byte-decompile-bytecode-1):
+ * byte-optimize.el (byte-optimize-lapcode):
+ * bytecomp.el:
+ * bytecomp.el (byte-compile-arglist-warn):
+ * bytecomp.el (byte-compile-warn-about-unresolved-functions):
+ * bytecomp.el (byte-compile-lambda):
+ * bytecomp.el (byte-compile-out-toplevel):
+ * bytecomp.el (byte-compile-insert):
+ * bytecomp.el (byte-compile-defalias-warn):
+ * cl-macs.el (cl-upcase-arg):
+ * cl-macs.el (cl-transform-lambda):
+ * cl-macs.el (cl-do-proclaim):
+ * cl-macs.el (defstruct):
+ * cl-macs.el (cl-make-type-test):
+ * cl-macs.el (define-compiler-macro):
+ * cl-macs.el (delete-duplicates):
+ * cus-edit.el (widget-face-value-delete):
+ * cus-edit.el (face-history):
+ * easymenu.el (easy-menu-remove):
+ * files.el (files-fetch-hook-value):
+ * files.el (file-expand-wildcards):
+ * font-lock.el (font-lock-update-removed-keyword-alist):
+ * font-lock.el (font-lock-remove-keywords):
+ * frame.el (frame-initialize):
+ * frame.el (frame-notice-user-settings):
+ * frame.el (set-frame-font):
+ * frame.el (delete-other-frames):
+ * frame.el (get-frame-for-buffer-noselect):
+ * gnuserv.el (gnuserv-kill-buffer-function):
+ * gnuserv.el (gnuserv-check-device):
+ * gnuserv.el (gnuserv-kill-client):
+ * gnuserv.el (gnuserv-buffer-done-1):
+ * gtk-font-menu.el (gtk-reset-device-font-menus):
+ * gutter-items.el (buffers-tab-items):
+ * gutter.el (set-gutter-element-visible-p):
+ * info.el (Info-find-file-node):
+ * info.el (Info-history-add):
+ * info.el (Info-build-annotation-completions):
+ * info.el (Info-index):
+ * info.el (Info-reannotate-node):
+ * itimer.el (delete-itimer):
+ * itimer.el (start-itimer):
+ * lib-complete.el (lib-complete:cache-completions):
+ * loadhist.el (unload-feature):
+ * menubar-items.el (build-buffers-menu-internal):
+ * menubar.el (delete-menu-item):
+ * menubar.el (relabel-menu-item):
+ * msw-font-menu.el (mswindows-reset-device-font-menus):
+ * mule/make-coding-system.el (fixed-width-generate-helper):
+ * next-error.el (next-error-find-buffer):
+ * obsolete.el:
+ * obsolete.el (find-non-ascii-charset-string):
+ * obsolete.el (find-non-ascii-charset-region):
+ * occur.el (multi-occur-by-filename-regexp):
+ * occur.el (occur-1):
+ * packages.el (packages-package-hierarchy-directory-names):
+ * packages.el (package-get-key-1):
+ * process.el (setenv):
+ * simple.el (undo):
+ * simple.el (handle-pre-motion-command-current-command-is-motion):
+ * sound.el (load-sound-file):
+ * wid-edit.el (widget-field-value-delete):
+ * wid-edit.el (widget-checklist-match-inline):
+ * wid-edit.el (widget-checklist-match-find):
+ * wid-edit.el (widget-editable-list-delete-at):
+ * wid-edit.el (widget-editable-list-entry-create):
+ * window.el (quit-window):
+ * x-font-menu.el (x-reset-device-font-menus-core):
+
+ 1. Replace (delq nil (mapcar ....)) with analogous (mapcan ...)
+ forms; this is in non-dumped files, it was done previously in
+ dumped files.
+ 2. Replace (delq FOO (copy-sequence BAR)) with (remove* FOO BAR),
+ where #'eq and #'eql are equivalent
+ 3. Replace (delq FOO BAR) with (delete* FOO BAR), where FOO is not
+ a non-fixnum number. Saves a little space in the dumped file
+ (since the compiler macro adds :test #'eq to the delete* call if
+ it's not clear that FOO is not a non-fixnum number).
+
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/behavior.el
--- a/lisp/behavior.el
+++ b/lisp/behavior.el
＠＠ -403,7 +403,7 ＠＠
(message "Disabling behavior %s...done" behavior)
(let ((within-behavior-enabling-disabling t))
(customize-set-variable 'enabled-behavior-list
- (delq behavior enabled-behavior-list))))))
+ (delete* behavior enabled-behavior-list))))))
(defun compute-behavior-group-children (group hash)
"Compute the actual children for GROUP and its subgroups.
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/buff-menu.el
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
＠＠ -860,10 +860,10 ＠＠
(not in-deletion)
(not (eq first-buf (window-buffer (selected-window frame)))))
(setq buffers (cons (window-buffer (selected-window frame))
- (delq first-buf buffers))))
+ (delete* first-buf buffers))))
;; if we're in deletion ignore the current buffer
(when in-deletion
- (setq buffers (delq (current-buffer) buffers))
+ (setq buffers (delete* (current-buffer) buffers))
(setq first-buf (car buffers)))
;; filter buffers
(when buffers-tab-filter-functions
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/byte-optimize.el
--- a/lisp/byte-optimize.el
+++ b/lisp/byte-optimize.el
＠＠ -710,7 +710,7 ＠＠
(apply fun (mapcar 'float constants))
(float (apply fun constants)))))
(setq form orig)
- (setq form (nconc (delq nil form)
+ (setq form (nconc (delete* nil form)
(list (apply fun (nreverse constants)))))))))
form))
＠＠ -787,7 +787,7 ＠＠
(cond ((memq 0 form)
(setq form (if (eq (car form) 'logand)
(cons 'progn (cdr form))
- (delq 0 (copy-sequence form)))))
+ (remove* 0 form))))
((and (eq (car-safe form) 'logior)
(memq -1 form))
(cons 'progn (cdr form)))
＠＠ -1462,7 +1462,7 ＠＠
;; this addr is jumped to
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
- (setq tags (delq tmp tags))
+ (setq tags (delete* tmp tags))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
＠＠ -1591,11 +1591,11 ＠＠
(cond ((= tmp 1)
(byte-compile-log-lap
" %s discard\t-->\t<deleted>" lap0)
- (setq lap (delq lap0 (delq lap1 lap))))
+ (setq lap (delete* lap0 (delete* lap1 lap))))
((= tmp 0)
(byte-compile-log-lap
" %s discard\t-->\t<deleted> discard" lap0)
- (setq lap (delq lap0 lap)))
+ (setq lap (delete* lap0 lap)))
((= tmp -1)
(byte-compile-log-lap
" %s discard\t-->\tdiscard discard" lap0)
＠＠ -1608,7 +1608,7 ＠＠
((and (memq (car lap0) byte-goto-ops)
(eq (cdr lap0) lap1))
(cond ((eq (car lap0) 'byte-goto)
- (setq lap (delq lap0 lap))
+ (setq lap (delete* lap0 lap))
(setq tmp "<deleted>"))
((memq (car lap0) byte-goto-always-pop-ops)
(setcar lap0 (setq tmp 'byte-discard))
＠＠ -1665,7 +1665,7 ＠＠
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
(setq keep-going t
rest (cdr rest))
- (setq lap (delq lap0 (delq lap2 lap))))
+ (setq lap (delete* lap0 (delete* lap2 lap))))
;;
;; not goto-X-if-nil --> goto-X-if-non-nil
;; not goto-X-if-non-nil --> goto-X-if-nil
＠＠ -1685,7 +1685,7 ＠＠
(setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
'byte-goto-if-not-nil
'byte-goto-if-nil))
- (setq lap (delq lap0 lap))
+ (setq lap (delete* lap0 lap))
(setq keep-going t))
;;
;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
＠＠ -1702,7 +1702,7 ＠＠
(byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
lap0 lap1 lap2
(cons inverse (cdr lap1)) lap2)
- (setq lap (delq lap0 lap))
+ (setq lap (delete* lap0 lap))
(setcar lap1 inverse)
(setq keep-going t)))
;;
＠＠ -1717,13 +1717,13 ＠＠
(byte-compile-log-lap " %s %s\t-->\t<deleted>"
lap0 lap1)
(setq rest (cdr rest)
- lap (delq lap0 (delq lap1 lap))))
+ lap (delete* lap0 (delete* lap1 lap))))
(t
(if (memq (car lap1) byte-goto-always-pop-ops)
(progn
(byte-compile-log-lap " %s %s\t-->\t%s"
lap0 lap1 (cons 'byte-goto (cdr lap1)))
- (setq lap (delq lap0 lap)))
+ (setq lap (delete* lap0 lap)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
(cons 'byte-goto (cdr lap1))))
(setcar lap1 'byte-goto)))
＠＠ -1768,7 +1768,7 ＠＠
(while (setq tmp2 (rassq lap0 tmp3))
(setcdr tmp2 lap1)
(setq tmp3 (cdr (memq tmp2 tmp3))))
- (setq lap (delq lap0 lap)
+ (setq lap (delete* lap0 lap)
keep-going t))
;;
;; unused-TAG: --><deleted>
＠＠ -1777,7 +1777,7 ＠＠
(not (rassq lap0 lap)))
(and (memq byte-optimize-log '(t byte))
(byte-compile-log " unused tag %d removed" (nth 1 lap0)))
- (setq lap (delq lap0 lap)
+ (setq lap (delete* lap0 lap)
keep-going t))
;;
;; goto ... --> goto <delete until TAG or end>
＠＠ -1832,10 +1832,10 ＠＠
byte-save-restriction))
(< 0 (cdr lap1)))
(if (zerop (setcdr lap1 (1- (cdr lap1))))
- (delq lap1 rest))
+ (delete* lap1 rest))
(if (eq (car lap0) 'byte-varbind)
(setcar rest (cons 'byte-discard 0))
- (setq lap (delq lap0 lap)))
+ (setq lap (delete* lap0 lap)))
(byte-compile-log-lap " %s %s\t-->\t%s %s"
lap0 (cons (car lap1) (1+ (cdr lap1)))
(if (eq (car lap0) 'byte-varbind)
＠＠ -1922,7 +1922,7 ＠＠
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))))
+ (setq lap (delete* lap0 lap))))
(setq keep-going t))
;;
;; X: varref-Y ... varset-Y goto-X -->
＠＠ -2058,7 +2058,7 ＠＠
(cons 'byte-unbind
(+ (cdr lap0) (cdr lap1))))
(setq keep-going t)
- (setq lap (delq lap0 lap))
+ (setq lap (delete* lap0 lap))
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
)
(setq rest (cdr rest)))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/bytecomp.el
--- a/lisp/bytecomp.el
+++ b/lisp/bytecomp.el
＠＠ -1488,7 +1488,7 ＠＠
(byte-compile-arglist-signature-string (cons min max))))
(setq byte-compile-unresolved-functions
- (delq calls byte-compile-unresolved-functions)))))
+ (delete* calls byte-compile-unresolved-functions)))))
)))
;; If we have compiled any calls to functions which are not known to be
＠＠ -1503,7 +1503,7 ＠＠
(while rest
(if (assq (car (car rest)) byte-compile-autoload-environment)
(setq byte-compile-unresolved-functions
- (delq (car rest) byte-compile-unresolved-functions)))
+ (delete* (car rest) byte-compile-unresolved-functions)))
(setq rest (cdr rest)))))
;; Now warn.
(if (cdr byte-compile-unresolved-functions)
＠＠ -2757,8 +2757,7 ＠＠
(let ((new-bindings
(mapcar #'(lambda (x) (cons x byte-compile-arglist-bit))
(and (memq 'free-vars byte-compile-warnings)
- (delq '&rest (delq '&optional
- (copy-sequence arglist)))))))
+ (remove* '&rest (remove* '&optional arglist))))))
(nconc new-bindings
(cons 'new-scope byte-compile-bound-variables))))
(body (cdr (cdr fun)))
＠＠ -2963,7 +2962,7 ＠＠
(cons (nth 1 (car body)) (cdr body))
(cons tmp body))))
(or (eq output-type 'file)
- (not (delq nil (mapcar 'consp (cdr (car body))))))))
+ (notany #'consp (cdar body)))))
(setq rest (cdr rest)))
rest))
(let ((byte-compile-vector (byte-compile-constants-vector)))
＠＠ -3814,7 +3813,7 ＠＠
(if (cdr (cdr form))
(byte-compile-out 'byte-insertN (length (cdr form)))
(byte-compile-out 'byte-insert 0)))
- ((memq t (mapcar 'consp (cdr (cdr form))))
+ ((some #'consp (cddr form))
(byte-compile-normal-call form))
;; We can split it; there is no function call after inserting 1st arg.
(t
＠＠ -4669,7 +4668,7 ＠＠
(let ((calls (assq new byte-compile-unresolved-functions)))
(if calls
(setq byte-compile-unresolved-functions
- (delq calls byte-compile-unresolved-functions)))))
+ (delete* calls byte-compile-unresolved-functions)))))
;;; tags
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/cl-macs.el
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
＠＠ -299,9 +299,9 ＠＠
;; Clean the list
(let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(if (setq junk (cadr (memq '&cl-defs arg)))
- (setq arg (delq '&cl-defs (delq junk arg))))
+ (setq arg (delete* '&cl-defs (delete* junk arg))))
(if (memq '&cl-quote arg)
- (setq arg (delq '&cl-quote arg)))
+ (setq arg (delete* '&cl-quote arg)))
(mapcar 'cl-upcase-arg arg)))
(t arg))) ; Maybe we are in initializer
＠＠ -346,13 +346,13 ＠＠
(setq args (if (listp args) (copy-list args) (list '&rest args)))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(if (setq bind-defs (cadr (memq '&cl-defs args)))
- (setq args (delq '&cl-defs (delq bind-defs args))
+ (setq args (delete* '&cl-defs (delete* bind-defs args))
bind-defs (cadr bind-defs)))
(if (setq bind-enquote (memq '&cl-quote args))
- (setq args (delq '&cl-quote args)))
+ (setq args (delete* '&cl-quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
(let* ((p (memq '&environment args)) (v (cadr p)))
- (if p (setq args (nconc (delq (car p) (delq v args))
+ (if p (setq args (nconc (delete* (car p) (delete* v args))
`(&aux (,v byte-compile-macro-environment))))))
(while (and args (symbolp (car args))
(not (memq (car args) '(nil &rest &body &key &aux)))
＠＠ -1916,7 +1916,7 ＠＠
(if (consp (car spec))
(if (eq (cadar spec) 0)
(setq byte-compile-warnings
- (delq (caar spec) byte-compile-warnings))
+ (delete* (caar spec) byte-compile-warnings))
(setq byte-compile-warnings
(adjoin (caar spec) byte-compile-warnings)))))))
nil)
＠＠ -2806,7 +2806,7 ＠＠
(caar include-descs) include))
old-descs)
(pop include-descs)))
- (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
+ (setq descs (append old-descs (delete* (assq 'cl-tag-slot descs) descs))
type (car inc-type)
named (assq 'cl-tag-slot descs))
(if (cadr inc-type) (setq tag name named t))
＠＠ -2822,7 +2822,7 ＠＠
(error "Illegal :type specifier: %s" type))
(if named (setq tag name)))
(setq type 'vector named 'true)))
- (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
+ (or named (setq descs (delete* (assq 'cl-tag-slot descs) descs)))
(push (list 'defvar tag-symbol) forms)
(setq pred-form (and named
(let ((pos (- (length descs)
＠＠ -2896,8 +2896,8 ＠＠
(push (cons copier t) side-eff)))
(if constructor
(push (list constructor
- (cons '&key (delq nil (copy-sequence slots))))
- constrs))
+ (cons '&key (remove* nil slots)))
+ constrs))
(while constrs
(let* ((name (caar constrs))
(args (cadr (pop constrs)))
＠＠ -2988,7 +2988,7 ＠＠
(cl-make-type-test val (apply (get (car type) 'cl-deftype-handler)
(cdr type))))
((memq (car-safe type) '(integer float real number))
- (delq t (list 'and (cl-make-type-test val (car type))
+ (delete* t (list 'and (cl-make-type-test val (car type))
(if (memq (cadr type) '(* nil)) t
(if (consp (cadr type)) (list '> val (caadr type))
(list '>= val (cadr type))))
＠＠ -3086,7 +3086,7 ＠＠
(list 'eval-when '(compile load eval)
(cl-transform-function-property
func 'cl-compiler-macro
- (cons (if (memq '&whole args) (delq '&whole args)
+ (cons (if (memq '&whole args) (delete* '&whole args)
(cons '--cl-whole-arg-- args)) body))
(list 'or (list 'get (list 'quote func) '(quote byte-compile))
(list 'put (list 'quote func) '(quote byte-compile)
＠＠ -3519,7 +3519,7 ＠＠
(cl-seq begin))
(while cl-seq
(setq cl-seq (setcdr cl-seq
- (delq (car cl-seq) (cdr cl-seq)))))
+ (delete* (car cl-seq) (cdr cl-seq)))))
begin))
((or (plists-equal cl-keys '(:test 'equal) t)
(plists-equal cl-keys '(:test #'equal) t))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/cus-edit.el
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
＠＠ -2964,7 +2964,7 ＠＠
(defun widget-face-value-delete (widget)
;; Remove the child from the options.
(let ((child (car (widget-get widget :children))))
- (setq custom-options (delq child custom-options))
+ (setq custom-options (delete* child custom-options))
(widget-children-value-delete widget)))
(defvar face-history nil
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/easymenu.el
--- a/lisp/easymenu.el
+++ b/lisp/easymenu.el
＠＠ -223,7 +223,7 ＠＠
(when (featurep 'menubar)
(setq
;; Remove this menu from the list of popups we know about.
- easy-menu-all-popups (delq menu easy-menu-all-popups)
+ easy-menu-all-popups (delete* menu easy-menu-all-popups)
;; If there are multiple popup menus available, make the popup menu
;; normally shown with button-3 a menu of them. If there is just one,
;; make that button show it, and no super-menu.
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/files.el
--- a/lisp/files.el
+++ b/lisp/files.el
＠＠ -2838,7 +2838,7 ＠＠
(let ((localval (copy-list (symbol-value hook)))
(globalval (copy-list (default-value hook))))
(if (memq t localval)
- (setq localval (append (delq t localval) (delq t globalval))))
+ (setq localval (append (delete* t localval) (delete* t globalval))))
localval))
(defun basic-save-buffer ()
＠＠ -4065,13 +4065,9 ＠＠
(file-directory-p (directory-file-name (car dirs))))
(let ((this-dir-contents
;; Filter out "." and ".."
- (delq nil
- (mapcar #'(lambda (name)
- (unless (string-match "\\`\\.\\.?\\'"
- (file-name-nondirectory name))
- name))
- (directory-files (or (car dirs) ".") full
- (wildcard-to-regexp nondir))))))
+ (nset-difference (directory-files (or (car dirs) ".") full
+ (wildcard-to-regexp nondir))
+ '("." "..") :test #'equal)))
(setq contents
(nconc
(if (and (car dirs) (not full))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/font-lock.el
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
＠＠ -987,14 +987,14 ＠＠
;; A new set of keywords is defined. Forget all about
;; our old keywords that should be removed.
(setq font-lock-removed-keywords-alist
- (delq cell font-lock-removed-keywords-alist))
+ (delete* cell font-lock-removed-keywords-alist))
;; Delete all previously removed keywords.
(dolist (kword keywords)
(setcdr cell (delete kword (cdr cell))))
;; Delete the mode cell if empty.
(if (null (cdr cell))
(setq font-lock-removed-keywords-alist
- (delq cell font-lock-removed-keywords-alist)))))))
+ (delete* cell font-lock-removed-keywords-alist)))))))
;; Written by Anders Lindgren <andersl(a)andersl.com>.
;;
＠＠ -1053,7 +1053,7 ＠＠
;; was deleted.
(if (null (cdr top-cell))
(setq font-lock-keywords-alist
- (delq top-cell font-lock-keywords-alist))))
+ (delete* top-cell font-lock-keywords-alist))))
;; Remember the keyword in case it is not local.
(let ((cell (assq mode font-lock-removed-keywords-alist)))
(if cell
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/frame.el
--- a/lisp/frame.el
+++ b/lisp/frame.el
＠＠ -218,7 +218,7 ＠＠
;; frame, then we need to create the opening frame. Make sure
;; it has a minibuffer, but let initial-frame-plist omit the
;; minibuffer spec.
- (or (delq terminal-frame (minibuffer-frame-list))
+ (or (delete* terminal-frame (minibuffer-frame-list))
(progn
(setq frame-initial-frame-plist
(append initial-frame-plist default-frame-plist))
＠＠ -230,8 +230,8 ＠＠
(setq default-minibuffer-frame
(setq frame-initial-frame
(make-frame initial-frame-plist
- (car (delq terminal-device
- (device-list))))))
+ (car (delete* terminal-device
+ (device-list))))))
;; Delete any specifications for window geometry properties
;; so that we won't reapply them in frame-notice-user-settings.
;; It would be wrong to reapply them then,
＠＠ -465,7 +465,7 ＠＠
;; The initial frame, which we are about to delete, may be
;; the only frame with a minibuffer. If it is, create a
;; new one.
- (or (delq frame-initial-frame (minibuffer-frame-list))
+ (or (delete* frame-initial-frame (minibuffer-frame-list))
(make-initial-minibuffer-frame nil))
;; If the initial frame is serving as a surrogate
＠＠ -991,7 +991,7 ＠＠
(face-list-to-change (face-list)))
(when (eq (device-type) 'mswindows)
(setq face-list-to-change
- (delq 'border-glyph face-list-to-change)))
+ (delete* 'border-glyph face-list-to-change)))
;; FIXME: Is it sufficient to just change the default face, due to
;; face inheritance?
(dolist (face face-list-to-change)
＠＠ -1325,7 +1325,7 ＠＠
(unless frame
(setq frame (selected-frame)))
(let* ((mini-frame (window-frame (minibuffer-window frame)))
- (frames (delq mini-frame (delq frame (frame-list)))))
+ (frames (delete* mini-frame (delete* frame (frame-list)))))
(mapc 'delete-frame frames)))
;; XEmacs change: we still use delete-frame-hook
＠＠ -1699,7 +1699,7 ＠＠
;; but the selected frame should come first, even if it's occluded,
;; to minimize thrashing.
(setq frames (cons (selected-frame)
- (delq (selected-frame) frames)))
+ (delete* (selected-frame) frames)))
(setq name (symbol-name name))
(while frames
＠＠ -1760,7 +1760,7 ＠＠
(t))))))
;; put the selected frame last. The user wants a new frame,
;; so don't reuse the existing one unless forced to.
- (setq frames (append (delq (selected-frame) frames) (list frames)))
+ (setq frames (append (delete* (selected-frame) frames) (list frames)))
(if (or (eq limit 0) ; means create with reckless abandon
(< (length frames) limit))
(get-frame-for-buffer-make-new-frame buffer)
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/gnuserv.el
--- a/lisp/gnuserv.el
+++ b/lisp/gnuserv.el
＠＠ -551,7 +551,7 ＠＠
editing has ended."
(let* ((buf (current-buffer)))
(dolist (client (gnuserv-buffer-clients buf))
- (callf2 delq buf (gnuclient-buffers client))
+ (callf2 delete* buf (gnuclient-buffers client))
;; If no more buffers, kill the client.
(when (null (gnuclient-buffers client))
(gnuserv-kill-client client)))))
＠＠ -588,7 +588,7 ＠＠
;; killing the device, because it would cause a device-dead
;; error when `delete-device' tries to do the job later.
(gnuserv-kill-client client t))))
- (callf2 delq device gnuserv-devices))
+ (callf2 delete* device gnuserv-devices))
(add-hook 'delete-device-hook 'gnuserv-check-device)
＠＠ -608,7 +608,7 ＠＠
the function will not remove the frames associated with the client."
;; Order is important: first delete client from gnuserv-clients, to
;; prevent gnuserv-buffer-done-1 calling us recursively.
- (callf2 delq client gnuserv-clients)
+ (callf2 delete* client gnuserv-clients)
;; Process the buffers.
(mapc 'gnuserv-buffer-done-1 (gnuclient-buffers client))
(unless leave-frame
＠＠ -636,7 +636,7 ＠＠
;; Do away with the buffer.
(defun gnuserv-buffer-done-1 (buffer)
(dolist (client (gnuserv-buffer-clients buffer))
- (callf2 delq buffer (gnuclient-buffers client))
+ (callf2 delete* buffer (gnuclient-buffers client))
(when (null (gnuclient-buffers client))
(gnuserv-kill-client client)))
;; Get rid of the buffer.
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/gtk-font-menu.el
--- a/lisp/gtk-font-menu.el
+++ b/lisp/gtk-font-menu.el
＠＠ -146,7 +146,7 ＠＠
done)
(setq sizes (cons (car common) sizes)))
(setq common (cdr common)))
- (setq sizes (delq 0 sizes))))
+ (setq sizes (delete* 0 sizes))))
(setq families (sort families 'string-lessp)
weights (sort weights 'string-lessp)
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/gutter-items.el
--- a/lisp/gutter-items.el
+++ b/lisp/gutter-items.el
＠＠ -270,10 +270,10 ＠＠
(not in-deletion)
(not (eq first-buf (window-buffer (selected-window frame)))))
(setq buffers (cons (window-buffer (selected-window frame))
- (delq first-buf buffers))))
+ (delete* first-buf buffers))))
;; if we're in deletion ignore the current buffer
(when in-deletion
- (setq buffers (delq (current-buffer) buffers))
+ (setq buffers (delete* (current-buffer) buffers))
(setq first-buf (car buffers)))
;; filter buffers
(when buffers-tab-filter-functions
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/gutter.el
--- a/lisp/gutter.el
+++ b/lisp/gutter.el
＠＠ -91,7 +91,7 ＠＠
(if visible-p
(if (memq prop spec) spec
(cons prop spec))
- (delq prop spec))
+ (delete* prop spec))
(if visible-p (list prop))))
(list prop visible-p)
'force nil locale tag-set)
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/info.el
--- a/lisp/info.el
+++ b/lisp/info.el
＠＠ -798,7 +798,7 ＠＠
(if (re-search-backward regexp beg t)
(throw 'foo t))))
(setq found nil)
- (let ((bufs (delq nil (mapcar 'get-file-buffer
+ (let ((bufs (delete* nil (mapcar 'get-file-buffer
Info-annotations-path)))
(pattern (if (string-match "\\`<<.*>>\\'" qnode) qnode
(format "\"%s\"\\|<<%s>>" qnode qnode)))
＠＠ -1384,7 +1384,7 ＠＠
(let* ((name (format "(%s)%s" (Info-file-name-only file) node))
(found (assoc name Info-history)))
(if found
- (setq Info-history (delq found Info-history)))
+ (setq Info-history (delete* found Info-history)))
(setq Info-history (cons (list name (- point (point-min))
(and (eq (window-buffer)
(current-buffer))
＠＠ -1702,7 +1702,7 ＠＠
(defun Info-build-annotation-completions ()
(or Info-current-annotation-completions
(save-excursion
- (let ((bufs (delq nil (mapcar 'get-file-buffer
+ (let ((bufs (delete* nil (mapcar 'get-file-buffer
Info-annotations-path)))
(compl nil))
(while bufs
＠＠ -2360,7 +2360,7 ＠＠
;; Here it is a feature that assoc is case-sensitive.
(while (setq found (assoc topic matches))
(setq exact (cons found exact)
- matches (delq found matches)))
+ matches (delete* found matches)))
(setq Info-index-alternatives (nconc exact matches)
Info-index-first-alternative (car Info-index-alternatives))
(Info-index-next 0)))
＠＠ -2528,7 +2528,7 ＠＠
(defun Info-reannotate-node ()
- (let ((bufs (delq nil (mapcar 'get-file-buffer Info-annotations-path))))
+ (let ((bufs (delete* nil (mapcar 'get-file-buffer Info-annotations-path))))
(if bufs
(let ((ibuf (current-buffer))
(file (concat "\\(" (regexp-quote
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/itimer.el
--- a/lisp/itimer.el
+++ b/lisp/itimer.el
＠＠ -316,7 +316,7 ＠＠
(defun delete-itimer (itimer)
"Deletes ITIMER. ITIMER may be an itimer or the name of one."
(check-itimer-coerce-string itimer)
- (setq itimer-list (delq itimer itimer-list)))
+ (setq itimer-list (delete* itimer itimer-list)))
(defun start-itimer (name function value &optional restart
is-idle with-args &rest function-arguments)
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/lib-complete.el
--- a/lisp/lib-complete.el
+++ b/lisp/lib-complete.el
＠＠ -180,7 +180,7 ＠＠
(new-cache-records (list (list root modtimes table))))
(if (not cache-entry) nil
;; Remove old cache entry
- (setq lib-complete:cache (delq cache-entry lib-complete:cache))
+ (setq lib-complete:cache (delete* cache-entry lib-complete:cache))
;; Copy non-redundant entries from old cache entry
(while cache-records
(if (or (equal root (nth 0 (car cache-records)))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/loadhist.el
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
＠＠ -185,7 +185,7 ＠＠
((consp x)
;; Remove any feature names that this file provided.
(if (eq (car x) 'provide)
- (setq features (delq (cdr x) features))
+ (setq features (delete* (cdr x) features))
(if (eq (car x) 'module)
(setq unloading-module t))))
((and (boundp x)
＠＠ -201,7 +201,7 ＠＠
(cdr flist)))
;; Delete the load-history element for this file.
(let ((elt (assoc file load-history)))
- (setq load-history (delq elt load-history)))
+ (setq load-history (delete* elt load-history)))
;; If it is a module, really unload it.
(if unloading-module
(declare-fboundp (unload-module (symbol-name feature))))))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/menubar-items.el
--- a/lisp/menubar-items.el
+++ b/lisp/menubar-items.el
＠＠ -1806,7 +1806,7 ＠＠
(funcall fn buffer)
(funcall fn buffer n))))
(if complex-buffers-menu-p
- (delq nil
+ (delete* nil
(list line
(vector "S%_witch to Buffer"
(list buffers-menu-switch-to-buffer-function
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/menubar.el
--- a/lisp/menubar.el
+++ b/lisp/menubar.el
＠＠ -352,8 +352,8 ＠＠
;; the menubar is the only special case, because other menus begin
;; with their name.
(if (eq parent current-menubar)
- (setq current-menubar (delq item parent))
- (delq item parent))
+ (setq current-menubar (delete* item parent))
+ (delete* item parent))
(set-menubar-dirty-flag)
item)))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/msw-font-menu.el
--- a/lisp/msw-font-menu.el
+++ b/lisp/msw-font-menu.el
＠＠ -118,7 +118,7 ＠＠
done)
(setq sizes (cons (car common) sizes)))
(setq common (cdr common)))
- (setq sizes (delq 0 sizes))))
+ (setq sizes (delete* 0 sizes))))
(setq families (sort families 'string-lessp)
weights (sort weights 'string-lessp)
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/mule/make-coding-system.el
--- a/lisp/mule/make-coding-system.el
+++ b/lisp/mule/make-coding-system.el
＠＠ -90,7 +90,7 ＠＠
(loop for char across decode-table
do (pushnew (char-charset char) known-charsets))
- (setq known-charsets (delq 'ascii known-charsets))
+ (setq known-charsets (delete* 'ascii known-charsets))
(loop for known-charset in known-charsets
do
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/next-error.el
--- a/lisp/next-error.el
+++ b/lisp/next-error.el
＠＠ -137,14 +137,14 ＠＠
(or
;; 1. If one window on the selected frame displays such buffer, return it.
(let ((window-buffers
- (delete-dups
- (delq nil (mapcar (lambda (w)
- (if (next-error-buffer-p
- (window-buffer w)
- avoid-current
- extra-test-inclusive extra-test-exclusive)
- (window-buffer w)))
- (window-list))))))
+ (delete-duplicates
+ (mapcan #'(lambda (w)
+ (if (next-error-buffer-p
+ (window-buffer w)
+ avoid-current
+ extra-test-inclusive extra-test-exclusive)
+ (list (window-buffer w))))
+ (window-list)))))
(if (eq (length window-buffers) 1)
(car window-buffers)))
;; 2. If next-error-last-buffer is an acceptable buffer, use that.
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/obsolete.el
--- a/lisp/obsolete.el
+++ b/lisp/obsolete.el
＠＠ -410,7 +410,8 ＠＠
"Return a list of charsets in the STRING except ascii.
It might be available for compatibility with Mule 2.3,
because its `find-charset-string' ignores ASCII charset."
- (delq 'ascii (and-fboundp 'charsets-in-string (charsets-in-string string))))
+ (delete* 'ascii
+ (and-fboundp 'charsets-in-string (charsets-in-string string))))
(make-obsolete 'find-non-ascii-charset-string
"use (delq 'ascii (charsets-in-string STRING)) instead.")
＠＠ -418,8 +419,8 ＠＠
"Return a list of charsets except ascii in the region between START and END.
It might be available for compatibility with Mule 2.3,
because its `find-charset-string' ignores ASCII charset."
- (delq 'ascii (and-fboundp 'charsets-in-region
- (charsets-in-region start end))))
+ (delete* 'ascii (and-fboundp 'charsets-in-region
+ (charsets-in-region start end))))
(make-obsolete 'find-non-ascii-charset-region
"use (delq 'ascii (charsets-in-region START END)) instead.")
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/occur.el
--- a/lisp/occur.el
+++ b/lisp/occur.el
＠＠ -365,24 +365,21 ＠＠
(occur-read-primary-args)))
(when bufregexp
(occur-1 regexp nlines
- (delq nil
- (mapcar (lambda (buf)
- (when (and (buffer-file-name buf)
- (string-match bufregexp
- (buffer-file-name buf)))
- buf))
- (buffer-list))))))
+ (mapcan #'(lambda (buf)
+ (when (and (buffer-file-name buf)
+ (string-match bufregexp
+ (buffer-file-name buf)))
+ (list buf)))
+ (buffer-list)))))
(defun occur-1 (regexp nlines bufs &optional buf-name)
(unless buf-name
(setq buf-name "*Occur*"))
(let (occur-buf
- (active-bufs (delq nil (mapcar #'(lambda (buf)
- (when (buffer-live-p buf) buf))
- bufs))))
+ (active-bufs (remove-if-not #'buffer-live-p bufs)))
;; Handle the case where one of the buffers we're searching is the
;; output buffer. Just rename it.
- (when (member buf-name (mapcar 'buffer-name active-bufs))
+ (when (position buf-name active-bufs :test #'equal :key #'buffer-name)
(with-current-buffer (get-buffer buf-name)
(rename-uniquely)))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/packages.el
--- a/lisp/packages.el
+++ b/lisp/packages.el
＠＠ -85,12 +85,11 ＠＠
"Load path for packages last in the load path.")
(defun packages-package-hierarchy-directory-names ()
- "Returns a list package hierarchy directory names.
+ "Returns a list of package hierarchy directory names.
These are the valid immediate directory names of package
directories, directories with higher priority first"
- (delq nil `("site-packages"
- ,(when (featurep 'mule) "mule-packages")
- "xemacs-packages")))
+ `("site-packages" ,＠(when (featurep 'mule) '("mule-packages"))
+ "xemacs-packages"))
(defun package-get-key-1 (info key)
"Locate keyword `key' in list."
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/process.el
--- a/lisp/process.el
+++ b/lisp/process.el
＠＠ -707,7 +707,8 ＠＠
(cond ((string-match pattern (car scan))
(setq found t)
(if (eq nil value)
- (setq process-environment (delq (car scan) process-environment))
+ (setq process-environment
+ (delete* (car scan) process-environment))
(setcar scan (concat variable "=" value)))
(setq scan nil)))
(setq scan (cdr scan)))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/simple.el
--- a/lisp/simple.el
+++ b/lisp/simple.el
＠＠ -958,7 +958,7 ＠＠
(if (fixnump (car tail))
(progn
(setq done t)
- (setq buffer-undo-list (delq (car tail) buffer-undo-list))))
+ (setq buffer-undo-list (delete* (car tail) buffer-undo-list))))
(setq tail (cdr tail))))
(and modified (not (buffer-modified-p))
(delete-auto-save-file-if-necessary recent-save)))
＠＠ -2100,7 +2100,7 ＠＠
(loop
for keysym in motion-keys-for-shifted-motion
with key = (event-key last-input-event)
- with mods = (delq 'shift (event-modifiers last-input-event))
+ with mods = (delete* 'shift (event-modifiers last-input-event))
with char-list = '(?a) ;; Some random character; the list will be
;; modified in the constants vector over
;; time.
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/sound.el
--- a/lisp/sound.el
+++ b/lisp/sound.el
＠＠ -174,8 +174,7 ＠＠
(erase-buffer))
(and buf (kill-buffer buf)))
(let ((old (assq sound-name sound-alist)))
- ;; some conses in sound-alist might have been dumped with emacs.
- (if old (setq sound-alist (delq old (copy-sequence sound-alist)))))
+ (if old (setq sound-alist (remove* old sound-alist))))
(setq sound-alist (cons
(nconc (list sound-name)
(if (and volume (not (eq 0 volume)))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/wid-edit.el
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
＠＠ -2332,7 +2332,7 ＠＠
(defun widget-field-value-delete (widget)
"Remove the widget from the list of active editing fields."
- (setq widget-field-list (delq widget widget-field-list))
+ (setq widget-field-list (delete* widget widget-field-list))
;; These are nil if the :format string doesn't contain `%v'.
(let ((extent (widget-get widget :field-extent)))
(when extent
＠＠ -2676,7 +2676,7 ＠＠
(let ((vals (widget-match-inline answer values)))
(setq found (append found (car vals))
values (cdr vals)
- args (delq answer args))))
+ args (delete* answer args))))
(greedy
(setq rest (append rest (list (car values)))
values (cdr values)))
＠＠ -2697,7 +2697,7 ＠＠
(let ((match (widget-match-inline answer vals)))
(setq found (cons (cons answer (car match)) found)
vals (cdr match)
- args (delq answer args))))
+ args (delete* answer args))))
(greedy
(setq vals (cdr vals)))
(t
＠＠ -3091,7 +3091,7 ＠＠
buttons (cdr buttons))
(when (eq (widget-get button :widget) child)
(widget-put widget
- :buttons (delq button (widget-get widget :buttons)))
+ :buttons (delete* button (widget-get widget :buttons)))
(widget-delete button))))
(let ((entry-from (widget-get child :entry-from))
(entry-to (widget-get child :entry-to))
＠＠ -3102,7 +3102,7 ＠＠
(delete-region entry-from entry-to)
(set-marker entry-from nil)
(set-marker entry-to nil))
- (widget-put widget :children (delq child (widget-get widget :children))))
+ (widget-put widget :children (delete* child (widget-get widget :children))))
(widget-setup)
(widget-apply widget :notify widget))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/window.el
--- a/lisp/window.el
+++ b/lisp/window.el
＠＠ -580,7 +580,7 ＠＠
;; Get rid of the frame, if it has just one dedicated window
;; and other visible frames exist.
(and (or (window-minibuffer-p) (window-dedicated-p window))
- (delq frame (visible-frame-list))
+ (delete* frame (visible-frame-list))
window-solitary
(if (and (eq default-minibuffer-frame frame)
(eql 1 (length (minibuffer-frame-list))))
diff -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 -r cc6f0266bc367884f3d0d8cda3f82528935743ef lisp/x-font-menu.el
--- a/lisp/x-font-menu.el
+++ b/lisp/x-font-menu.el
＠＠ -233,7 +233,7 ＠＠
done)
(setq sizes (cons (car common) sizes)))
(setq common (cdr common)))
- (setq sizes (delq 0 sizes))))
+ (setq sizes (delete* 0 sizes))))
(setq families (sort families 'string-lessp)
weights (sort weights 'string-lessp)
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/XEmacs: kehoea: Improve for-effect handling in a few places, lisp/
12 years, 8 months
Bitbucket
Bitbucket
1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/ae2fdb1fd9e0/
changeset: ae2fdb1fd9e0
user: kehoea
date: 2012-05-01 13:43:22
summary: Improve for-effect handling in a few places, lisp/
lisp/ChangeLog addition:
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
* byte-optimize.el (byte-optimize-or):
Improve handling of for-effect here; we don't need to worry about
discarding multiple values when for-effect is non-nil, this
applies to both #'prog1 and #'or.
* bytecomp.el (progn):
* bytecomp.el (byte-compile-file-form-progn): New.
Put back this function, since it's for-effect there's no need to
worry about passing back multiple values.
* cl-macs.el (cl-pop2):
* cl-macs.el (cl-do-pop):
* cl-macs.el (remf):
* cl.el (pop):
Expand to (prog1 (car-safe PLACE) (setq PLACE (cdr PLACE))) in all
these macros, since that optimizes better (especially for-effect
handling) when byte-compile-delete-errors is nil.
affected #: 5 files
diff -r 7fa8667cdaa732afd502dd72f088e5f3d9e00478 -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
＠＠ -1,3 +1,22 ＠＠
+2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ * byte-optimize.el (byte-optimize-or):
+ Improve handling of for-effect here; we don't need to worry about
+ discarding multiple values when for-effect is non-nil, this
+ applies to both #'prog1 and #'or.
+ * bytecomp.el (progn):
+ * bytecomp.el (byte-compile-file-form-progn): New.
+ Put back this function, since it's for-effect there's no need to
+ worry about passing back multiple values.
+ * cl-macs.el (cl-pop2):
+ * cl-macs.el (cl-do-pop):
+ * cl-macs.el (remf):
+ * cl.el (pop):
+ Expand to (prog1 (car-safe PLACE) (setq PLACE (cdr PLACE))) in all
+ these macros, since that optimizes better (especially for-effect
+ handling) when byte-compile-delete-errors is nil.
+
2012-04-23 Michael Sperber <mike(a)xemacs.org>
* bytecomp.el (batch-byte-recompile-directory): Accept an optional
diff -r 7fa8667cdaa732afd502dd72f088e5f3d9e00478 -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el
+++ b/lisp/byte-optimize.el
＠＠ -431,7 +431,7 ＠＠
(byte-optimize-form (nth 1 form) for-effect)))
((eq fn 'prog1)
(if (cdr (cdr form))
- (cons 'prog1
+ (cons (if for-effect 'progn 'prog1)
(cons (byte-optimize-form (nth 1 form) for-effect)
(byte-optimize-body (cdr (cdr form)) t)))
(byte-optimize-form `(or ,(nth 1 form) nil) for-effect)))
＠＠ -537,6 +537,12 ＠＠
(setq tmp (byte-optimize-side-effect-free-p form))
(or byte-compile-delete-errors
(eq tmp 'error-free)
+ ;; XEmacs; GNU handles the expansion of (pop foo) specially
+ ;; here. We changed the macro to expand to (prog1 (car-safe
+ ;; PLACE) (setq PLACE (cdr PLACE))) , which has the same
+ ;; effect. (This only matters when
+ ;; byte-compile-delete-errors is nil, which is usually true
+ ;; for GNU and usually false for XEmacs.)
(progn
(byte-compile-warn "%s called for effect"
(prin1-to-string form))
＠＠ -947,20 +953,17 ＠＠
(defun byte-optimize-or (form)
;; Throw away unneeded nils, and simplify if less than 2 args.
;; XEmacs; change to be more careful about discarding multiple values.
- (let* ((memqueued (memq nil form))
- (trailing-nil (and (cdr memqueued)
- (equal '(nil) (last form))))
- rest)
- ;; A trailing nil indicates to discard multiple values, and we need to
- ;; respect that:
- (when (and memqueued (cdr memqueued))
- (setq form (delq nil (copy-sequence form)))
- (when trailing-nil
- (setcdr (last form) '(nil))))
- (setq rest form)
- ;; If there is a literal non-nil constant in the args to `or', throw
- ;; away all following forms. We can do this because a literal non-nil
- ;; constant cannot be multiple.
+ (if (memq nil form)
+ (setq form (remove* nil form
+ ;; A trailing nil indicates to discard multiple
+ ;; values, and we need to respect that. No need if
+ ;; this is for-effect, though, multiple values
+ ;; will be discarded anyway.
+:end (if (not for-effect) (1- (length form))))))
+ ;; If there is a literal non-nil constant in the args to `or', throw
+ ;; away all following forms. We can do this because a literal non-nil
+ ;; constant cannot be multiple.
+ (let ((rest form))
(while (cdr (setq rest (cdr rest)))
(if (byte-compile-trueconstp (car rest))
(setq form (copy-sequence form)
diff -r 7fa8667cdaa732afd502dd72f088e5f3d9e00478 -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 lisp/bytecomp.el
--- a/lisp/bytecomp.el
+++ b/lisp/bytecomp.el
＠＠ -2411,29 +2411,13 ＠＠
(eval form)
(byte-compile-keep-pending form 'byte-compile-normal-call))
-;; XEmacs change: be careful about multiple values with these three forms.
-(put 'progn 'byte-hunk-handler
- #'(lambda (form)
- (mapc 'byte-compile-file-form (cdr form))
- ;; Return nil so the forms are not output twice.
- nil))
-
-(put 'prog1 'byte-hunk-handler
- #'(lambda (form)
- (when (first form)
- (byte-compile-file-form `(or ,(first form) nil))
- (mapc 'byte-compile-file-form (cdr form))
- nil)))
-
-(put 'prog2 'byte-hunk-handler
- #'(lambda (form)
- (when (first form)
- (byte-compile-file-form (first form))
- (when (second form)
- (setq form (cdr form))
- (byte-compile-file-form `(or ,(first form) nil))
- (mapc 'byte-compile-file-form (cdr form))
- nil))))
+(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
+(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
+(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
+(defun byte-compile-file-form-progn (form)
+ (mapc 'byte-compile-file-form (cdr form))
+ ;; Return nil so the forms are not output twice.
+ nil)
;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner.
diff -r 7fa8667cdaa732afd502dd72f088e5f3d9e00478 -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 lisp/cl-macs.el
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
＠＠ -46,7 +46,7 ＠＠
;;; Code:
(defmacro cl-pop2 (place)
- (list 'prog1 (list 'car (list 'cdr place))
+ (list 'prog1 (list 'car-safe (list 'cdr-safe place))
(list 'setq place (list 'cdr (list 'cdr place)))))
(put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
＠＠ -2456,14 +2456,14 ＠＠
;;;###autoload
(defun cl-do-pop (place)
(if (cl-simple-expr-p place)
- (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
+ (list 'prog1 (list 'car-safe place) (list 'setf place (list 'cdr place)))
(let* ((method (cl-setf-do-modify place t))
(temp (gensym "--pop--")))
(list 'let*
(append (car method)
(list (list temp (nth 2 method))))
(list 'prog1
- (list 'car temp)
+ (list 'car-safe temp)
(cl-setf-do-store (nth 1 method) (list 'cdr temp)))))))
;;;###autoload
diff -r 7fa8667cdaa732afd502dd72f088e5f3d9e00478 -r ae2fdb1fd9e0d4b5152eabf54d239866f60d55e6 lisp/cl.el
--- a/lisp/cl.el
+++ b/lisp/cl.el
＠＠ -152,7 +152,7 ＠＠
careful about evaluating each argument only once and in the right order.
PLACE may be a symbol, or any generalized variable allowed by `setf'."
(if (symbolp place)
- `(car (prog1 ,place (setq ,place (cdr ,place))))
+ `(car-safe (prog1 ,place (setq ,place (cdr ,place))))
(cl-do-pop place)))
(defmacro push (newelt listname)
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments