6:52 p.m.
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1287078638 -3600
# Node ID 99de5fd48e87639c3b8ac73b6d283b78445bdb09
# Parent d27c1ee1943b510e6e76337ee892a362dfa5f780
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp,
#'ldiff
lisp/ChangeLog addition:
2010-10-14 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (side-effect-free-fns):
* cl-macs.el (remf, getf):
* cl-extra.el (tailp, cl-set-getf, cl-do-remf):
* cl.el (ldiff, endp):
Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
add circularity checking for the first two.
#'cl-set-getf and #'cl-do-remf were Lisp implementations of
#'plist-put and #'plist-remprop; change the names to aliases,
changes the macros that use them to using #'plist-put and
#'plist-remprop directly.
src/ChangeLog addition:
2010-10-14 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Fnbutlast, Fbutlast):
Tighten up Common Lisp compatibility for these two functions; they
need to operate on dotted lists without erroring.
tests/ChangeLog addition:
2010-10-14 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (x):
Test #'nbutlast, #'butlast with dotted lists.
Check that #'ldiff and #'tailp don't hang on circular lists; check
that #'tailp returns t with circular lists when that is
appropriate. Test them both with dotted lists.
diff -r d27c1ee1943b -r 99de5fd48e87 lisp/ChangeLog
--- a/lisp/ChangeLog Tue Oct 12 21:11:46 2010 +0100
+++ b/lisp/ChangeLog Thu Oct 14 18:50:38 2010 +0100
＠＠ -1,3 +1,17 ＠＠
+2010-10-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el (side-effect-free-fns):
+ * cl-macs.el (remf, getf):
+ * cl-extra.el (tailp, cl-set-getf, cl-do-remf):
+ * cl.el (ldiff, endp):
+ Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
+ add circularity checking for the first two.
+
+ #'cl-set-getf and #'cl-do-remf were Lisp implementations of
+ #'plist-put and #'plist-remprop; change the names to aliases,
+ changes the macros that use them to using #'plist-put and
+ #'plist-remprop directly.
+
2010-10-12 Aidan Kehoe <kehoea(a)parhasard.net>
* abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table):
diff -r d27c1ee1943b -r 99de5fd48e87 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Tue Oct 12 21:11:46 2010 +0100
+++ b/lisp/byte-optimize.el Thu Oct 14 18:50:38 2010 +0100
＠＠ -1225,7 +1225,7 ＠＠
;; coordinates-in-window-p not in XEmacs
copy-marker cos count-lines
default-boundp default-value denominator documentation downcase
- elt exp expt fboundp featurep
+ elt endp exp expt fboundp featurep
file-directory-p file-exists-p file-locked-p file-name-absolute-p
file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
float floor format
diff -r d27c1ee1943b -r 99de5fd48e87 lisp/cl-extra.el
--- a/lisp/cl-extra.el Tue Oct 12 21:11:46 2010 +0100
+++ b/lisp/cl-extra.el Thu Oct 14 18:50:38 2010 +0100
＠＠ -405,11 +405,17 ＠＠
"Equivalent to (nconc (nreverse X) Y)."
(nconc (nreverse x) y))
+;; XEmacs; check LIST for type and circularity.
(defun tailp (sublist list)
"Return true if SUBLIST is a tail of LIST."
- (while (and (consp list) (not (eq sublist list)))
- (setq list (cdr list)))
- (if (numberp sublist) (equal sublist list) (eq sublist list)))
+ (check-argument-type #'listp list)
+ (let ((before list) (evenp t))
+ (while (and (consp list) (not (eq sublist list)))
+ (setq list (cdr list)
+ evenp (not evenp))
+ (if evenp (setq before (cdr before)))
+ (if (eq before list) (error 'circular-list list)))
+ (eql sublist list)))
(defalias 'cl-copy-tree 'copy-tree)
＠＠ -419,17 +425,9 ＠＠
(defalias 'get* 'get)
(defalias 'getf 'plist-get)
-(defun cl-set-getf (plist tag val)
- (let ((p plist))
- (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
- (if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
-
-(defun cl-do-remf (plist tag)
- (let ((p (cdr plist)))
- (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
- (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
-
-;; XEmacs change: we have a builtin remprop
+;; XEmacs; these are built-in.
+(defalias 'cl-set-getf 'plist-put)
+(defalias 'cl-do-remf 'plist-remprop)
(defalias 'cl-remprop 'remprop)
(defun get-properties (plist indicator-list)
diff -r d27c1ee1943b -r 99de5fd48e87 lisp/cl-macs.el
--- a/lisp/cl-macs.el Tue Oct 12 21:11:46 2010 +0100
+++ b/lisp/cl-macs.el Thu Oct 14 18:50:38 2010 +0100
＠＠ -2407,7 +2407,7 ＠＠
(append (nth 1 method) (list tag def))
(list store-temp)
(list 'let (list (list (car (nth 2 method))
- (list 'cl-set-getf (nth 4 method)
+ (list 'plist-put (nth 4 method)
tag-temp store-temp)))
(nth 3 method) store-temp)
(list 'getf (nth 4 method) tag-temp def-temp))))
＠＠ -2597,7 +2597,7 ＠＠
(list 'progn
(cl-setf-do-store (nth 1 method) (list 'cddr tval))
t)
- (list 'cl-do-remf tval ttag)))))
+ (list 'plist-remprop tval ttag)))))
;;;###autoload
(defmacro shiftf (place &rest args)
＠＠ -3805,7 +3805,7 ＠＠
'((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr
x)
(fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
(eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
- (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
+ (rest 'cdr x) (plusp '> x 0) (minusp '< x 0)
(oddp 'eq (list 'logand x 1) 1)
(evenp 'eq (list 'logand x 1) 0)
(caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
diff -r d27c1ee1943b -r 99de5fd48e87 lisp/cl.el
--- a/lisp/cl.el Tue Oct 12 21:11:46 2010 +0100
+++ b/lisp/cl.el Thu Oct 14 18:50:38 2010 +0100
＠＠ -365,7 +365,13 ＠＠
(defalias 'first 'car)
(defalias 'rest 'cdr)
-(defalias 'endp 'null)
+
+;; XEmacs change; this needs to error if handed a non-list.
+(defun endp (list)
+ "Return t if LIST is nil, or nil if LIST is a cons. Error otherwise."
+ (prog1
+ (null list)
+ (and list (atom list) (error 'wrong-type-argument #'listp list))))
;; XEmacs change: make it a real function
(defun second (x)
＠＠ -521,12 +527,26 ＠＠
;;; XEmacs: `list*' is in subr.el.
+;; XEmacs; handle dotted lists properly, error on circularity and if LIST is
+;; not a list.
(defun ldiff (list sublist)
- "Return a copy of LIST with the tail SUBLIST removed."
- (let ((res nil))
- (while (and (consp list) (not (eq list sublist)))
- (push (pop list) res))
- (nreverse res)))
+ "Return a copy of LIST with the tail SUBLIST removed.
+
+If SUBLIST is the same Lisp object as LIST, return nil. If SUBLIST is
+not present in the list structure of LIST (that is, it is not the cdr
+of some cons making up LIST), this function is equivalent to
+`copy-list'. LIST may be dotted."
+ (check-argument-type #'listp list)
+ (and list (not (eq list sublist))
+ (let ((before list) (evenp t) result)
+ (prog1
+ (setq result (list (car list)))
+ (while (and (setq list (cdr-safe list)) (not (eql list sublist)))
+ (setf (cdr result) (if (consp list) (list (car list)) list)
+ result (cdr result)
+ evenp (not evenp))
+ (if evenp (setq before (cdr before)))
+ (if (eq before list) (error 'circular-list list)))))))
;;; `copy-list' is implemented as a C primitive, as of 1998-11
diff -r d27c1ee1943b -r 99de5fd48e87 src/ChangeLog
--- a/src/ChangeLog Tue Oct 12 21:11:46 2010 +0100
+++ b/src/ChangeLog Thu Oct 14 18:50:38 2010 +0100
＠＠ -1,3 +1,9 ＠＠
+2010-10-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Fnbutlast, Fbutlast):
+ Tighten up Common Lisp compatibility for these two functions; they
+ need to operate on dotted lists without erroring.
+
2010-10-12 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (list_merge):
diff -r d27c1ee1943b -r 99de5fd48e87 src/fns.c
--- a/src/fns.c Tue Oct 12 21:11:46 2010 +0100
+++ b/src/fns.c Thu Oct 14 18:50:38 2010 +0100
＠＠ -1570,72 +1570,99 ＠＠
DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
Modify LIST to remove the last N (default 1) elements.
+
If LIST has N or fewer elements, nil is returned and LIST is unmodified.
+Otherwise, LIST may be dotted, but not circular.
*/
(list, n))
{
- EMACS_INT int_n;
+ Elemcount int_n = 1;
CHECK_LIST (list);
- if (NILP (n))
- int_n = 1;
- else
+ if (!NILP (n))
{
CHECK_NATNUM (n);
int_n = XINT (n);
}
- {
- Lisp_Object last_cons = list;
-
- EXTERNAL_LIST_LOOP_1 (list)
- {
- if (int_n-- < 0)
- last_cons = XCDR (last_cons);
- }
-
- if (int_n >= 0)
- return Qnil;
-
- XCDR (last_cons) = Qnil;
- return list;
- }
+ if (CONSP (list))
+ {
+ Lisp_Object last_cons = list;
+
+ EXTERNAL_LIST_LOOP_3 (elt, list, tail)
+ {
+ if (int_n-- < 0)
+ {
+ last_cons = XCDR (last_cons);
+ }
+
+ if (!CONSP (XCDR (tail)))
+ {
+ break;
+ }
+ }
+
+ if (int_n >= 0)
+ {
+ return Qnil;
+ }
+
+ XCDR (last_cons) = Qnil;
+ }
+
+ return list;
}
DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
Return a copy of LIST with the last N (default 1) elements removed.
+
If LIST has N or fewer elements, nil is returned.
+Otherwise, LIST may be dotted, but not circular, and `(butlast LIST 0)'
+converts a dotted into a true list.
*/
(list, n))
{
- EMACS_INT int_n;
+ Lisp_Object retval = Qnil, retval_tail = Qnil;
+ Elemcount int_n = 1;
CHECK_LIST (list);
- if (NILP (n))
- int_n = 1;
- else
+ if (!NILP (n))
{
CHECK_NATNUM (n);
int_n = XINT (n);
}
- {
- Lisp_Object retval = Qnil;
- Lisp_Object tail = list;
-
- EXTERNAL_LIST_LOOP_1 (list)
- {
- if (--int_n < 0)
- {
- retval = Fcons (XCAR (tail), retval);
- tail = XCDR (tail);
- }
- }
-
- return Fnreverse (retval);
- }
+ if (CONSP (list))
+ {
+ Lisp_Object tail = list;
+
+ EXTERNAL_LIST_LOOP_3 (elt, list, list_tail)
+ {
+ if (--int_n < 0)
+ {
+ if (NILP (retval_tail))
+ {
+ retval = retval_tail = Fcons (XCAR (tail), Qnil);
+ }
+ else
+ {
+ XSETCDR (retval_tail, Fcons (XCAR (tail), Qnil));
+ retval_tail = XCDR (retval_tail);
+ }
+
+ tail = XCDR (tail);
+ }
+
+ if (!CONSP (XCDR (list_tail)))
+ {
+ break;
+ }
+ }
+ }
+
+ return retval;
}
DEFUN ("member", Fmember, 2, 2, 0, /*
diff -r d27c1ee1943b -r 99de5fd48e87 tests/ChangeLog
--- a/tests/ChangeLog Tue Oct 12 21:11:46 2010 +0100
+++ b/tests/ChangeLog Thu Oct 14 18:50:38 2010 +0100
＠＠ -1,3 +1,11 ＠＠
+2010-10-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el (x):
+ Test #'nbutlast, #'butlast with dotted lists.
+ Check that #'ldiff and #'tailp don't hang on circular lists; check
+ that #'tailp returns t with circular lists when that is
+ appropriate. Test them both with dotted lists.
+
2010-10-12 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
diff -r d27c1ee1943b -r 99de5fd48e87 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Tue Oct 12 21:11:46 2010 +0100
+++ b/tests/automated/lisp-tests.el Thu Oct 14 18:50:38 2010 +0100
＠＠ -200,6 +200,14 ＠＠
(Assert (equal y '(0 1 2 3)))
(Assert (equal z y)))
+(let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c)))
+ (y (butlast x 0))
+ (z (nbutlast x 0)))
+ (Assert (eq z x))
+ (Assert (not (eq y x)))
+ (Assert (equal y '(0 1 2 3 4 5 6.0 ?7 ?8)))
+ (Assert (equal z y)))
+
(Assert (eq (butlast '(x)) nil))
(Assert (eq (nbutlast '(x)) nil))
(Assert (eq (butlast '()) nil))
＠＠ -219,6 +227,58 ＠＠
(Assert (and (equal x y) (not (eq x y))))))
;;-----------------------------------------------------
+;; Test `ldiff'
+;;-----------------------------------------------------
+(Check-Error wrong-type-argument (ldiff 'foo pi))
+(Check-Error wrong-number-of-arguments (ldiff))
+(Check-Error wrong-number-of-arguments (ldiff '(1 2)))
+(Check-Error circular-list (ldiff (make-circular-list 1) nil))
+(Check-Error circular-list (ldiff (make-circular-list 2000) nil))
+(Assert (eq '() (ldiff '() pi)))
+(dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
+ (let ((y (ldiff x nil)))
+ (Assert (and (equal x y) (not (eq x y))))))
+
+(let* ((vector (vector 'foo))
+ (dotted `(1 2 3 ,pi 40 50 . ,vector))
+ (dotted-pi `(1 2 3 . ,pi))
+ without-vector without-pi)
+ (Assert (equal dotted (ldiff dotted nil))
+ "checking ldiff handles dotted lists properly")
+ (Assert (equal (butlast dotted 0) (ldiff dotted vector))
+ "checking ldiff discards dotted elements correctly")
+ (Assert (equal (butlast dotted-pi 0) (ldiff dotted-pi (* 4 (atan 1))))
+ "checking ldiff handles float equivalence correctly"))
+
+;;-----------------------------------------------------
+;; Test `tailp'
+;;-----------------------------------------------------
+(Check-Error wrong-type-argument (tailp pi 'foo))
+(Check-Error wrong-number-of-arguments (tailp))
+(Check-Error wrong-number-of-arguments (tailp '(1 2)))
+(Check-Error circular-list (tailp nil (make-circular-list 1)))
+(Check-Error circular-list (tailp nil (make-circular-list 2000)))
+(Assert (null (tailp pi '()))
+ "checking pi is not a tail of the list nil")
+(Assert (tailp 3 '(1 2 . 3))
+ "checking #'tailp works with a dotted integer.")
+(Assert (tailp pi `(1 2 . ,(* 4 (atan 1))))
+ "checking tailp works with non-eq dotted floats.")
+(let ((list (make-list 2048 nil)))
+ (Assert (tailp (nthcdr 2000 list) (nconc list list))
+ "checking #'tailp succeeds with circular LIST containing SUBLIST"))
+
+;;-----------------------------------------------------
+;; Test `endp'
+;;-----------------------------------------------------
+(Check-Error wrong-type-argument (endp 'foo))
+(Check-Error wrong-number-of-arguments (endp))
+(Check-Error wrong-number-of-arguments (endp '(1 2) 'foo))
+(Assert (endp nil) "checking nil is recognized as the end of a list")
+(Assert (not (endp (list 200 200 4 0 9)))
+ "checking a cons is not recognised as the end of a list")
+
+;;-----------------------------------------------------
;; Arithmetic operations
;;-----------------------------------------------------
--
“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