APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # 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&gt; * 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&gt; * 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&gt; * 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&gt; + + * 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&gt; * 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&gt; + + * 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&gt; * 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&gt; + + * 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&gt; * 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