carbon2-commit: Handle bignum N correctly, #'butlast, #'nbutlast.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5364:cde1608596d0
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Wed Nov 17 14:37:26 2010 +0000
files: src/ChangeLog src/fns.c
description:
Handle bignum N correctly, #'butlast, #'nbutlast.
2010-11-17 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (bignum_butlast): New.
(Fnbutlast, Fbutlast): Use it.
In #'butlast and #'nbutlast, if N is a bignum, we should always
return nil. Bug revealed by Paul Dietz' test suite, thank you
Paul.
diff -r 09fed7053634 -r cde1608596d0 src/ChangeLog
--- a/src/ChangeLog Wed Nov 17 14:30:03 2010 +0000
+++ b/src/ChangeLog Wed Nov 17 14:37:26 2010 +0000
＠＠ -1,3 +1,11 ＠＠
+2010-11-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (bignum_butlast): New.
+ (Fnbutlast, Fbutlast): Use it.
+ In #'butlast and #'nbutlast, if N is a bignum, we should always
+ return nil. Bug revealed by Paul Dietz' test suite, thank you
+ Paul.
+
2010-11-15 Aidan Kehoe <kehoea(a)parhasard.net>
* .gdbinit.in: Remove lrecord_type_popup_data,
diff -r 09fed7053634 -r cde1608596d0 src/fns.c
--- a/src/fns.c Wed Nov 17 14:30:03 2010 +0000
+++ b/src/fns.c Wed Nov 17 14:37:26 2010 +0000
＠＠ -1576,6 +1576,9 ＠＠
return retval;
}
+static Lisp_Object bignum_butlast (Lisp_Object list, Lisp_Object number,
+ Boolint copy);
+
DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
Modify LIST to remove the last N (default 1) elements.
＠＠ -1590,6 +1593,11 ＠＠
if (!NILP (n))
{
+ if (BIGNUMP (n))
+ {
+ return bignum_butlast (list, n, 0);
+ }
+
CHECK_NATNUM (n);
int_n = XINT (n);
}
＠＠ -1638,6 +1646,11 ＠＠
if (!NILP (n))
{
+ if (BIGNUMP (n))
+ {
+ return bignum_butlast (list, n, 1);
+ }
+
CHECK_NATNUM (n);
int_n = XINT (n);
}
＠＠ -1671,6 +1684,42 ＠＠
}
return retval;
+}
+
+/* This is sufficient to implement #'butlast and #'nbutlast with bignum N
+ under XEmacs, because #'list-length and #'safe-length can never return a
+ bignum. This means that #'nbutlast never has to modify and #'butlast
+ never has to copy. */
+static Lisp_Object
+bignum_butlast (Lisp_Object list, Lisp_Object number, Boolint copy)
+{
+ Boolint malformed = EQ (Fsafe_length (list), Qzero);
+ Boolint circular = !malformed && EQ (Flist_length (list), Qnil);
+
+ assert (BIGNUMP (number));
+
+#ifdef HAVE_BIGNUM
+
+ if (bignum_sign (XBIGNUM_DATA (number)) < 0)
+ {
+ dead_wrong_type_argument (Qnatnump, number);
+ }
+
+ number = Fcanonicalize_number (number);
+
+ if (INTP (number))
+ {
+ return copy ? Fbutlast (list, number) : Fnbutlast (list, number);
+ }
+
+#endif
+
+ if (circular)
+ {
+ signal_circular_list_error (list);
+ }
+
+ return Qnil;
}
DEFUN ("member", Fmember, 2, 2, 0, /*
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Handle slightly more complex type specifications, #'coerce, #'typep.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5363:09fed7053634
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Wed Nov 17 14:30:03 2010 +0000
files: lisp/ChangeLog lisp/cl-extra.el lisp/cl-macs.el
description:
Handle slightly more complex type specifications, #'coerce, #'typep.
2010-11-17 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
diff -r 6784adb405ad -r 09fed7053634 lisp/ChangeLog
--- a/lisp/ChangeLog Mon Nov 15 19:31:06 2010 +0000
+++ b/lisp/ChangeLog Wed Nov 17 14:30:03 2010 +0000
＠＠ -1,3 +1,13 ＠＠
+2010-11-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-extra.el (coerce):
+ In the argument list, name the first argument OBJECT, not X; the
+ former name was always used in the doc string and is clearer.
+ Handle vector type specifications which include the length of the
+ target sequence, error if there's a mismatch.
+ * cl-macs.el (cl-make-type-test): Handle type specifications
+ starting with the symbol 'eql.
+
2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
diff -r 6784adb405ad -r 09fed7053634 lisp/cl-extra.el
--- a/lisp/cl-extra.el Mon Nov 15 19:31:06 2010 +0000
+++ b/lisp/cl-extra.el Wed Nov 17 14:30:03 2010 +0000
＠＠ -53,47 +53,67 ＠＠
;;; Type coercion.
-(defun coerce (x type)
+(defun coerce (object type)
"Coerce OBJECT to type TYPE.
TYPE is a Common Lisp type specifier."
- (cond ((eq type 'list) (if (listp x) x (append x nil)))
- ((eq type 'vector) (if (vectorp x) x (vconcat x)))
- ((eq type 'string) (if (stringp x) x (concat x)))
- ((eq type 'array) (if (arrayp x) x (vconcat x)))
- ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
- ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
+ (cond ((eq type 'list) (if (listp object) object (append object nil)))
+ ((eq type 'vector) (if (vectorp object) object (vconcat object)))
+ ((eq type 'string) (if (stringp object) object (concat object)))
+ ((eq type 'array) (if (arrayp object) object (vconcat object)))
+ ((and (eq type 'character) (stringp object)
+ (eql (length object) 1)) (aref object 0))
+ ((and (eq type 'character) (symbolp object))
+ (coerce (symbol-name object) type))
;; XEmacs addition character <-> integer coercions
- ((and (eq type 'character) (char-int-p x)) (int-char x))
- ((and (memq type '(integer fixnum)) (characterp x)) (char-int x))
- ((eq type 'float) (float x))
+ ((and (eq type 'character) (char-int-p object)) (int-char object))
+ ((and (memq type '(integer fixnum)) (characterp object))
+ (char-int object))
+ ((eq type 'float) (float object))
;; XEmacs addition: enhanced numeric type coercions
((and-fboundp 'coerce-number
(memq type '(integer ratio bigfloat fixnum))
- (coerce-number x type)))
+ (coerce-number object type)))
;; XEmacs addition: bit-vector coercion
((or (eq type 'bit-vector)
(eq type 'simple-bit-vector))
- (if (bit-vector-p x) x (apply 'bit-vector (append x nil))))
+ (if (bit-vector-p object)
+ object
+ (apply 'bit-vector (append object nil))))
;; XEmacs addition: weak-list coercion
((eq type 'weak-list)
- (if (weak-list-p x) x
+ (if (weak-list-p object) object
(let ((wl (make-weak-list)))
- (set-weak-list-list wl (if (listp x) x (append x nil)))
+ (set-weak-list-list wl (if (listp object)
+ object
+ (append object nil)))
wl)))
((and
- (consp type)
- (or (eq (car type) 'vector)
- (eq (car type) 'simple-array)
- (eq (car type) 'simple-vector))
- (cond
- ((equal (cdr-safe type) '(*))
- (coerce x 'vector))
- ((equal (cdr-safe type) '(bit))
- (coerce x 'bit-vector))
- ((equal (cdr-safe type) '(character))
- (coerce x 'string)))))
- ((typep x type) x)
- (t (error "Can't coerce %s to type %s" x type))))
+ (memq (car-safe type) '(vector simple-array))
+ (loop
+ for (ignore elements length) = type
+ initially (declare (special ignore))
+ return (if (or (memq length '(* nil)) (eql length (length object)))
+ (cond
+ ((memq elements '(t * nil))
+ (coerce object 'vector))
+ ((memq elements '(string-char character))
+ (coerce object 'string))
+ ((eq elements 'bit)
+ (coerce object 'bit-vector)))
+ (error
+ 'wrong-type-argument
+ "Type specifier length must equal sequence length"
+ type)))))
+ ((eq (car-safe type) 'simple-vector)
+ (coerce object (list* 'vector t (cdr type))))
+ ((memq (car-safe type)
+ '(string simple-string base-string simple-base-string))
+ (coerce object (list* 'vector 'character (cdr type))))
+ ((eq (car-safe type) 'bit-vector)
+ (coerce object (list* 'vector 'bit (cdr type))))
+ ((typep object type) object)
+ (t (error 'invalid-operation
+ "Can't coerce object to type" object type))))
;; XEmacs; #'equalp is in C.
diff -r 6784adb405ad -r 09fed7053634 lisp/cl-macs.el
--- a/lisp/cl-macs.el Mon Nov 15 19:31:06 2010 +0000
+++ b/lisp/cl-macs.el Wed Nov 17 14:30:03 2010 +0000
＠＠ -3116,6 +3116,8 ＠＠
(cdr type))))
((memq (car-safe type) '(member member*))
(list 'and (list 'member* val (list 'quote (cdr type))) t))
+ ((eq (car-safe type) 'eql)
+ (list 'eql (cadr type) val))
((eq (car-safe type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Remove lrecord_type_popup_data, lrecord_type_window_configuration, .gdbinit.in
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5362:6784adb405ad
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Mon Nov 15 19:31:06 2010 +0000
files: src/.gdbinit.in.in src/ChangeLog
description:
Remove lrecord_type_popup_data, lrecord_type_window_configuration, .gdbinit.in
2010-11-15 Aidan Kehoe <kehoea(a)parhasard.net>
* .gdbinit.in: Remove lrecord_type_popup_data,
lrecord_type_window_configuration from this file, they're not
used, and their presence breaks pobj in GDB at runtime for me.
diff -r 4c4085177ca5 -r 6784adb405ad src/.gdbinit.in.in
--- a/src/.gdbinit.in.in Sun Nov 14 14:54:09 2010 +0000
+++ b/src/.gdbinit.in.in Mon Nov 15 19:31:06 2010 +0000
＠＠ -411,9 +411,6 ＠＠
if $lrecord_type == lrecord_type_opaque_ptr
pptype Lisp_Opaque_Ptr
else
- if $lrecord_type == lrecord_type_popup_data
- pptype popup_data
- else
if $lrecord_type == lrecord_type_process
pptype Lisp_Process
else
＠＠ -456,9 +453,6 ＠＠
if $lrecord_type == lrecord_type_window
pstructtype window
else
- if $lrecord_type == lrecord_type_window_configuration
- pstructtype window_config
- else
if $lrecord_type == lrecord_type_fc_pattern
pstructtype fc_pattern
else
＠＠ -470,8 +464,6 ＠＠
## Barf, gag, retch
end
end
- end
- end
end
end
end
diff -r 4c4085177ca5 -r 6784adb405ad src/ChangeLog
--- a/src/ChangeLog Sun Nov 14 14:54:09 2010 +0000
+++ b/src/ChangeLog Mon Nov 15 19:31:06 2010 +0000
＠＠ -1,3 +1,9 ＠＠
+2010-11-15 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * .gdbinit.in: Remove lrecord_type_popup_data,
+ lrecord_type_window_configuration from this file, they're not
+ used, and their presence breaks pobj in GDB at runtime for me.
+
2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Fnreverse):
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Fix some bugs in fns.c, discovered in passing while doing other work.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5361:4c4085177ca5
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Nov 14 14:54:09 2010 +0000
files: src/ChangeLog src/fns.c
description:
Fix some bugs in fns.c, discovered in passing while doing other work.
2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Fnreverse):
Check that non-list sequences are writable from Lisp before
modifying them. (There's an argument that we should do this for
list sequences too, but for the moment other code (e.g. #'setcar)
doesn't.)
(mapcarX): Initialise lisp_vals_staging, lisp_vals_type
explicitly, for the sake of compile warnings. Check if
lisp_vals_staging is non-NULL when deciding whether to replace a
string's range.
(Fsome): Cross-reference to #'find-if in the doc string for this
function.
(Freduce): GCPRO accum in this function, when a key argument is
specicified it can be silently garbage-collected. When deciding
whether to iterate across a string, check whether the cursor
exceeds the byte len; while iterating, increment an integer
counter. Don't ABORT() if check_sequence_range() returns when
handed a suspicious sequence; it is legal to supply the length of
SEQUENCE as the :end keyword value, and this will provoke our
suspicions, legitimately enough. (Problems with this function
revealed by Paul Dietz' ANSI test suite, thank you Paul Dietz.)
(Freplace): Check list sequence lengths using the arguments, not
the conses we're currently looking at, thank you Paul Dietz.
diff -r 6468cf6f0b9d -r 4c4085177ca5 src/ChangeLog
--- a/src/ChangeLog Sun Nov 14 14:13:06 2010 +0000
+++ b/src/ChangeLog Sun Nov 14 14:54:09 2010 +0000
＠＠ -1,3 +1,28 ＠＠
+2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Fnreverse):
+ Check that non-list sequences are writable from Lisp before
+ modifying them. (There's an argument that we should do this for
+ list sequences too, but for the moment other code (e.g. #'setcar)
+ doesn't.)
+ (mapcarX): Initialise lisp_vals_staging, lisp_vals_type
+ explicitly, for the sake of compile warnings. Check if
+ lisp_vals_staging is non-NULL when deciding whether to replace a
+ string's range.
+ (Fsome): Cross-reference to #'find-if in the doc string for this
+ function.
+ (Freduce): GCPRO accum in this function, when a key argument is
+ specicified it can be silently garbage-collected. When deciding
+ whether to iterate across a string, check whether the cursor
+ exceeds the byte len; while iterating, increment an integer
+ counter. Don't ABORT() if check_sequence_range() returns when
+ handed a suspicious sequence; it is legal to supply the length of
+ SEQUENCE as the :end keyword value, and this will provoke our
+ suspicions, legitimately enough. (Problems with this function
+ revealed by Paul Dietz' ANSI test suite, thank you Paul Dietz.)
+ (Freplace): Check list sequence lengths using the arguments, not
+ the conses we're currently looking at, thank you Paul Dietz.
+
2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Frandom): Correct the docstring here, the name of the
diff -r 6468cf6f0b9d -r 4c4085177ca5 src/fns.c
--- a/src/fns.c Sun Nov 14 14:13:06 2010 +0000
+++ b/src/fns.c Sun Nov 14 14:54:09 2010 +0000
＠＠ -1108,11 +1108,12 ＠＠
sequence = Fnthcdr (make_int (ss), sequence);
}
+ ii = ss + 1;
+
if (ss < ee && !NILP (sequence))
{
result = result_tail = Fcons (Fcar (sequence), Qnil);
sequence = Fcdr (sequence);
- ii = ss + 1;
{
EXTERNAL_LIST_LOOP_2 (elt, sequence)
＠＠ -2128,6 +2129,7 ＠＠
Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
Elemcount half = length / 2;
Lisp_Object swap = Qnil;
+ CHECK_LISP_WRITEABLE (sequence);
while (ii > half)
{
＠＠ -2144,6 +2146,7 ＠＠
Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
+ CHECK_LISP_WRITEABLE (sequence);
while (cursor < endp)
{
staging_end -= itext_ichar_len (cursor);
＠＠ -2165,6 +2168,7 ＠＠
Elemcount half = length / 2;
int swap = 0;
+ CHECK_LISP_WRITEABLE (sequence);
while (ii > half)
{
swap = bit_vector_bit (bv, length - ii);
＠＠ -4450,7 +4454,7 ＠＠
{
Lisp_Object called, *args;
struct gcpro gcpro1, gcpro2;
- Ibyte *lisp_vals_staging, *cursor;
+ Ibyte *lisp_vals_staging = NULL, *cursor = NULL;
int i, j;
assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1);
＠＠ -4497,7 +4501,7 ＠＠
}
else
{
- enum lrecord_type lisp_vals_type;
+ enum lrecord_type lisp_vals_type = lrecord_type_symbol;
Binbyte *sequence_types = alloca_array (Binbyte, nsequences);
for (j = 0; j < nsequences; ++j)
{
＠＠ -4516,6 +4520,10 ＠＠
lisp_vals_staging = cursor
= alloca_ibytes (call_count * MAX_ICHAR_LEN);
}
+ else if (ARRAYP (lisp_vals))
+ {
+ CHECK_LISP_WRITEABLE (lisp_vals);
+ }
}
for (i = 0; i < call_count; ++i)
＠＠ -4641,9 +4649,9 ＠＠
}
}
- if (!EQ (caller, Qsome) && !EQ (caller, Qevery) &&
- lrecord_type_string == lisp_vals_type)
- {
+ if (lisp_vals_staging != NULL)
+ {
+ CHECK_LISP_WRITEABLE (lisp_vals);
replace_string_range (lisp_vals, Qzero, make_int (call_count),
lisp_vals_staging, cursor);
}
＠＠ -4659,7 +4667,7 ＠＠
shortest_length_among_sequences (int nsequences, Lisp_Object *sequences)
{
Elemcount len = EMACS_INT_MAX;
- Lisp_Object length;
+ Lisp_Object length = Qnil;
int i;
for (i = 0; i < nsequences; ++i)
＠＠ -4953,6 +4961,10 ＠＠
With optional SEQUENCES, call PREDICATE each time with as many arguments as
there are SEQUENCES (plus one for the element from SEQUENCE).
+See also `find-if', which returns the corresponding element of SEQUENCE,
+rather than the value given by PREDICATE, and accepts bounding index
+keywords.
+
arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
*/
(int nargs, Lisp_Object *args))
＠＠ -5205,10 +5217,13 ＠＠
if (VECTORP (sequence))
{
Lisp_Vector *vv = XVECTOR (sequence);
+ struct gcpro gcpro1;
check_sequence_range (sequence, start, end, make_int (vv->size));
ending = min (ending, vv->size);
+
+ GCPRO1 (accum);
if (!UNBOUNDP (initial_value))
{
＠＠ -5242,14 +5257,18 ＠＠
accum = CALL2 (function, KEY (key, vv->contents[ii]), accum);
}
}
+
+ UNGCPRO;
}
else if (BIT_VECTORP (sequence))
{
Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
+ struct gcpro gcpro1;
check_sequence_range (sequence, start, end, make_int (bv->size));
-
ending = min (ending, bv->size);
+
+ GCPRO1 (accum);
if (!UNBOUNDP (initial_value))
{
＠＠ -5287,9 +5306,16 ＠＠
accum);
}
}
+
+ UNGCPRO;
+
}
else if (STRINGP (sequence))
{
+ struct gcpro gcpro1;
+
+ GCPRO1 (accum);
+
if (NILP (from_end))
{
Bytecount byte_len = XSTRING_LENGTH (sequence);
＠＠ -5307,7 +5333,7 ＠＠
{
accum = initial_value;
}
- else if (ending - starting)
+ else if (ending - starting && cursor_offset < byte_len)
{
accum = KEY (key, make_char (itext_ichar (cursor)));
starting++;
＠＠ -5322,6 +5348,7 ＠＠
INC_IBYTEPTR (cursor);
cursor_offset = cursor - startp;
+ ii++;
}
while (cursor_offset < byte_len && ii < ending)
＠＠ -5346,7 +5373,6 ＠＠
if (ii < starting || (ii < ending && !NILP (end)))
{
check_sequence_range (sequence, start, end, Flength (sequence));
- ABORT ();
}
}
else
＠＠ -5356,7 +5382,6 ＠＠
const Ibyte *cursor;
check_sequence_range (sequence, start, end, make_int (len));
-
ending = min (ending, len);
cursor = string_char_addr (sequence, ending - 1);
cursor_offset = cursor - XSTRING_DATA (sequence);
＠＠ -5403,15 +5428,17 ＠＠
}
}
}
+
+ UNGCPRO;
}
else if (LISTP (sequence))
{
if (NILP (from_end))
{
- struct gcpro gcpro1;
+ struct gcpro gcpro1, gcpro2;
Lisp_Object tailed = Qnil;
- GCPRO1 (tailed);
+ GCPRO2 (tailed, accum);
if (!UNBOUNDP (initial_value))
{
＠＠ -5464,7 +5491,6 ＠＠
if (ii < starting || (ii < ending && !NILP (end)))
{
check_sequence_range (sequence, start, end, Flength (sequence));
- ABORT ();
}
}
else
＠＠ -5930,12 +5956,12 ＠＠
if (NILP (sequence1))
{
- check_sequence_range (sequence1, start1, end1,
+ check_sequence_range (args[0], start1, end1,
make_int (XINT (start1) + shortest_len));
}
else if (NILP (sequence2))
{
- check_sequence_range (sequence2, start2, end2,
+ check_sequence_range (args[1], start2, end2,
make_int (XINT (start2) + shortest_len));
}
}
＠＠ -5998,7 +6024,7 ＠＠
if (NILP (sequence1))
{
- check_sequence_range (sequence1, start1, end1,
+ check_sequence_range (args[0], start1, end1,
make_int (XINT (start1) + starting1));
}
}
＠＠ -6055,7 +6081,7 ＠＠
if (NILP (sequence2))
{
- check_sequence_range (sequence2, start2, end2,
+ check_sequence_range (args[1], start2, end2,
make_int (XINT (start2) + starting2));
}
}
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Correct argument name in docstring, #'random.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5360:6468cf6f0b9d
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Nov 14 14:13:06 2010 +0000
files: src/ChangeLog src/fns.c
description:
Correct argument name in docstring, #'random.
2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Frandom): Correct the docstring here, the name of the
argument is LIMIT, not N.
diff -r ec05a30f7148 -r 6468cf6f0b9d src/ChangeLog
--- a/src/ChangeLog Sun Nov 14 13:46:29 2010 +0000
+++ b/src/ChangeLog Sun Nov 14 14:13:06 2010 +0000
＠＠ -1,3 +1,8 ＠＠
+2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Frandom): Correct the docstring here, the name of the
+ argument is LIMIT, not N.
+
2010-11-06 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecode.c (bytecode_nreverse): Call Fnreverse() if SEQUENCE is
diff -r ec05a30f7148 -r 6468cf6f0b9d src/fns.c
--- a/src/fns.c Sun Nov 14 13:46:29 2010 +0000
+++ b/src/fns.c Sun Nov 14 14:13:06 2010 +0000
＠＠ -214,9 +214,10 ＠＠
DEFUN ("random", Frandom, 0, 1, 0, /*
Return a pseudo-random number.
All fixnums are equally likely. On most systems, this is 31 bits' worth.
-With positive integer argument N, return random number in interval [0,N).
-N can be a bignum, in which case the range of possible values is extended.
-With argument t, set the random number seed from the current time and pid.
+With positive integer argument LIMIT, return random number in interval [0,
+LIMIT). LIMIT can be a bignum, in which case the range of possible values
+is extended. With argument t, set the random number seed from the current
+time and pid.
*/
(limit))
{
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Fix a bytecomp.el bug compiling #'eql, which was masked by cl-macs.el
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5359:ec05a30f7148
parent: 5356:9f738305f80f
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Nov 14 13:46:29 2010 +0000
files: lisp/ChangeLog lisp/bytecomp.el lisp/cl-macs.el
description:
Fix a bytecomp.el bug compiling #'eql, which was masked by cl-macs.el
lisp/ChangeLog addition:
2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
symbol. That was necessary to override a bug in bytecomp.el where
#'eql was confused with #'eq, which bug we no longer have.
If neither expression is constant, don't attempt to handle the
expression in this compiler macro, leave it to byte-compile-eql,
which produces better code anyway.
* bytecomp.el (eq): #'eql is not the function associated with the
byte-eq byte code.
(byte-compile-eql): Add an explicit compile method for this
function, for cases where the cl-macs compiler macro hasn't
reduced it to #'eq or #'equal.
diff -r 9f738305f80f -r ec05a30f7148 lisp/ChangeLog
--- a/lisp/ChangeLog Sat Nov 06 21:18:52 2010 +0000
+++ b/lisp/ChangeLog Sun Nov 14 13:46:29 2010 +0000
＠＠ -1,3 +1,17 ＠＠
+2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (eql): Don't remove the byte-compile property of this
+ symbol. That was necessary to override a bug in bytecomp.el where
+ #'eql was confused with #'eq, which bug we no longer have.
+ If neither expression is constant, don't attempt to handle the
+ expression in this compiler macro, leave it to byte-compile-eql,
+ which produces better code anyway.
+ * bytecomp.el (eq): #'eql is not the function associated with the
+ byte-eq byte code.
+ (byte-compile-eql): Add an explicit compile method for this
+ function, for cases where the cl-macs compiler macro hasn't
+ reduced it to #'eq or #'equal.
+
2010-10-25 Aidan Kehoe <kehoea(a)parhasard.net>
Add compiler macros and compilation sanity-checking for various
diff -r 9f738305f80f -r ec05a30f7148 lisp/bytecomp.el
--- a/lisp/bytecomp.el Sat Nov 06 21:18:52 2010 +0000
+++ b/lisp/bytecomp.el Sun Nov 14 13:46:29 2010 +0000
＠＠ -3160,7 +3160,7 ＠＠
(byte-defop-compiler fixnump 1)
(byte-defop-compiler skip-chars-forward 1-2+1)
(byte-defop-compiler skip-chars-backward 1-2+1)
-(byte-defop-compiler (eql byte-eq) 2)
+(byte-defop-compiler eq 2)
(byte-defop-compiler20 old-eq 2)
(byte-defop-compiler20 old-memq 2)
(byte-defop-compiler cons 2)
＠＠ -3909,6 +3909,7 ＠＠
(byte-defop-compiler-1 let*)
(byte-defop-compiler-1 integerp)
+(byte-defop-compiler-1 eql)
(byte-defop-compiler-1 fillarray)
(defun byte-compile-progn (form)
＠＠ -4142,6 +4143,24 ＠＠
(byte-compile-discard)
(byte-compile-constant t)
(byte-compile-out-tag donetag))))
+
+(defun byte-compile-eql (form)
+ (if (eql 3 (length form))
+ (let ((donetag (byte-compile-make-tag))
+ (eqtag (byte-compile-make-tag)))
+ (mapc 'byte-compile-form (cdr form))
+ (byte-compile-out 'byte-dup 0)
+ (byte-compile-out 'byte-numberp 0)
+ (byte-compile-goto 'byte-goto-if-nil eqtag)
+ (byte-compile-out 'byte-dup 0)
+ (byte-compile-out 'byte-fixnump 0)
+ (byte-compile-goto 'byte-goto-if-not-nil eqtag)
+ (byte-compile-out 'byte-equal 0)
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag eqtag)
+ (byte-compile-out 'byte-eq 0)
+ (byte-compile-out-tag donetag))
+ (byte-compile-subr-wrong-args form 2)))
;;(byte-defop-compiler-1 /= byte-compile-negated)
(byte-defop-compiler-1 atom byte-compile-negated)
diff -r 9f738305f80f -r ec05a30f7148 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sat Nov 06 21:18:52 2010 +0000
+++ b/lisp/cl-macs.el Sun Nov 14 13:46:29 2010 +0000
＠＠ -3270,7 +3270,6 ＠＠
(defun cl-non-fixnum-number-p (object)
(and (numberp object) (not (fixnump object))))
-(put 'eql 'byte-compile nil)
(define-compiler-macro eql (&whole form a b)
(cond ((eq (cl-const-expr-p a) t)
(let ((val (cl-const-expr-val a)))
＠＠ -3282,15 +3281,6 ＠＠
(if (cl-non-fixnum-number-p val)
(list 'equal a b)
(list 'eq a b))))
- ((cl-simple-expr-p a 5)
- (list 'if (list 'numberp a)
- (list 'equal a b)
- (list 'eq a b)))
- ((and (cl-safe-expr-p a)
- (cl-simple-expr-p b 5))
- (list 'if (list 'numberp b)
- (list 'equal a b)
- (list 'eq a b)))
(t form)))
(macrolet
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Loop at macroexpansion time when sanity-checking :start, :end keyword args.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1295790997 0
# Node ID fd441b85d76087b9b14340ff1ed090b3c3abc1da
# Parent b4ef3128160cd912415eee1f987c2b9fe631c5fc
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
When sanity-checking :start and :end keyword arguments, loop at
macroexpansion time, not runtime, allowing us to pick up any
compiler macros and giving a clearer *Test-Log* buffer.
diff -r b4ef3128160c -r fd441b85d760 tests/ChangeLog
--- a/tests/ChangeLog Sun Jan 23 13:13:54 2011 +0000
+++ b/tests/ChangeLog Sun Jan 23 13:56:37 2011 +0000
＠＠ -1,3 +1,10 ＠＠
+2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ When sanity-checking :start and :end keyword arguments, loop at
+ macroexpansion time, not runtime, allowing us to pick up any
+ compiler macros and giving a clearer *Test-Log* buffer.
+
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (test-fun):
diff -r b4ef3128160c -r fd441b85d760 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Jan 23 13:13:54 2011 +0000
+++ b/tests/automated/lisp-tests.el Sun Jan 23 13:56:37 2011 +0000
＠＠ -2682,115 +2682,154 ＠＠
(string (make-string string-length
(or (decode-char 'ucs #x20ac) ?\xFF)))
(item 'cons))
- (dolist (function '(count position find delete* remove* reduce))
- (Check-Error args-out-of-range
- (funcall function item list
-:start (1+ list-length) :end (1+ list-length)))
- (Check-Error wrong-type-argument
- (funcall function item list
-:start -1 :end list-length))
- (Check-Error args-out-of-range
- (funcall function item list :end (* 2 list-length)))
- (Check-Error args-out-of-range
- (funcall function item vector
-:start (1+ vector-length) :end (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function item vector :start -1))
- (Check-Error args-out-of-range
- (funcall function item vector :end (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function item bit-vector
-:start (1+ vector-length) :end (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function item bit-vector :start -1))
- (Check-Error args-out-of-range
- (funcall function item bit-vector :end (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function item string
-:start (1+ string-length) :end (1+ string-length)))
- (Check-Error wrong-type-argument
- (funcall function item string :start -1))
- (Check-Error args-out-of-range
- (funcall function item string :end (* 2 string-length))))
- (dolist (function '(delete-duplicates remove-duplicates))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence list)
-:start (1+ list-length) :end (1+ list-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence list)
-:start -1 :end list-length))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence list)
-:end (* 2 list-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence vector)
-:start (1+ vector-length) :end (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence vector) :start -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence vector)
-:end (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence bit-vector)
-:start (1+ vector-length) :end (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence bit-vector) :start -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence bit-vector)
-:end (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence string)
-:start (1+ string-length) :end (1+ string-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence string) :start -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence string)
-:end (* 2 string-length))))
- (dolist (function '(replace mismatch search))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence list) (copy-sequence list)
-:start1 (1+ list-length) :end1 (1+ list-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence list) (copy-sequence list)
-:start1 -1 :end1 list-length))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence list) (copy-sequence list)
-:end1 (* 2 list-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence vector)
- (copy-sequence vector) :start1 (1+ vector-length)
-:end1 (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence vector)
- (copy-sequence vector) :start1 -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence vector)
- (copy-sequence vector)
-:end1 (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence bit-vector)
- (copy-sequence bit-vector)
-:start1 (1+ vector-length)
-:end1 (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence bit-vector)
- (copy-sequence bit-vector) :start1 -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence bit-vector)
- (copy-sequence bit-vector)
-:end1 (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence string)
- (copy-sequence string)
-:start1 (1+ string-length)
-:end1 (1+ string-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence string)
- (copy-sequence string) :start1 -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence string)
- (copy-sequence string)
-:end1 (* 2 string-length))))))
+ (macrolet
+ ((construct-item-sequence-checks (&rest functions)
+ (cons
+ 'progn
+ (mapcan
+ #'(lambda (function)
+ `((Check-Error args-out-of-range
+ (,function item list
+:start (1+ list-length)
+:end (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (,function item list :start -1
+:end list-length))
+ (Check-Error args-out-of-range
+ (,function item list :end (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (,function item vector
+:start (1+ vector-length)
+:end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function item vector :start -1))
+ (Check-Error args-out-of-range
+ (,function item vector
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function item bit-vector
+:start (1+ vector-length)
+:end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function item bit-vector :start -1))
+ (Check-Error args-out-of-range
+ (,function item bit-vector
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function item string
+:start (1+ string-length)
+:end (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (,function item string :start -1))
+ (Check-Error args-out-of-range
+ (,function item string
+:end (* 2 string-length)))))
+ functions)))
+ (construct-one-sequence-checks (&rest functions)
+ (cons
+ 'progn
+ (mapcan
+ #'(lambda (function)
+ `((Check-Error args-out-of-range
+ (,function (copy-sequence list)
+:start (1+ list-length)
+:end (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence list)
+:start -1 :end list-length))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence list)
+:end (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence vector)
+:start (1+ vector-length)
+:end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence vector) :start -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence vector)
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence bit-vector)
+:start (1+ vector-length)
+:end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence bit-vector)
+:start -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence bit-vector)
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence string)
+:start (1+ string-length)
+:end (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence string) :start -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence string)
+:end (* 2 string-length)))))
+ functions)))
+ (construct-two-sequence-checks (&rest functions)
+ (cons
+ 'progn
+ (mapcan
+ #'(lambda (function)
+ `((Check-Error args-out-of-range
+ (,function (copy-sequence list)
+ (copy-sequence list)
+:start1 (1+ list-length)
+:end1 (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence list)
+ (copy-sequence list)
+:start1 -1 :end1 list-length))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence list)
+ (copy-sequence list)
+:end1 (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence vector)
+ (copy-sequence vector)
+:start1 (1+ vector-length)
+:end1 (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function
+ (copy-sequence vector)
+ (copy-sequence vector) :start1 -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence vector)
+ (copy-sequence vector)
+:end1 (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence bit-vector)
+ (copy-sequence bit-vector)
+:start1 (1+ vector-length)
+:end1 (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence bit-vector)
+ (copy-sequence bit-vector)
+:start1 -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence bit-vector)
+ (copy-sequence bit-vector)
+:end1 (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence string)
+ (copy-sequence string)
+:start1 (1+ string-length)
+:end1 (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence string)
+ (copy-sequence string) :start1 -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence string)
+ (copy-sequence string)
+:end1 (* 2 string-length)))))
+ functions))))
+ (construct-item-sequence-checks count position find delete* remove*
+ reduce)
+ (construct-one-sequence-checks delete-duplicates remove-duplicates)
+ (construct-two-sequence-checks replace mismatch search))))
(let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone))
(vector (map 'vector #'identity list))
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Loop at macroexpansion time when sanity-checking :start, :end keyword args.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5347:fd441b85d760
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jan 23 13:56:37 2011 +0000
files: tests/ChangeLog tests/automated/lisp-tests.el
description:
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
When sanity-checking :start and :end keyword arguments, loop at
macroexpansion time, not runtime, allowing us to pick up any
compiler macros and giving a clearer *Test-Log* buffer.
diff -r b4ef3128160c -r fd441b85d760 tests/ChangeLog
--- a/tests/ChangeLog Sun Jan 23 13:13:54 2011 +0000
+++ b/tests/ChangeLog Sun Jan 23 13:56:37 2011 +0000
＠＠ -1,3 +1,10 ＠＠
+2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ When sanity-checking :start and :end keyword arguments, loop at
+ macroexpansion time, not runtime, allowing us to pick up any
+ compiler macros and giving a clearer *Test-Log* buffer.
+
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (test-fun):
diff -r b4ef3128160c -r fd441b85d760 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Jan 23 13:13:54 2011 +0000
+++ b/tests/automated/lisp-tests.el Sun Jan 23 13:56:37 2011 +0000
＠＠ -2682,115 +2682,154 ＠＠
(string (make-string string-length
(or (decode-char 'ucs #x20ac) ?\xFF)))
(item 'cons))
- (dolist (function '(count position find delete* remove* reduce))
- (Check-Error args-out-of-range
- (funcall function item list
-:start (1+ list-length) :end (1+ list-length)))
- (Check-Error wrong-type-argument
- (funcall function item list
-:start -1 :end list-length))
- (Check-Error args-out-of-range
- (funcall function item list :end (* 2 list-length)))
- (Check-Error args-out-of-range
- (funcall function item vector
-:start (1+ vector-length) :end (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function item vector :start -1))
- (Check-Error args-out-of-range
- (funcall function item vector :end (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function item bit-vector
-:start (1+ vector-length) :end (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function item bit-vector :start -1))
- (Check-Error args-out-of-range
- (funcall function item bit-vector :end (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function item string
-:start (1+ string-length) :end (1+ string-length)))
- (Check-Error wrong-type-argument
- (funcall function item string :start -1))
- (Check-Error args-out-of-range
- (funcall function item string :end (* 2 string-length))))
- (dolist (function '(delete-duplicates remove-duplicates))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence list)
-:start (1+ list-length) :end (1+ list-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence list)
-:start -1 :end list-length))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence list)
-:end (* 2 list-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence vector)
-:start (1+ vector-length) :end (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence vector) :start -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence vector)
-:end (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence bit-vector)
-:start (1+ vector-length) :end (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence bit-vector) :start -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence bit-vector)
-:end (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence string)
-:start (1+ string-length) :end (1+ string-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence string) :start -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence string)
-:end (* 2 string-length))))
- (dolist (function '(replace mismatch search))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence list) (copy-sequence list)
-:start1 (1+ list-length) :end1 (1+ list-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence list) (copy-sequence list)
-:start1 -1 :end1 list-length))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence list) (copy-sequence list)
-:end1 (* 2 list-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence vector)
- (copy-sequence vector) :start1 (1+ vector-length)
-:end1 (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence vector)
- (copy-sequence vector) :start1 -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence vector)
- (copy-sequence vector)
-:end1 (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence bit-vector)
- (copy-sequence bit-vector)
-:start1 (1+ vector-length)
-:end1 (1+ vector-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence bit-vector)
- (copy-sequence bit-vector) :start1 -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence bit-vector)
- (copy-sequence bit-vector)
-:end1 (* 2 vector-length)))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence string)
- (copy-sequence string)
-:start1 (1+ string-length)
-:end1 (1+ string-length)))
- (Check-Error wrong-type-argument
- (funcall function (copy-sequence string)
- (copy-sequence string) :start1 -1))
- (Check-Error args-out-of-range
- (funcall function (copy-sequence string)
- (copy-sequence string)
-:end1 (* 2 string-length))))))
+ (macrolet
+ ((construct-item-sequence-checks (&rest functions)
+ (cons
+ 'progn
+ (mapcan
+ #'(lambda (function)
+ `((Check-Error args-out-of-range
+ (,function item list
+:start (1+ list-length)
+:end (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (,function item list :start -1
+:end list-length))
+ (Check-Error args-out-of-range
+ (,function item list :end (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (,function item vector
+:start (1+ vector-length)
+:end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function item vector :start -1))
+ (Check-Error args-out-of-range
+ (,function item vector
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function item bit-vector
+:start (1+ vector-length)
+:end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function item bit-vector :start -1))
+ (Check-Error args-out-of-range
+ (,function item bit-vector
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function item string
+:start (1+ string-length)
+:end (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (,function item string :start -1))
+ (Check-Error args-out-of-range
+ (,function item string
+:end (* 2 string-length)))))
+ functions)))
+ (construct-one-sequence-checks (&rest functions)
+ (cons
+ 'progn
+ (mapcan
+ #'(lambda (function)
+ `((Check-Error args-out-of-range
+ (,function (copy-sequence list)
+:start (1+ list-length)
+:end (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence list)
+:start -1 :end list-length))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence list)
+:end (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence vector)
+:start (1+ vector-length)
+:end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence vector) :start -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence vector)
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence bit-vector)
+:start (1+ vector-length)
+:end (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence bit-vector)
+:start -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence bit-vector)
+:end (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence string)
+:start (1+ string-length)
+:end (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence string) :start -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence string)
+:end (* 2 string-length)))))
+ functions)))
+ (construct-two-sequence-checks (&rest functions)
+ (cons
+ 'progn
+ (mapcan
+ #'(lambda (function)
+ `((Check-Error args-out-of-range
+ (,function (copy-sequence list)
+ (copy-sequence list)
+:start1 (1+ list-length)
+:end1 (1+ list-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence list)
+ (copy-sequence list)
+:start1 -1 :end1 list-length))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence list)
+ (copy-sequence list)
+:end1 (* 2 list-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence vector)
+ (copy-sequence vector)
+:start1 (1+ vector-length)
+:end1 (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function
+ (copy-sequence vector)
+ (copy-sequence vector) :start1 -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence vector)
+ (copy-sequence vector)
+:end1 (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence bit-vector)
+ (copy-sequence bit-vector)
+:start1 (1+ vector-length)
+:end1 (1+ vector-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence bit-vector)
+ (copy-sequence bit-vector)
+:start1 -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence bit-vector)
+ (copy-sequence bit-vector)
+:end1 (* 2 vector-length)))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence string)
+ (copy-sequence string)
+:start1 (1+ string-length)
+:end1 (1+ string-length)))
+ (Check-Error wrong-type-argument
+ (,function (copy-sequence string)
+ (copy-sequence string) :start1 -1))
+ (Check-Error args-out-of-range
+ (,function (copy-sequence string)
+ (copy-sequence string)
+:end1 (* 2 string-length)))))
+ functions))))
+ (construct-item-sequence-checks count position find delete* remove*
+ reduce)
+ (construct-one-sequence-checks delete-duplicates remove-duplicates)
+ (construct-two-sequence-checks replace mismatch search))))
(let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone))
(vector (map 'vector #'identity list))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1295788434 0
# Node ID b4ef3128160cd912415eee1f987c2b9fe631c5fc
# Parent db326b8fe982a75108885e02eb035e6eadb8768e
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
lisp/ChangeLog addition:
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
tests/ChangeLog addition:
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (test-fun):
#'delete* and friends can now throw a wrong-type-argument if
handed a non-sequence; accept this too when checking for an error
when passing a fixnum as the SEQUENCE argument.
Check #'remove*, #'remove and #'remq too.
diff -r db326b8fe982 -r b4ef3128160c lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jan 23 12:47:02 2011 +0000
+++ b/lisp/ChangeLog Sun Jan 23 13:13:54 2011 +0000
＠＠ -1,3 +1,14 ＠＠
+2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (delete):
+ * cl-macs.el (delq):
+ * cl-macs.el (remove):
+ * cl-macs.el (remq):
+ Don't use the compiler macro if these functions were given the
+ wrong number of arguments, as happens in lisp-tests.el.
+ * cl-seq.el (remove, remq): Removed.
+ I added these to subr.el, and forgot to remove them from here.
+
2011-01-22 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
diff -r db326b8fe982 -r b4ef3128160c lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jan 23 12:47:02 2011 +0000
+++ b/lisp/cl-macs.el Sun Jan 23 13:13:54 2011 +0000
＠＠ -3344,42 +3344,49 ＠＠
form))
(define-compiler-macro delete (&whole form &rest args)
- (symbol-macrolet
- ((not-constant '#:not-constant))
- (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
- (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
- (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
- (characterp cl-const-expr-val)))
- (cons 'delete* (cdr form))
- `(delete* ,＠(cdr form) :test #'equal)))))
+ (if (eql 3 (length form))
+ (symbol-macrolet ((not-constant '#:not-constant))
+ (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
+ (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
+ (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
+ (characterp cl-const-expr-val)))
+ (cons 'delete* (cdr form))
+ `(delete* ,＠(cdr form) :test #'equal))))
+ form))
(define-compiler-macro delq (&whole form &rest args)
- (symbol-macrolet
- ((not-constant '#:not-constant))
- (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
- (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
- (not (cl-non-fixnum-number-p cl-const-expr-val)))
- (cons 'delete* (cdr form))
- `(delete* ,＠(cdr form) :test #'eq)))))
+ (if (eql 3 (length form))
+ (symbol-macrolet
+ ((not-constant '#:not-constant))
+ (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
+ (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
+ (not (cl-non-fixnum-number-p cl-const-expr-val)))
+ (cons 'delete* (cdr form))
+ `(delete* ,＠(cdr form) :test #'eq))))
+ form))
(define-compiler-macro remove (&whole form &rest args)
- (symbol-macrolet
- ((not-constant '#:not-constant))
- (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
- (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
- (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
- (characterp cl-const-expr-val)))
- (cons 'remove* (cdr form))
- `(remove* ,＠(cdr form) :test #'equal)))))
+ (if (eql 3 (length form))
+ (symbol-macrolet
+ ((not-constant '#:not-constant))
+ (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
+ (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
+ (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
+ (characterp cl-const-expr-val)))
+ (cons 'remove* (cdr form))
+ `(remove* ,＠(cdr form) :test #'equal))))
+ form))
(define-compiler-macro remq (&whole form &rest args)
- (symbol-macrolet
- ((not-constant '#:not-constant))
- (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
- (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
- (not (cl-non-fixnum-number-p cl-const-expr-val)))
- (cons 'remove* (cdr form))
- `(remove* ,＠(cdr form) :test #'eq)))))
+ (if (eql 3 (length form))
+ (symbol-macrolet
+ ((not-constant '#:not-constant))
+ (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
+ (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
+ (not (cl-non-fixnum-number-p cl-const-expr-val)))
+ (cons 'remove* (cdr form))
+ `(remove* ,＠(cdr form) :test #'eq))))
+ form))
(macrolet
((define-foo-if-compiler-macros (&rest alist)
diff -r db326b8fe982 -r b4ef3128160c lisp/cl-seq.el
--- a/lisp/cl-seq.el Sun Jan 23 12:47:02 2011 +0000
+++ b/lisp/cl-seq.el Sun Jan 23 13:13:54 2011 +0000
＠＠ -56,26 +56,6 ＠＠
;; scope (e.g. a variable called start bound in this file and one in a
;; user-supplied test predicate may well interfere with each other).
-;; XEmacs change: these two are in subr.el in GNU Emacs.
-(defun remove (cl-item cl-seq)
- "Remove all occurrences of ITEM in SEQUENCE, testing with `equal'.
-
-This is a non-destructive function; it makes a copy of SEQUENCE if necessary
-to avoid corrupting the original SEQUENCE.
-Also see: `remove*', `delete', `delete*'
-
-arguments: (ITEM SEQUENCE)"
- (remove* cl-item cl-seq :test #'equal))
-
-(defun remq (cl-item cl-seq)
- "Remove all occurrences of ITEM in SEQUENCE, comparing with `eq'.
-
-This is a non-destructive function; it makes a copy of SEQUENCE to avoid
-corrupting the original LIST. See also the more general `remove*'.
-
-arguments: (ITEM SEQUENCE)"
- (remove* cl-item cl-seq :test #'eq))
-
(defun remove-if (cl-predicate cl-seq &rest cl-keys)
"Remove all items satisfying PREDICATE in SEQUENCE.
diff -r db326b8fe982 -r b4ef3128160c tests/ChangeLog
--- a/tests/ChangeLog Sun Jan 23 12:47:02 2011 +0000
+++ b/tests/ChangeLog Sun Jan 23 13:13:54 2011 +0000
＠＠ -1,3 +1,11 ＠＠
+2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el (test-fun):
+ #'delete* and friends can now throw a wrong-type-argument if
+ handed a non-sequence; accept this too when checking for an error
+ when passing a fixnum as the SEQUENCE argument.
+ Check #'remove*, #'remove and #'remq too.
+
2011-01-15 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (list): Test #'concatenate, especially
diff -r db326b8fe982 -r b4ef3128160c tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Jan 23 12:47:02 2011 +0000
+++ b/tests/automated/lisp-tests.el Sun Jan 23 13:13:54 2011 +0000
＠＠ -793,19 +793,21 ＠＠
`(progn
(Check-Error wrong-number-of-arguments (,fun))
(Check-Error wrong-number-of-arguments (,fun nil))
- (Check-Error malformed-list (,fun nil 1))
+ (Check-Error (malformed-list wrong-type-argument) (,fun nil 1))
,＠(loop for n in '(1 2 2000)
collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
(test-funs (&rest funs) `(progn ,＠(loop for fun in funs collect `(test-fun ,fun)))))
- (test-funs member* member old-member
- memq old-memq
- assoc* assoc old-assoc
- rassoc* rassoc old-rassoc
- rassq old-rassq
- delete* delete old-delete
- delq old-delq
- remassoc remassq remrassoc remrassq))
+ (test-funs member* member memq
+ assoc* assoc assq
+ rassoc* rassoc rassq
+ delete* delete delq
+ remove* remove remq
+ old-member old-memq
+ old-assoc old-assq
+ old-rassoc old-rassq
+ old-delete old-delq
+ remassoc remassq remrassoc remrassq))
(let ((x '((1 . 2) 3 (4 . 5))))
(Assert (eq (assoc 1 x) (car x)))
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5346:b4ef3128160c
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Jan 23 13:13:54 2011 +0000
files: lisp/ChangeLog lisp/cl-macs.el lisp/cl-seq.el tests/ChangeLog tests/automated/lisp-tests.el
description:
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
lisp/ChangeLog addition:
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
tests/ChangeLog addition:
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (test-fun):
#'delete* and friends can now throw a wrong-type-argument if
handed a non-sequence; accept this too when checking for an error
when passing a fixnum as the SEQUENCE argument.
Check #'remove*, #'remove and #'remq too.
diff -r db326b8fe982 -r b4ef3128160c lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jan 23 12:47:02 2011 +0000
+++ b/lisp/ChangeLog Sun Jan 23 13:13:54 2011 +0000
＠＠ -1,3 +1,14 ＠＠
+2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (delete):
+ * cl-macs.el (delq):
+ * cl-macs.el (remove):
+ * cl-macs.el (remq):
+ Don't use the compiler macro if these functions were given the
+ wrong number of arguments, as happens in lisp-tests.el.
+ * cl-seq.el (remove, remq): Removed.
+ I added these to subr.el, and forgot to remove them from here.
+
2011-01-22 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
diff -r db326b8fe982 -r b4ef3128160c lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Jan 23 12:47:02 2011 +0000
+++ b/lisp/cl-macs.el Sun Jan 23 13:13:54 2011 +0000
＠＠ -3344,42 +3344,49 ＠＠
form))
(define-compiler-macro delete (&whole form &rest args)
- (symbol-macrolet
- ((not-constant '#:not-constant))
- (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
- (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
- (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
- (characterp cl-const-expr-val)))
- (cons 'delete* (cdr form))
- `(delete* ,＠(cdr form) :test #'equal)))))
+ (if (eql 3 (length form))
+ (symbol-macrolet ((not-constant '#:not-constant))
+ (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
+ (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
+ (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
+ (characterp cl-const-expr-val)))
+ (cons 'delete* (cdr form))
+ `(delete* ,＠(cdr form) :test #'equal))))
+ form))
(define-compiler-macro delq (&whole form &rest args)
- (symbol-macrolet
- ((not-constant '#:not-constant))
- (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
- (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
- (not (cl-non-fixnum-number-p cl-const-expr-val)))
- (cons 'delete* (cdr form))
- `(delete* ,＠(cdr form) :test #'eq)))))
+ (if (eql 3 (length form))
+ (symbol-macrolet
+ ((not-constant '#:not-constant))
+ (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
+ (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
+ (not (cl-non-fixnum-number-p cl-const-expr-val)))
+ (cons 'delete* (cdr form))
+ `(delete* ,＠(cdr form) :test #'eq))))
+ form))
(define-compiler-macro remove (&whole form &rest args)
- (symbol-macrolet
- ((not-constant '#:not-constant))
- (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
- (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
- (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
- (characterp cl-const-expr-val)))
- (cons 'remove* (cdr form))
- `(remove* ,＠(cdr form) :test #'equal)))))
+ (if (eql 3 (length form))
+ (symbol-macrolet
+ ((not-constant '#:not-constant))
+ (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
+ (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
+ (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
+ (characterp cl-const-expr-val)))
+ (cons 'remove* (cdr form))
+ `(remove* ,＠(cdr form) :test #'equal))))
+ form))
(define-compiler-macro remq (&whole form &rest args)
- (symbol-macrolet
- ((not-constant '#:not-constant))
- (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
- (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
- (not (cl-non-fixnum-number-p cl-const-expr-val)))
- (cons 'remove* (cdr form))
- `(remove* ,＠(cdr form) :test #'eq)))))
+ (if (eql 3 (length form))
+ (symbol-macrolet
+ ((not-constant '#:not-constant))
+ (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
+ (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
+ (not (cl-non-fixnum-number-p cl-const-expr-val)))
+ (cons 'remove* (cdr form))
+ `(remove* ,＠(cdr form) :test #'eq))))
+ form))
(macrolet
((define-foo-if-compiler-macros (&rest alist)
diff -r db326b8fe982 -r b4ef3128160c lisp/cl-seq.el
--- a/lisp/cl-seq.el Sun Jan 23 12:47:02 2011 +0000
+++ b/lisp/cl-seq.el Sun Jan 23 13:13:54 2011 +0000
＠＠ -55,26 +55,6 ＠＠
;; () lists in the docstrings, but that often breaks because of dynamic
;; scope (e.g. a variable called start bound in this file and one in a
;; user-supplied test predicate may well interfere with each other).
-
-;; XEmacs change: these two are in subr.el in GNU Emacs.
-(defun remove (cl-item cl-seq)
- "Remove all occurrences of ITEM in SEQUENCE, testing with `equal'.
-
-This is a non-destructive function; it makes a copy of SEQUENCE if necessary
-to avoid corrupting the original SEQUENCE.
-Also see: `remove*', `delete', `delete*'
-
-arguments: (ITEM SEQUENCE)"
- (remove* cl-item cl-seq :test #'equal))
-
-(defun remq (cl-item cl-seq)
- "Remove all occurrences of ITEM in SEQUENCE, comparing with `eq'.
-
-This is a non-destructive function; it makes a copy of SEQUENCE to avoid
-corrupting the original LIST. See also the more general `remove*'.
-
-arguments: (ITEM SEQUENCE)"
- (remove* cl-item cl-seq :test #'eq))
(defun remove-if (cl-predicate cl-seq &rest cl-keys)
"Remove all items satisfying PREDICATE in SEQUENCE.
diff -r db326b8fe982 -r b4ef3128160c tests/ChangeLog
--- a/tests/ChangeLog Sun Jan 23 12:47:02 2011 +0000
+++ b/tests/ChangeLog Sun Jan 23 13:13:54 2011 +0000
＠＠ -1,3 +1,11 ＠＠
+2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el (test-fun):
+ #'delete* and friends can now throw a wrong-type-argument if
+ handed a non-sequence; accept this too when checking for an error
+ when passing a fixnum as the SEQUENCE argument.
+ Check #'remove*, #'remove and #'remq too.
+
2011-01-15 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (list): Test #'concatenate, especially
diff -r db326b8fe982 -r b4ef3128160c tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Jan 23 12:47:02 2011 +0000
+++ b/tests/automated/lisp-tests.el Sun Jan 23 13:13:54 2011 +0000
＠＠ -793,19 +793,21 ＠＠
`(progn
(Check-Error wrong-number-of-arguments (,fun))
(Check-Error wrong-number-of-arguments (,fun nil))
- (Check-Error malformed-list (,fun nil 1))
+ (Check-Error (malformed-list wrong-type-argument) (,fun nil 1))
,＠(loop for n in '(1 2 2000)
collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
(test-funs (&rest funs) `(progn ,＠(loop for fun in funs collect `(test-fun ,fun)))))
- (test-funs member* member old-member
- memq old-memq
- assoc* assoc old-assoc
- rassoc* rassoc old-rassoc
- rassq old-rassq
- delete* delete old-delete
- delq old-delq
- remassoc remassq remrassoc remrassq))
+ (test-funs member* member memq
+ assoc* assoc assq
+ rassoc* rassoc rassq
+ delete* delete delq
+ remove* remove remq
+ old-member old-memq
+ old-assoc old-assq
+ old-rassoc old-rassq
+ old-delete old-delq
+ remassoc remassq remrassoc remrassq))
(let ((x '((1 . 2) 3 (4 . 5))))
(Assert (eq (assoc 1 x) (car x)))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments