commit 09d50834206ff48bf6ac214e8cfb31d281ba993c (HEAD, refs/remotes/origin/master) Author: Michael Albinus Date: Sat Feb 11 10:29:29 2017 +0100 ; Fix typo in etc/NEWS diff --git a/etc/NEWS b/etc/NEWS index da0b538883..cba4e4d9a8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -617,8 +617,9 @@ Drive onsite repositories. manual documents how to configure ssh and PuTTY accordingly. +++ -Setting the "ENV" environment variable in 'tramp-remote-process-environment' -enables reading of shell initialization files. +*** Setting the "ENV" environment variable in +'tramp-remote-process-environment' enables reading of shell +initialization files. --- ** 'auto-revert-use-notify' is set back to t in 'global-auto-revert-mode'. commit 44578d9acc952963a2c9acbd7696b65b29af2f6e Author: Eli Zaretskii Date: Sat Feb 11 11:09:33 2017 +0200 Fix handling of PBM data * src/image.c (pbm_load): Handle PBM data with no blanks between individual pixel values correctly. (Bug#25660) diff --git a/src/image.c b/src/image.c index ad0143be48..a7a9416528 100644 --- a/src/image.c +++ b/src/image.c @@ -5465,7 +5465,17 @@ pbm_load (struct frame *f, struct image *img) c <<= 1; } else - g = pbm_scan_number (&p, end); + { + int c = 0; + /* Skip white-space and comments. */ + while ((c = pbm_next_char (&p, end)) != -1 && c_isspace (c)) + ; + + if (c == '0' || c == '1') + g = c - '0'; + else + g = 0; + } #ifdef USE_CAIRO *dataptr++ = g ? fga32 : bga32; commit 26187a38a17734d313c1294f47f95c4926d7b6ef Author: Noam Postavsky Date: Fri Feb 10 15:33:05 2017 -0500 Fix warnings in debug tracing code * src/xdisp.c (dump_glyph, dump_glyph_string): * src/xfaces.c (dump_realized_face): Cast arguments or adjust format specifiers to match signedness. diff --git a/src/xdisp.c b/src/xdisp.c index 6cb5b4e056..e59934d2d5 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -18972,7 +18972,7 @@ dump_glyph (struct glyph_row *row, struct glyph *glyph, int area) glyph->pixel_width, glyph->u.ch, (glyph->u.ch < 0x80 && glyph->u.ch >= ' ' - ? glyph->u.ch + ? (int) glyph->u.ch : '.'), glyph->face_id, glyph->left_box_line_p, @@ -18993,7 +18993,7 @@ dump_glyph (struct glyph_row *row, struct glyph *glyph, int area) ? '0' : '-'))), glyph->pixel_width, - 0, + 0u, ' ', glyph->face_id, glyph->left_box_line_p, @@ -19014,7 +19014,7 @@ dump_glyph (struct glyph_row *row, struct glyph *glyph, int area) ? '0' : '-'))), glyph->pixel_width, - glyph->u.img_id, + (unsigned int) glyph->u.img_id, '.', glyph->face_id, glyph->left_box_line_p, @@ -19035,7 +19035,7 @@ dump_glyph (struct glyph_row *row, struct glyph *glyph, int area) ? '0' : '-'))), glyph->pixel_width, - glyph->u.cmp.id); + (unsigned int) glyph->u.cmp.id); if (glyph->u.cmp.automatic) fprintf (stderr, "[%d-%d]", @@ -24616,7 +24616,7 @@ dump_glyph_string (struct glyph_string *s) fprintf (stderr, " x, y, w, h = %d, %d, %d, %d\n", s->x, s->y, s->width, s->height); fprintf (stderr, " ybase = %d\n", s->ybase); - fprintf (stderr, " hl = %d\n", s->hl); + fprintf (stderr, " hl = %u\n", s->hl); fprintf (stderr, " left overhang = %d, right = %d\n", s->left_overhang, s->right_overhang); fprintf (stderr, " nchars = %d\n", s->nchars); diff --git a/src/xfaces.c b/src/xfaces.c index 830106d64c..b5dbb53ca2 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -6251,7 +6251,7 @@ dump_realized_face (struct face *face) fprintf (stderr, "underline: %d (%s)\n", face->underline_p, SDATA (Fsymbol_name (face->lface[LFACE_UNDERLINE_INDEX]))); - fprintf (stderr, "hash: %d\n", face->hash); + fprintf (stderr, "hash: %u\n", face->hash); } commit 59e7efe7bdfb384017d34265df3e6c15837b972e Author: Sam Steingold Date: Fri Feb 10 14:53:02 2017 -0500 Extract grep-find-ignored-directories processing from rgrep-default-command (rgrep-find-ignored-directories): Extract from `rgrep-default-command'. Some Emacs packages use `grep-find-ignored-directories' to ignore some directories, so will use this function instead of custom code. (rgrep-default-command): Use `rgrep-find-ignored-directories'. diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 22d4f2abd9..b3d8a51cee 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -1045,6 +1045,15 @@ to specify a command to run." (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir))))))) +(defun rgrep-find-ignored-directories (dir) + "Return the list of ignored directories applicable to `dir'." + (delq nil (mapcar + (lambda (ignore) + (cond ((stringp ignore) ignore) + ((consp ignore) + (and (funcall (car ignore) dir) (cdr ignore))))) + grep-find-ignored-directories))) + (defun rgrep-default-command (regexp files dir) "Compute the command for \\[rgrep] to use by default." (require 'find-dired) ; for `find-name-arg' @@ -1066,20 +1075,9 @@ to specify a command to run." (shell-quote-argument "(") ;; we should use shell-quote-argument here " -path " - (mapconcat - 'identity - (delq nil (mapcar - #'(lambda (ignore) - (cond ((stringp ignore) - (shell-quote-argument - (concat "*/" ignore))) - ((consp ignore) - (and (funcall (car ignore) dir) - (shell-quote-argument - (concat "*/" - (cdr ignore))))))) - grep-find-ignored-directories)) - " -o -path ") + (mapconcat (lambda (d) (shell-quote-argument (concat "*/" d))) + (rgrep-find-ignored-directories dir) + " -o -path ") " " (shell-quote-argument ")") " -prune -o ")) commit abcba32c262e575b562ec0e481e55538536f969f Author: Paul Eggert Date: Fri Feb 10 08:34:57 2017 -0800 Fix a few integer-overflow glitches * src/composite.c (composition_compute_stop_pos, composition_reseat_it): * src/dispextern.h (struct composition_it.rule_idx): * src/keyboard.c (Fset__this_command_keys): * src/xwidget.c (webkit_js_to_lisp): Don’t assume object sizes fit in ‘int’. * src/xwidget.c (Fxwidget_resize): Don’t assume Emacs integers fit in ‘int’. diff --git a/src/composite.c b/src/composite.c index f23bb17c57..b673c53ac8 100644 --- a/src/composite.c +++ b/src/composite.c @@ -1012,7 +1012,7 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, val = CHAR_TABLE_REF (Vcomposition_function_table, c); if (! NILP (val)) { - for (int ridx = 0; CONSP (val); val = XCDR (val), ridx++) + for (EMACS_INT ridx = 0; CONSP (val); val = XCDR (val), ridx++) { Lisp_Object elt = XCAR (val); if (VECTORP (elt) && ASIZE (elt) == 3 @@ -1063,54 +1063,48 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, while (char_composable_p (c)) { val = CHAR_TABLE_REF (Vcomposition_function_table, c); - if (! NILP (val)) + for (EMACS_INT ridx = 0; CONSP (val); val = XCDR (val), ridx++) { - Lisp_Object elt; - int ridx, blen; - - for (ridx = 0; CONSP (val); val = XCDR (val), ridx++) + Lisp_Object elt = XCAR (val); + if (VECTORP (elt) && ASIZE (elt) == 3 + && NATNUMP (AREF (elt, 1)) + && charpos - XFASTINT (AREF (elt, 1)) > endpos) { - elt = XCAR (val); - if (VECTORP (elt) && ASIZE (elt) == 3 - && NATNUMP (AREF (elt, 1)) - && charpos - XFASTINT (AREF (elt, 1)) > endpos) - { - ptrdiff_t back = XFASTINT (AREF (elt, 1)); - ptrdiff_t cpos = charpos - back, bpos; + ptrdiff_t back = XFASTINT (AREF (elt, 1)); + ptrdiff_t cpos = charpos - back, bpos; - if (back == 0) - bpos = bytepos; - else - bpos = (NILP (string) ? CHAR_TO_BYTE (cpos) - : string_char_to_byte (string, cpos)); - if (STRINGP (AREF (elt, 0))) - blen = fast_looking_at (AREF (elt, 0), cpos, bpos, - start + 1, limit, string); - else - blen = 1; - if (blen > 0) + if (back == 0) + bpos = bytepos; + else + bpos = (NILP (string) ? CHAR_TO_BYTE (cpos) + : string_char_to_byte (string, cpos)); + ptrdiff_t blen + = (STRINGP (AREF (elt, 0)) + ? fast_looking_at (AREF (elt, 0), cpos, bpos, + start + 1, limit, string) + : 1); + if (blen > 0) + { + /* Make CPOS point to the last character of + match. Note that BLEN is byte-length. */ + if (blen > 1) + { + bpos += blen; + if (NILP (string)) + cpos = BYTE_TO_CHAR (bpos) - 1; + else + cpos = string_byte_to_char (string, bpos) - 1; + } + back = cpos - (charpos - back); + if (cmp_it->stop_pos < cpos + || (cmp_it->stop_pos == cpos + && cmp_it->lookback < back)) { - /* Make CPOS point to the last character of - match. Note that BLEN is byte-length. */ - if (blen > 1) - { - bpos += blen; - if (NILP (string)) - cpos = BYTE_TO_CHAR (bpos) - 1; - else - cpos = string_byte_to_char (string, bpos) - 1; - } - back = cpos - (charpos - back); - if (cmp_it->stop_pos < cpos - || (cmp_it->stop_pos == cpos - && cmp_it->lookback < back)) - { - cmp_it->rule_idx = ridx; - cmp_it->stop_pos = cpos; - cmp_it->ch = c; - cmp_it->lookback = back; - cmp_it->nchars = back + 1; - } + cmp_it->rule_idx = ridx; + cmp_it->stop_pos = cpos; + cmp_it->ch = c; + cmp_it->lookback = back; + cmp_it->nchars = back + 1; } } } @@ -1203,10 +1197,10 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos, { Lisp_Object lgstring = Qnil; Lisp_Object val, elt; - ptrdiff_t i; val = CHAR_TABLE_REF (Vcomposition_function_table, cmp_it->ch); - for (i = 0; i < cmp_it->rule_idx; i++, val = XCDR (val)); + for (EMACS_INT i = 0; i < cmp_it->rule_idx; i++, val = XCDR (val)) + continue; if (charpos < endpos) { for (; CONSP (val); val = XCDR (val)) @@ -1255,6 +1249,7 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos, if (NILP (LGSTRING_ID (lgstring))) lgstring = composition_gstring_put_cache (lgstring, -1); cmp_it->id = XINT (LGSTRING_ID (lgstring)); + int i; for (i = 0; i < LGSTRING_GLYPH_LEN (lgstring); i++) if (NILP (LGSTRING_GLYPH (lgstring, i))) break; diff --git a/src/dispextern.h b/src/dispextern.h index eb71a82311..e030618a9b 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -2215,7 +2215,7 @@ struct composition_it the automatic composition. Provided that ELT is an element of Vcomposition_function_table for CH, (nth ELT RULE_IDX) is the rule for the composition. */ - int rule_idx; + EMACS_INT rule_idx; /* If this is an automatic composition, how many characters to look back from the position where a character triggering the composition exists. */ diff --git a/src/keyboard.c b/src/keyboard.c index 168232203f..ed8e71fd0a 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -10020,7 +10020,7 @@ Internal use only. */) add_command_key (make_number ('x' | meta_modifier)); else add_command_key (make_number (key0)); - for (int i = 1; i < SCHARS (keys); i++) + for (ptrdiff_t i = 1; i < SCHARS (keys); i++) add_command_key (make_number (SREF (keys, i))); return Qnil; } diff --git a/src/xwidget.c b/src/xwidget.c index 4ba1617d8d..5c276b1371 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -301,13 +301,13 @@ webkit_js_to_lisp (JSContextRef context, JSValueRef value) { JSStringRef pname = JSStringCreateWithUTF8CString("length"); JSValueRef len = JSObjectGetProperty (context, (JSObjectRef) value, pname, NULL); - int n = JSValueToNumber (context, len, NULL); + EMACS_INT n = JSValueToNumber (context, len, NULL); JSStringRelease(pname); Lisp_Object obj; struct Lisp_Vector *p = allocate_vector (n); - for (int i = 0; i < n; ++i) + for (ptrdiff_t i = 0; i < n; ++i) { p->contents[i] = webkit_js_to_lisp (context, @@ -323,13 +323,13 @@ webkit_js_to_lisp (JSContextRef context, JSValueRef value) JSPropertyNameArrayRef properties = JSObjectCopyPropertyNames (context, (JSObjectRef) value); - int n = JSPropertyNameArrayGetCount (properties); + ptrdiff_t n = JSPropertyNameArrayGetCount (properties); Lisp_Object obj; /* TODO: can we use a regular list here? */ struct Lisp_Vector *p = allocate_vector (n); - for (int i = 0; i < n; ++i) + for (ptrdiff_t i = 0; i < n; ++i) { JSStringRef name = JSPropertyNameArrayGetNameAtIndex (properties, i); JSValueRef property = JSObjectGetProperty (context, @@ -733,8 +733,8 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, (Lisp_Object xwidget, Lisp_Object new_width, Lisp_Object new_height) { CHECK_XWIDGET (xwidget); - CHECK_NATNUM (new_width); - CHECK_NATNUM (new_height); + CHECK_RANGED_INTEGER (new_width, 0, INT_MAX); + CHECK_RANGED_INTEGER (new_height, 0, INT_MAX); struct xwidget *xw = XXWIDGET (xwidget); int w = XFASTINT (new_width); int h = XFASTINT (new_height); commit cef233eeb8366580f76e8324695e6f964cb160d0 Author: Eli Zaretskii Date: Fri Feb 10 18:19:11 2017 +0200 Fix a bug with displaying an image after a TAB * src/xdisp.c (display_line): Handle TAB at end of screen line specially only when we are displaying characters. (Bug#25662) diff --git a/src/xdisp.c b/src/xdisp.c index 387a370972..6cb5b4e056 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -20995,7 +20995,10 @@ display_line (struct it *it) up to the right margin of the window. */ extend_face_to_end_of_line (it); } - else if (it->c == '\t' && FRAME_WINDOW_P (it->f)) + else if ((it->what == IT_CHARACTER + || it->what == IT_STRETCH + || it->what == IT_COMPOSITION) + && it->c == '\t' && FRAME_WINDOW_P (it->f)) { /* A TAB that extends past the right edge of the window. This produces a single glyph on commit 65298ff4d5861cbc8d88162d58c18fa972b81acf Author: Paul Eggert Date: Fri Feb 10 11:52:41 2017 +0200 Move cyclic tests to fns-tests.el * test/src/fns-tests.el (cyc1, cyc2, dot1, dot2): New functions. (test-cycle-length, test-cycle-safe-length, test-cycle-member) (test-cycle-memq, test-cycle-memql, test-cycle-assq) (test-cycle-assoc, test-cycle-rassq, test-cycle-rassoc) (test-cycle-delq, test-cycle-delete, test-cycle-reverse) (test-cycle-plist-get, test-cycle-lax-plist-get) (test-cycle-plist-member, test-cycle-plist-put) (test-cycle-lax-plist-put, test-cycle-equal, test-cycle-nconc): New tests. * test/manual/cyclic-tests.el: File deleted. diff --git a/test/manual/cycle-tests.el b/test/manual/cycle-tests.el deleted file mode 100644 index 2632b2d7b5..0000000000 --- a/test/manual/cycle-tests.el +++ /dev/null @@ -1,314 +0,0 @@ -;;; Test handling of cyclic and dotted lists -*- lexical-binding: t; -*- - -;; Copyright 2017 Free Software Foundation, Inc. - -;; Written by Paul Eggert - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(require 'ert) - -(defun cyc1 (a) - (let ((ls (make-list 10 a))) - (nconc ls ls) - ls)) -(defun cyc2 (a b) - (let ((ls1 (make-list 10 a)) - (ls2 (make-list 1000 b))) - (nconc ls2 ls2) - (nconc ls1 ls2) - ls1)) - -(defun dot1 (a) - (let ((ls (make-list 10 a))) - (nconc ls 'tail) - ls)) -(defun dot2 (a b) - (let ((ls1 (make-list 10 a)) - (ls2 (make-list 10 b))) - (nconc ls1 ls2) - (nconc ls2 'tail) - ls1)) - -(ert-deftest test-cycle-length () - (should-error (length (cyc1 1)) :type 'circular-list) - (should-error (length (cyc2 1 2)) :type 'circular-list) - (should-error (length (dot1 1)) :type 'wrong-type-argument) - (should-error (length (dot2 1 2)) :type 'wrong-type-argument)) - -(ert-deftest test-cycle-safe-length () - (should (<= 10 (safe-length (cyc1 1)))) - (should (<= 1010 (safe-length (cyc2 1 2)))) - (should (= 10 (safe-length (dot1 1)))) - (should (= 20 (safe-length (dot2 1 2))))) - -(ert-deftest test-cycle-member () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (member 1 c1)) - (should (member 1 c2)) - (should (member 1 d1)) - (should (member 1 d2)) - (should-error (member 2 c1) :type 'circular-list) - (should (member 2 c2)) - (should-error (member 2 d1) :type 'wrong-type-argument) - (should (member 2 d2)) - (should-error (member 3 c1) :type 'circular-list) - (should-error (member 3 c2) :type 'circular-list) - (should-error (member 3 d1) :type 'wrong-type-argument) - (should-error (member 3 d2) :type 'wrong-type-argument))) - -(ert-deftest test-cycle-memq () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (memq 1 c1)) - (should (memq 1 c2)) - (should (memq 1 d1)) - (should (memq 1 d2)) - (should-error (memq 2 c1) :type 'circular-list) - (should (memq 2 c2)) - (should-error (memq 2 d1) :type 'wrong-type-argument) - (should (memq 2 d2)) - (should-error (memq 3 c1) :type 'circular-list) - (should-error (memq 3 c2) :type 'circular-list) - (should-error (memq 3 d1) :type 'wrong-type-argument) - (should-error (memq 3 d2) :type 'wrong-type-argument))) - -(ert-deftest test-cycle-memql () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (memql 1 c1)) - (should (memql 1 c2)) - (should (memql 1 d1)) - (should (memql 1 d2)) - (should-error (memql 2 c1) :type 'circular-list) - (should (memql 2 c2)) - (should-error (memql 2 d1) :type 'wrong-type-argument) - (should (memql 2 d2)) - (should-error (memql 3 c1) :type 'circular-list) - (should-error (memql 3 c2) :type 'circular-list) - (should-error (memql 3 d1) :type 'wrong-type-argument) - (should-error (memql 3 d2) :type 'wrong-type-argument))) - -(ert-deftest test-cycle-assq () - (let ((c1 (cyc1 '(1))) - (c2 (cyc2 '(1) '(2))) - (d1 (dot1 '(1))) - (d2 (dot2 '(1) '(2)))) - (should (assq 1 c1)) - (should (assq 1 c2)) - (should (assq 1 d1)) - (should (assq 1 d2)) - (should-error (assq 2 c1) :type 'circular-list) - (should (assq 2 c2)) - (should-error (assq 2 d1) :type 'wrong-type-argument) - (should (assq 2 d2)) - (should-error (assq 3 c1) :type 'circular-list) - (should-error (assq 3 c2) :type 'circular-list) - (should-error (assq 3 d1) :type 'wrong-type-argument) - (should-error (assq 3 d2) :type 'wrong-type-argument))) - -(ert-deftest test-cycle-assoc () - (let ((c1 (cyc1 '(1))) - (c2 (cyc2 '(1) '(2))) - (d1 (dot1 '(1))) - (d2 (dot2 '(1) '(2)))) - (should (assoc 1 c1)) - (should (assoc 1 c2)) - (should (assoc 1 d1)) - (should (assoc 1 d2)) - (should-error (assoc 2 c1) :type 'circular-list) - (should (assoc 2 c2)) - (should-error (assoc 2 d1) :type 'wrong-type-argument) - (should (assoc 2 d2)) - (should-error (assoc 3 c1) :type 'circular-list) - (should-error (assoc 3 c2) :type 'circular-list) - (should-error (assoc 3 d1) :type 'wrong-type-argument) - (should-error (assoc 3 d2) :type 'wrong-type-argument))) - -(ert-deftest test-cycle-rassq () - (let ((c1 (cyc1 '(0 . 1))) - (c2 (cyc2 '(0 . 1) '(0 . 2))) - (d1 (dot1 '(0 . 1))) - (d2 (dot2 '(0 . 1) '(0 . 2)))) - (should (rassq 1 c1)) - (should (rassq 1 c2)) - (should (rassq 1 d1)) - (should (rassq 1 d2)) - (should-error (rassq 2 c1) :type 'circular-list) - (should (rassq 2 c2)) - (should-error (rassq 2 d1) :type 'wrong-type-argument) - (should (rassq 2 d2)) - (should-error (rassq 3 c1) :type 'circular-list) - (should-error (rassq 3 c2) :type 'circular-list) - (should-error (rassq 3 d1) :type 'wrong-type-argument) - (should-error (rassq 3 d2) :type 'wrong-type-argument))) - -(ert-deftest test-cycle-rassoc () - (let ((c1 (cyc1 '(0 . 1))) - (c2 (cyc2 '(0 . 1) '(0 . 2))) - (d1 (dot1 '(0 . 1))) - (d2 (dot2 '(0 . 1) '(0 . 2)))) - (should (rassoc 1 c1)) - (should (rassoc 1 c2)) - (should (rassoc 1 d1)) - (should (rassoc 1 d2)) - (should-error (rassoc 2 c1) :type 'circular-list) - (should (rassoc 2 c2)) - (should-error (rassoc 2 d1) :type 'wrong-type-argument) - (should (rassoc 2 d2)) - (should-error (rassoc 3 c1) :type 'circular-list) - (should-error (rassoc 3 c2) :type 'circular-list) - (should-error (rassoc 3 d1) :type 'wrong-type-argument) - (should-error (rassoc 3 d2) :type 'wrong-type-argument))) - -(ert-deftest test-cycle-delq () - (should-error (delq 1 (cyc1 1)) :type 'circular-list) - (should-error (delq 1 (cyc2 1 2)) :type 'circular-list) - (should-error (delq 1 (dot1 1)) :type 'wrong-type-argument) - (should-error (delq 1 (dot2 1 2)) :type 'wrong-type-argument) - (should-error (delq 2 (cyc1 1)) :type 'circular-list) - (should-error (delq 2 (cyc2 1 2)) :type 'circular-list) - (should-error (delq 2 (dot1 1)) :type 'wrong-type-argument) - (should-error (delq 2 (dot2 1 2)) :type 'wrong-type-argument) - (should-error (delq 3 (cyc1 1)) :type 'circular-list) - (should-error (delq 3 (cyc2 1 2)) :type 'circular-list) - (should-error (delq 3 (dot1 1)) :type 'wrong-type-argument) - (should-error (delq 3 (dot2 1 2)) :type 'wrong-type-argument)) - -(ert-deftest test-cycle-delete () - (should-error (delete 1 (cyc1 1)) :type 'circular-list) - (should-error (delete 1 (cyc2 1 2)) :type 'circular-list) - (should-error (delete 1 (dot1 1)) :type 'wrong-type-argument) - (should-error (delete 1 (dot2 1 2)) :type 'wrong-type-argument) - (should-error (delete 2 (cyc1 1)) :type 'circular-list) - (should-error (delete 2 (cyc2 1 2)) :type 'circular-list) - (should-error (delete 2 (dot1 1)) :type 'wrong-type-argument) - (should-error (delete 2 (dot2 1 2)) :type 'wrong-type-argument) - (should-error (delete 3 (cyc1 1)) :type 'circular-list) - (should-error (delete 3 (cyc2 1 2)) :type 'circular-list) - (should-error (delete 3 (dot1 1)) :type 'wrong-type-argument) - (should-error (delete 3 (dot2 1 2)) :type 'wrong-type-argument)) - -(ert-deftest test-cycle-reverse () - (should-error (reverse (cyc1 1)) :type 'circular-list) - (should-error (reverse (cyc2 1 2)) :type 'circular-list) - (should-error (reverse (dot1 1)) :type 'wrong-type-argument) - (should-error (reverse (dot2 1 2)) :type 'wrong-type-argument)) - -(ert-deftest test-cycle-plist-get () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (plist-get c1 1)) - (should (plist-get c2 1)) - (should (plist-get d1 1)) - (should (plist-get d2 1)) - (should-not (plist-get c1 2)) - (should (plist-get c2 2)) - (should-not (plist-get d1 2)) - (should (plist-get d2 2)) - (should-not (plist-get c1 3)) - (should-not (plist-get c2 3)) - (should-not (plist-get d1 3)) - (should-not (plist-get d2 3)))) - -(ert-deftest test-cycle-lax-plist-get () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (lax-plist-get c1 1)) - (should (lax-plist-get c2 1)) - (should (lax-plist-get d1 1)) - (should (lax-plist-get d2 1)) - (should-error (lax-plist-get c1 2) :type 'circular-list) - (should (lax-plist-get c2 2)) - (should-not (lax-plist-get d1 2)) - (should (lax-plist-get d2 2)) - (should-error (lax-plist-get c1 3) :type 'circular-list) - (should-error (lax-plist-get c2 3) :type 'circular-list) - (should-not (lax-plist-get d1 3)) - (should-not (lax-plist-get d2 3)))) - -(ert-deftest test-cycle-plist-member () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (plist-member c1 1)) - (should (plist-member c2 1)) - (should (plist-member d1 1)) - (should (plist-member d2 1)) - (should-error (plist-member c1 2) :type 'circular-list) - (should (plist-member c2 2)) - (should-error (plist-member d1 2) :type 'wrong-type-argument) - (should (plist-member d2 2)) - (should-error (plist-member c1 3) :type 'circular-list) - (should-error (plist-member c2 3) :type 'circular-list) - (should-error (plist-member d1 3) :type 'wrong-type-argument) - (should-error (plist-member d2 3) :type 'wrong-type-argument))) - -(ert-deftest test-cycle-plist-put () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (plist-put c1 1 1)) - (should (plist-put c2 1 1)) - (should (plist-put d1 1 1)) - (should (plist-put d2 1 1)) - (should-error (plist-put c1 2 2) :type 'circular-list) - (should (plist-put c2 2 2)) - (should (plist-put d1 2 2)) - (should (plist-put d2 2 2)) - (should-error (plist-put c1 3 3) :type 'circular-list) - (should-error (plist-put c2 3 3) :type 'circular-list) - (should (plist-put d1 3 3)) - (should (plist-put d2 3 3)))) - -(ert-deftest test-cycle-lax-plist-put () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (lax-plist-put c1 1 1)) - (should (lax-plist-put c2 1 1)) - (should (lax-plist-put d1 1 1)) - (should (lax-plist-put d2 1 1)) - (should-error (lax-plist-put c1 2 2) :type 'circular-list) - (should (lax-plist-put c2 2 2)) - (should (lax-plist-put d1 2 2)) - (should (lax-plist-put d2 2 2)) - (should-error (lax-plist-put c1 3 3) :type 'circular-list) - (should-error (lax-plist-put c2 3 3) :type 'circular-list) - (should (lax-plist-put d1 3 3)) - (should (lax-plist-put d2 3 3)))) - -(ert-deftest test-cycle-equal () - (should-error (equal (cyc1 1) (cyc1 1))) - (should-error (equal (cyc2 1 2) (cyc2 1 2)))) - -(ert-deftest test-cycle-nconc () - (should-error (nconc (cyc1 1) 'tail) :type 'circular-list) - (should-error (nconc (cyc2 1 2) 'tail) :type 'circular-list)) - -(provide 'cycle-tests) diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index ee3c5dc77e..160d0f106e 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -245,3 +245,301 @@ (let ((data '((foo) (bar)))) (should (equal (mapcan #'identity data) '(foo bar))) (should (equal data '((foo bar) (bar)))))) + +;; Test handling of cyclic and dotted lists. + +(defun cyc1 (a) + (let ((ls (make-list 10 a))) + (nconc ls ls) + ls)) + +(defun cyc2 (a b) + (let ((ls1 (make-list 10 a)) + (ls2 (make-list 1000 b))) + (nconc ls2 ls2) + (nconc ls1 ls2) + ls1)) + +(defun dot1 (a) + (let ((ls (make-list 10 a))) + (nconc ls 'tail) + ls)) + +(defun dot2 (a b) + (let ((ls1 (make-list 10 a)) + (ls2 (make-list 10 b))) + (nconc ls1 ls2) + (nconc ls2 'tail) + ls1)) + +(ert-deftest test-cycle-length () + (should-error (length (cyc1 1)) :type 'circular-list) + (should-error (length (cyc2 1 2)) :type 'circular-list) + (should-error (length (dot1 1)) :type 'wrong-type-argument) + (should-error (length (dot2 1 2)) :type 'wrong-type-argument)) + +(ert-deftest test-cycle-safe-length () + (should (<= 10 (safe-length (cyc1 1)))) + (should (<= 1010 (safe-length (cyc2 1 2)))) + (should (= 10 (safe-length (dot1 1)))) + (should (= 20 (safe-length (dot2 1 2))))) + +(ert-deftest test-cycle-member () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (member 1 c1)) + (should (member 1 c2)) + (should (member 1 d1)) + (should (member 1 d2)) + (should-error (member 2 c1) :type 'circular-list) + (should (member 2 c2)) + (should-error (member 2 d1) :type 'wrong-type-argument) + (should (member 2 d2)) + (should-error (member 3 c1) :type 'circular-list) + (should-error (member 3 c2) :type 'circular-list) + (should-error (member 3 d1) :type 'wrong-type-argument) + (should-error (member 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-memq () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (memq 1 c1)) + (should (memq 1 c2)) + (should (memq 1 d1)) + (should (memq 1 d2)) + (should-error (memq 2 c1) :type 'circular-list) + (should (memq 2 c2)) + (should-error (memq 2 d1) :type 'wrong-type-argument) + (should (memq 2 d2)) + (should-error (memq 3 c1) :type 'circular-list) + (should-error (memq 3 c2) :type 'circular-list) + (should-error (memq 3 d1) :type 'wrong-type-argument) + (should-error (memq 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-memql () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (memql 1 c1)) + (should (memql 1 c2)) + (should (memql 1 d1)) + (should (memql 1 d2)) + (should-error (memql 2 c1) :type 'circular-list) + (should (memql 2 c2)) + (should-error (memql 2 d1) :type 'wrong-type-argument) + (should (memql 2 d2)) + (should-error (memql 3 c1) :type 'circular-list) + (should-error (memql 3 c2) :type 'circular-list) + (should-error (memql 3 d1) :type 'wrong-type-argument) + (should-error (memql 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-assq () + (let ((c1 (cyc1 '(1))) + (c2 (cyc2 '(1) '(2))) + (d1 (dot1 '(1))) + (d2 (dot2 '(1) '(2)))) + (should (assq 1 c1)) + (should (assq 1 c2)) + (should (assq 1 d1)) + (should (assq 1 d2)) + (should-error (assq 2 c1) :type 'circular-list) + (should (assq 2 c2)) + (should-error (assq 2 d1) :type 'wrong-type-argument) + (should (assq 2 d2)) + (should-error (assq 3 c1) :type 'circular-list) + (should-error (assq 3 c2) :type 'circular-list) + (should-error (assq 3 d1) :type 'wrong-type-argument) + (should-error (assq 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-assoc () + (let ((c1 (cyc1 '(1))) + (c2 (cyc2 '(1) '(2))) + (d1 (dot1 '(1))) + (d2 (dot2 '(1) '(2)))) + (should (assoc 1 c1)) + (should (assoc 1 c2)) + (should (assoc 1 d1)) + (should (assoc 1 d2)) + (should-error (assoc 2 c1) :type 'circular-list) + (should (assoc 2 c2)) + (should-error (assoc 2 d1) :type 'wrong-type-argument) + (should (assoc 2 d2)) + (should-error (assoc 3 c1) :type 'circular-list) + (should-error (assoc 3 c2) :type 'circular-list) + (should-error (assoc 3 d1) :type 'wrong-type-argument) + (should-error (assoc 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-rassq () + (let ((c1 (cyc1 '(0 . 1))) + (c2 (cyc2 '(0 . 1) '(0 . 2))) + (d1 (dot1 '(0 . 1))) + (d2 (dot2 '(0 . 1) '(0 . 2)))) + (should (rassq 1 c1)) + (should (rassq 1 c2)) + (should (rassq 1 d1)) + (should (rassq 1 d2)) + (should-error (rassq 2 c1) :type 'circular-list) + (should (rassq 2 c2)) + (should-error (rassq 2 d1) :type 'wrong-type-argument) + (should (rassq 2 d2)) + (should-error (rassq 3 c1) :type 'circular-list) + (should-error (rassq 3 c2) :type 'circular-list) + (should-error (rassq 3 d1) :type 'wrong-type-argument) + (should-error (rassq 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-rassoc () + (let ((c1 (cyc1 '(0 . 1))) + (c2 (cyc2 '(0 . 1) '(0 . 2))) + (d1 (dot1 '(0 . 1))) + (d2 (dot2 '(0 . 1) '(0 . 2)))) + (should (rassoc 1 c1)) + (should (rassoc 1 c2)) + (should (rassoc 1 d1)) + (should (rassoc 1 d2)) + (should-error (rassoc 2 c1) :type 'circular-list) + (should (rassoc 2 c2)) + (should-error (rassoc 2 d1) :type 'wrong-type-argument) + (should (rassoc 2 d2)) + (should-error (rassoc 3 c1) :type 'circular-list) + (should-error (rassoc 3 c2) :type 'circular-list) + (should-error (rassoc 3 d1) :type 'wrong-type-argument) + (should-error (rassoc 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-delq () + (should-error (delq 1 (cyc1 1)) :type 'circular-list) + (should-error (delq 1 (cyc2 1 2)) :type 'circular-list) + (should-error (delq 1 (dot1 1)) :type 'wrong-type-argument) + (should-error (delq 1 (dot2 1 2)) :type 'wrong-type-argument) + (should-error (delq 2 (cyc1 1)) :type 'circular-list) + (should-error (delq 2 (cyc2 1 2)) :type 'circular-list) + (should-error (delq 2 (dot1 1)) :type 'wrong-type-argument) + (should-error (delq 2 (dot2 1 2)) :type 'wrong-type-argument) + (should-error (delq 3 (cyc1 1)) :type 'circular-list) + (should-error (delq 3 (cyc2 1 2)) :type 'circular-list) + (should-error (delq 3 (dot1 1)) :type 'wrong-type-argument) + (should-error (delq 3 (dot2 1 2)) :type 'wrong-type-argument)) + +(ert-deftest test-cycle-delete () + (should-error (delete 1 (cyc1 1)) :type 'circular-list) + (should-error (delete 1 (cyc2 1 2)) :type 'circular-list) + (should-error (delete 1 (dot1 1)) :type 'wrong-type-argument) + (should-error (delete 1 (dot2 1 2)) :type 'wrong-type-argument) + (should-error (delete 2 (cyc1 1)) :type 'circular-list) + (should-error (delete 2 (cyc2 1 2)) :type 'circular-list) + (should-error (delete 2 (dot1 1)) :type 'wrong-type-argument) + (should-error (delete 2 (dot2 1 2)) :type 'wrong-type-argument) + (should-error (delete 3 (cyc1 1)) :type 'circular-list) + (should-error (delete 3 (cyc2 1 2)) :type 'circular-list) + (should-error (delete 3 (dot1 1)) :type 'wrong-type-argument) + (should-error (delete 3 (dot2 1 2)) :type 'wrong-type-argument)) + +(ert-deftest test-cycle-reverse () + (should-error (reverse (cyc1 1)) :type 'circular-list) + (should-error (reverse (cyc2 1 2)) :type 'circular-list) + (should-error (reverse (dot1 1)) :type 'wrong-type-argument) + (should-error (reverse (dot2 1 2)) :type 'wrong-type-argument)) + +(ert-deftest test-cycle-plist-get () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (plist-get c1 1)) + (should (plist-get c2 1)) + (should (plist-get d1 1)) + (should (plist-get d2 1)) + (should-not (plist-get c1 2)) + (should (plist-get c2 2)) + (should-not (plist-get d1 2)) + (should (plist-get d2 2)) + (should-not (plist-get c1 3)) + (should-not (plist-get c2 3)) + (should-not (plist-get d1 3)) + (should-not (plist-get d2 3)))) + +(ert-deftest test-cycle-lax-plist-get () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (lax-plist-get c1 1)) + (should (lax-plist-get c2 1)) + (should (lax-plist-get d1 1)) + (should (lax-plist-get d2 1)) + (should-error (lax-plist-get c1 2) :type 'circular-list) + (should (lax-plist-get c2 2)) + (should-not (lax-plist-get d1 2)) + (should (lax-plist-get d2 2)) + (should-error (lax-plist-get c1 3) :type 'circular-list) + (should-error (lax-plist-get c2 3) :type 'circular-list) + (should-not (lax-plist-get d1 3)) + (should-not (lax-plist-get d2 3)))) + +(ert-deftest test-cycle-plist-member () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (plist-member c1 1)) + (should (plist-member c2 1)) + (should (plist-member d1 1)) + (should (plist-member d2 1)) + (should-error (plist-member c1 2) :type 'circular-list) + (should (plist-member c2 2)) + (should-error (plist-member d1 2) :type 'wrong-type-argument) + (should (plist-member d2 2)) + (should-error (plist-member c1 3) :type 'circular-list) + (should-error (plist-member c2 3) :type 'circular-list) + (should-error (plist-member d1 3) :type 'wrong-type-argument) + (should-error (plist-member d2 3) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-plist-put () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (plist-put c1 1 1)) + (should (plist-put c2 1 1)) + (should (plist-put d1 1 1)) + (should (plist-put d2 1 1)) + (should-error (plist-put c1 2 2) :type 'circular-list) + (should (plist-put c2 2 2)) + (should (plist-put d1 2 2)) + (should (plist-put d2 2 2)) + (should-error (plist-put c1 3 3) :type 'circular-list) + (should-error (plist-put c2 3 3) :type 'circular-list) + (should (plist-put d1 3 3)) + (should (plist-put d2 3 3)))) + +(ert-deftest test-cycle-lax-plist-put () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (lax-plist-put c1 1 1)) + (should (lax-plist-put c2 1 1)) + (should (lax-plist-put d1 1 1)) + (should (lax-plist-put d2 1 1)) + (should-error (lax-plist-put c1 2 2) :type 'circular-list) + (should (lax-plist-put c2 2 2)) + (should (lax-plist-put d1 2 2)) + (should (lax-plist-put d2 2 2)) + (should-error (lax-plist-put c1 3 3) :type 'circular-list) + (should-error (lax-plist-put c2 3 3) :type 'circular-list) + (should (lax-plist-put d1 3 3)) + (should (lax-plist-put d2 3 3)))) + +(ert-deftest test-cycle-equal () + (should-error (equal (cyc1 1) (cyc1 1))) + (should-error (equal (cyc2 1 2) (cyc2 1 2)))) + +(ert-deftest test-cycle-nconc () + (should-error (nconc (cyc1 1) 'tail) :type 'circular-list) + (should-error (nconc (cyc2 1 2) 'tail) :type 'circular-list)) + +(provide 'fns-tests)