New major mode "SES" for spreadsheets.

New function (unsafep X) determines whether X is a safe Lisp form.
New support module testcover.el for coverage testing.

4 files changed, 1558 insertions, 0 deletions

diff --git a/lisp/emacs-lisp/testcover-ses.el b/lisp/emacs-lisp/testcover-ses.el
new file mode 100644
index 00000000000..3129d0a2c61
--- /dev/null
+++ b/lisp/emacs-lisp/testcover-ses.el
@@ -0,0 +1,711 @@
+;;;; testcover-ses.el -- Example use of `testcover' to test "SES"
+
+;; Copyright (C) 2002 Free Software Foundation, Inc.
+
+;; Author: Jonathan Yavner <jyavner@engineer.com>
+;; Maintainer: Jonathan Yavner <jyavner@engineer.com>
+;; Keywords: spreadsheet lisp utility
+
+;; GNU Emacs 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 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+(require 'testcover)
+
+;;;Here are some macros that exercise SES.  Set `pause' to t if you want the
+;;;macros to pause after each step.
+(let* ((pause nil)
+       (x (if pause "q" ""))
+       (y "ses-test.ses\r<"))
+  ;;Fiddle with the existing spreadsheet
+  (fset 'ses-exercise-example
+	(concat   "" data-directory "ses-example.ses\r<"
+		x "10"
+		x ""
+		x ""
+		x "pses-center\r"
+		x "p\r"
+		x "\t\t"
+		x "\r A9 B9\r"
+		x ""
+		x "\r
2\r"
+		x ""
+		x "50\r"
+		x "4"
+		x ""
+		x ""
+		x "(+ o\0"
+		x "-1o \r"
+		x ""
+		x))
+  ;;Create a new spreadsheet
+  (fset 'ses-exercise-new
+	(concat y
+		x "\"%.8g\"\r"
+		x "2\r"
+		x ""
+		x ""
+		x "2"
+		x "\"Header\r"
+		x "(sqrt 1\r"
+		x "pses-center\r"
+		x "\t"
+		x "(+ A2 A3\r"
+		x "(* B2 A3\r"
+		x "2"
+		x "\rB3\r"
+		x ""
+		x))
+  ;;Basic cell display
+  (fset 'ses-exercise-display
+	(concat y ":(revert-buffer t t)\r"
+		x ""
+		x "\"Very long\r"
+		x "w3\r"
+		x "w3\r"
+		x "(/ 1 0\r"
+		x "234567\r"
+		x "5w"
+		x "\t1\r"
+		x ""
+		x "234567\r"
+		x "\t"
+		x ""
+		x "345678\r"
+		x "3w"
+		x "\0>"
+		x ""
+		x ""
+		x ""
+		x "
"
+		x ""
+		x ""
+		x ""
+		x "1\r"
+		x ""
+		x ""
+		x "\"1234567-1234567-1234567\r"
+		x "123\r"
+		x "2"
+		x "\"1234567-1234567-1234567\r"
+		x "123\r"
+		x "w8\r"
+		x "\"1234567\r"
+		x "w5\r"
+		x))
+  ;;Cell formulas
+  (fset 'ses-exercise-formulas
+	(concat y ":(revert-buffer t t)\r"
+		x "\t\t"
+		x "\t"
+		x "(* B1 B2 D1\r"
+		x "(* B2 B3\r"
+		x "(apply '+ (ses-range B1 B3)\r"
+		x "(apply 'ses+ (ses-range B1 B3)\r"
+		x "(apply 'ses+ (ses-range A2 A3)\r"
+		x "(mapconcat'number-to-string(ses-range B2 B4) \"-\"\r"
+		x "(apply 'concat (reverse (ses-range A3 D3))\r"
+		x "(* (+ A2 A3) (ses+ B2 B3)\r"
+		x ""
+		x "2"
+		x "5\t"
+		x "(apply 'ses+ (ses-range E1 E2)\r"
+		x "(apply 'ses+ (ses-range A5 B5)\r"
+		x "(apply 'ses+ (ses-range E1 F1)\r"
+		x "(apply 'ses+ (ses-range D1 E1)\r"
+		x "\t"
+		x "(ses-average (ses-range A2 A5)\r"
+		x "(apply 'ses+ (ses-range A5 A6)\r"
+		x "k"
+		x ""
+		x ""
+		x "2"
+		x "3"
+		x "o"
+		x "2o"
+		x "3k"
+		x "(ses-average (ses-range B3 E3)\r"
+		x "k"
+		x "12345678\r"
+		x))
+  ;;Recalculating and reconstructing
+  (fset 'ses-exercise-recalc
+	(concat y ":(revert-buffer t t)\r"
+		x ""
+		x "\t\t"
+		x ""
+		x "(/ 1 0\r"
+		x ""
+		x "\n"
+		x ""
+		x "\"%.6g\"\r"
+		x ""
+		x ">nw"
+		x "\0>xdelete-region\r"
+		x ""
+		x "8"
+		x "\0>xdelete-region\r"
+		x ""
+		x ""
+		x "k"
+		x ""
+		x "\"Very long\r"
+		x ""
+		x "\r\r"
+		x ""
+		x "o"
+		x ""
+		x "\"Very long2\r"
+		x "o"
+		x ""
+		x "\rC3\r"
+		x "\rC2\r"
+		x "\0"
+		x "\rC4\r"
+		x "\rC2\r"
+		x "\0"
+		x ""
+		x "xses-mode\r"
+		x "<"
+		x "2k"
+		x))
+  ;;Header line
+  (fset 'ses-exercise-header-row
+	(concat y ":(revert-buffer t t)\r"
+		x "<"
+		x ">"
+		x "6<"
+		x ">"
+		x "7<"
+		x ">"
+		x "8<"
+		x "2<"
+		x ">"
+		x "3w"
+		x "10<"
+		x ">"
+		x "2"
+		x))
+  ;;Detecting unsafe formulas and printers
+  (fset 'ses-exercise-unsafe
+	(concat y ":(revert-buffer t t)\r"
+		x "p(lambda (x) (delete-file x))\rn"
+		x "p(lambda (x) (delete-file \"ses-nothing\"))\ry"
+		x "\0n"
+		x "(delete-file \"x\"\rn"
+		x "(delete-file \"ses-nothing\"\ry"
+		x "\0n"
+		x "(open-network-stream \"x\" nil \"localhost\" \"smtp\"\ry"
+		x "\0n"
+		x))
+  ;;Inserting and deleting rows
+  (fset 'ses-exercise-rows
+	(concat y ":(revert-buffer t t)\r"
+		x ""
+		x "\"%s=\"\r"
+		x "20"
+		x "p\"%s+\"\r"
+		x ""
+		x "123456789\r"
+		x "\021"
+		x ""
+		x ""
+		x "(not B25\r"
+		x "k"
+		x "jA3\r"
+		x "19"
+		x ""
+		x "100"  ;Make this approx your CPU speed in MHz
+		x))
+  ;;Inserting and deleting columns
+  (fset 'ses-exercise-columns
+	(concat y ":(revert-buffer t t)\r"
+		x "\"%s@\"\r"
+		x "o"
+		x ""
+		x "o"
+		x ""
+		x "k"
+		x "w8\r"
+		x "p\"%.7s*\"\r"
+		x "o"
+		x ""
+		x "2o"
+		x "3k"
+		x "\"%.6g\"\r"
+		x "26o"
+		x "\026\t"
+		x "26o"
+		x "0\r"
+		x "26\t"
+		x "400"
+		x "50k"
+		x "\0D"
+		x))
+  (fset 'ses-exercise-editing
+	(concat y ":(revert-buffer t t)\r"
+		x "1\r"
+		x "('x\r"
+		x ""
+		x ""
+		x "\r\r"
+		x "w9\r"
+		x "\r.5\r"
+		x "\r 10\r"
+		x "w12\r"
+		x "\r
'\r"
+		x "\r
\r"
+		x "jA4\r"
+		x "(+ A2 100\r"
+		x "3\r"
+		x "jB1\r"
+		x "(not A1\r"
+		x "\"Very long\r"
+		x ""
+		x "h"
+		x "H"
+		x ""
+		x ">\t"
+		x ""
+		x ""
+		x "2"
+		x ""
+		x "o"
+		x "h"
+		x "\0"
+		x "\"Also very long\r"
+		x "H"
+		x "\0'\r"
+		x "'Trial\r"
+		x "'qwerty\r"
+		x "(concat o<\0"
+		x "-1o\r"
+		x "(apply '+ o<\0-1o\r"
+		x "2"
+		x "-2"
+		x "-2"
+		x "2"
+		x ""
+		x "H"
+		x "\0"
+		x "\"Another long one\r"
+		x "H"
+		x "
"
+		x "<"
+		x ""
+		x ">"
+		x "\0"
+		x))
+  ;;Sorting of columns
+  (fset 'ses-exercise-sort-column
+	(concat y ":(revert-buffer t t)\r"
+		x "\"Very long\r"
+		x "99\r"
+		x "o13\r"
+		x "(+ A3 B3\r"
+		x "7\r8\r(* A4 B4\r"
+		x "\0A\r"
+		x "\0B\r"
+		x "\0C\r"
+		x "o"
+		x "\0C\r"
+		x))
+  ;;Simple cell printers
+  (fset 'ses-exercise-cell-printers
+	(concat y ":(revert-buffer t t)\r"
+		x "\"4\t76\r"
+		x "\"4\n7\r"
+		x "p\"{%S}\"\r"
+		x "p(\"[%s]\")\r"
+		x "p(\"<%s>\")\r"
+		x "\0"
+		x "p\r"
+		x "pnil\r"
+		x "pses-dashfill\r"
+		x "48\r"
+		x "\t"
+		x "\0p\r"
+		x "p\r"
+		x "pses-dashfill\r"
+		x "\0pnil\r"
+		x "5\r"
+		x "pses-center\r"
+		x "\"%s\"\r"
+		x "w8\r"
+		x "p\r"
+		x "p\"%.7g@\"\r"
+		x "\r"
+		x "\"%.6g#\"\r"
+		x "\"%.6g.\"\r"
+		x "\"%.6g.\"\r"
+		x "pidentity\r"
+		x "6\r"
+		x "\"UPCASE\r"
+		x "pdowncase\r"
+		x "(* 3 4\r"
+		x "p(lambda (x) '(\"Hi\"))\r"
+		x "p(lambda (x) '(\"Bye\"))\r"
+		x))
+  ;;Spanning cell printers
+  (fset 'ses-exercise-spanning-printers
+	(concat y ":(revert-buffer t t)\r"
+		x "p\"%.6g*\"\r"
+		x "pses-dashfill-span\r"
+		x "5\r"
+		x "pses-tildefill-span\r"
+		x "\"4\r"
+		x "p\"$%s\"\r"
+		x "p(\"$%s\")\r"
+		x "8\r"
+		x "p(\"!%s!\")\r"
+		x "\t\"12345678\r"
+		x "pses-dashfill-span\r"
+		x "\"23456789\r"
+		x "\t"
+		x "(not t\r"
+		x "w6\r"
+		x "\"5\r"
+		x "o"
+		x "k"
+		x "k"
+		x "\t"
+		x ""
+		x "o"
+		x "2k"
+		x "k"
+		x))
+  ;;Cut/copy/paste - within same buffer
+  (fset 'ses-exercise-paste-1buf
+	(concat y ":(revert-buffer t t)\r"
+		x "\0w"
+		x ""
+		x "o"
+		x "\"middle\r"
+		x "\0"
+		x "w"
+		x "\0"
+		x "w"
+		x ""
+		x ""
+		x "2y"
+		x "y"
+		x "y"
+		x ">"
+		x "y"
+		x ">y"
+		x "<"
+		x "p\"<%s>\"\r"
+		x "pses-dashfill\r"
+		x "\0"
+		x ""
+		x ""
+		x "y"
+		x "\r\0w"
+		x "\r"
+		x "3(+ G2 H1\r"
+		x "\0w"
+		x ">"
+		x ""
+		x "8(ses-average (ses-range G2 H2)\r"
+		x "\0k"
+		x "7"
+		x ""
+		x "(ses-average (ses-range E7 E9)\r"
+		x "\0"
+		x ""
+		x "(ses-average (ses-range E7 F7)\r"
+		x "\0k"
+		x ""
+		x "(ses-average (ses-range D6 E6)\r"
+		x "\0k"
+		x ""
+		x "
2"
+		x "\"Line A\r"
+		x "pses-tildefill-span\r"
+		x "\"Subline A(1)\r"
+		x "pses-dashfill-span\r"
+		x "\0w"
+		x "
"
+		x ""
+		x "\0w"
+		x ""
+		x))
+  ;;Cut/copy/paste - between two buffers
+  (fset 'ses-exercise-paste-2buf
+	(concat y ":(revert-buffer t t)\r"
+		x "o\"middle\r\0"
+		x ""
+		x "4bses-test.txt\r"
+		x " 
"
+		x "\"xxx\0"
+		x "wo"
+		x ""
+		x ""
+		x "o\"\0"
+		x "wo"
+		x "o123.45\0"
+		x "o"
+		x "o1 \0"
+		x "o"
+		x ">y"
+		x "o symb\0"
+		x "oy2y"
+		x "o1\t\0"
+		x "o"
+		x "w9\np\"<%s>\"\n"
+		x "o\n2\t\"3\nxxx\t5\n\0"
+		x "oy"
+		x))
+  ;;Export text, import it back
+  (fset 'ses-exercise-import-export
+	(concat y ":(revert-buffer t t)\r"
+		x "\0xt"
+		x "4bses-test.txt\r"
+		x "\n-1o"
+		x "xTo-1o"
+		x "'crunch\r"
+		x "pses-center-span\r"
+		x "\0xT"
+		x "o\n-1o"
+		x "\0y"
+		x "\0xt"
+		x "\0y"
+		x "12345678\r"
+		x "'bunch\r"
+		x "\0xtxT"
+		x)))
+
+(defun ses-exercise-macros ()
+  "Executes all SES coverage-test macros."
+  (dolist (x '(ses-exercise-example
+	       ses-exercise-new
+	       ses-exercise-display
+	       ses-exercise-formulas
+	       ses-exercise-recalc
+	       ses-exercise-header-row
+	       ses-exercise-unsafe
+	       ses-exercise-rows
+	       ses-exercise-columns
+	       ses-exercise-editing
+	       ses-exercise-sort-column
+	       ses-exercise-cell-printers
+	       ses-exercise-spanning-printers
+	       ses-exercise-paste-1buf
+	       ses-exercise-paste-2buf
+	       ses-exercise-import-export))
+    (message "<Testing %s>" x)
+    (execute-kbd-macro x)))
+
+(defun ses-exercise-signals ()
+  "Exercise code paths that lead to error signals, other than those for
+spreadsheet files with invalid formatting."
+  (message "<Checking for expected errors>")
+  (switch-to-buffer "ses-test.ses")
+  (deactivate-mark)
+  (ses-jump 'A1)
+  (ses-set-curcell)
+  (dolist (x '((ses-column-widths 14)
+	       (ses-column-printers "%s")
+	       (ses-column-printers ["%s" "%s" "%s"]) ;Should be two
+	       (ses-column-widths [14])
+	       (ses-delete-column -99)
+	       (ses-delete-column 2)
+	       (ses-delete-row -1)
+	       (ses-goto-data 'hogwash)
+	       (ses-header-row -56)
+	       (ses-header-row 99)
+	       (ses-insert-column -14)
+	       (ses-insert-row 0)
+	       (ses-jump 'B8) ;Covered by preceding cell
+	       (ses-printer-validate '("%s" t))
+	       (ses-printer-validate '([47]))
+	       (ses-read-header-row -1)
+	       (ses-read-header-row 32767)
+	       (ses-relocate-all 0 0 -1 1)
+	       (ses-relocate-all 0 0 1 -1)
+	       (ses-select (ses-range A1 A2) 'x (ses-range B1 B1))
+	       (ses-set-cell 0 0 'hogwash nil)
+	       (ses-set-column-width 0 0)
+	       (ses-yank-cells #("a\nb"
+				 0 1 (ses (A1 nil nil))
+				 2 3 (ses (A3 nil nil)))
+			       nil)
+	       (ses-yank-cells #("ab"
+				 0 1 (ses (A1 nil nil))
+				 1 2 (ses (A2 nil nil)))
+			       nil)
+	       (ses-yank-pop nil)
+	       (ses-yank-tsf "1\t2\n3" nil)
+	       (let ((curcell nil)) (ses-check-curcell))
+	       (let ((curcell 'A1)) (ses-check-curcell 'needrange))
+	       (let ((curcell '(A1 . A2))) (ses-check-curcell 'end))
+	       (let ((curcell '(A1 . A2))) (ses-sort-column "B"))
+	       (let ((curcell '(C1 . D2))) (ses-sort-column "B"))
+	       (execute-kbd-macro "jB10\n2")
+	       (execute-kbd-macro [?j ?B ?9 ?\n ?C-@ ?C-f ?C-f cut])
+	       (progn (kill-new "x") (execute-kbd-macro ">n"))
+	       (execute-kbd-macro "\0w")))
+    (condition-case nil
+	(progn
+	  (eval x)
+	  (signal 'singularity-error nil)) ;Shouldn't get here
+      (singularity-error (error "No error from %s?" x))
+      (error nil)))
+  ;;Test quit-handling in ses-update-cells.  Cant' use `eval' here.
+  (let ((inhibit-quit t))
+    (setq quit-flag t)
+    (condition-case nil
+	(progn
+	  (ses-update-cells '(A1))
+	  (signal 'singularity-error nil))
+      (singularity-error (error "Quit failure in ses-update-cells"))
+      (error nil))
+    (setq quit-flag nil)))
+
+(defun ses-exercise-invalid-spreadsheets ()
+  "Execute code paths that detect invalid spreadsheet files."
+  ;;Detect invalid spreadsheets
+  (let ((p&d "\n\n\n(ses-cell A1 nil nil nil nil)\n\n")
+	(cw  "(ses-column-widths [7])\n")
+	(cp  "(ses-column-printers [ses-center])\n")
+	(dp  "(ses-default-printer \"%.7g\")\n")
+	(hr  "(ses-header-row 0)\n")
+	(p11 "(2 1 1)")
+	(igp ses-initial-global-parameters))
+    (dolist (x (list "(1)"
+		     "(x 2 3)"
+		     "(1 x 3)"
+		     "(1 -1 0)"
+		     "(1 2 x)"
+		     "(1 2 -1)"
+		     "(3 1 1)"
+		     "\n\n(2 1 1)"
+		     "\n\n\n(ses-cell)(2 1 1)"
+		     "\n\n\n(x)\n(2 1 1)"
+		     "\n\n\n\n(ses-cell A2)\n(2 2 2)"
+		     "\n\n\n\n(ses-cell B1)\n(2 2 2)"
+		     "\n\n\n(ses-cell A1 nil nil nil nil)\n(2 1 1)"
+		     (concat p&d "(x)\n(x)\n(x)\n(x)\n" p11)
+		     (concat p&d "(ses-column-widths)(x)\n(x)\n(x)\n" p11)
+		     (concat p&d cw "(x)\n(x)\n(x)\n(2 1 1)")
+		     (concat p&d cw "(ses-column-printers)(x)\n(x)\n" p11)
+		     (concat p&d cw cp "(x)\n(x)\n" p11)
+		     (concat p&d cw cp "(ses-default-printer)(x)\n" p11)
+		     (concat p&d cw cp dp "(x)\n" p11)
+		     (concat p&d cw cp dp "(ses-header-row)" p11)
+		     (concat p&d cw cp dp hr p11)
+		     (concat p&d cw cp dp "\n" hr igp)))
+      (condition-case nil
+	  (with-temp-buffer
+	    (insert x)
+	    (ses-load)
+	    (signal 'singularity-error nil)) ;Shouldn't get here
+	(singularity-error (error "%S is an invalid spreadsheet!" x))
+	(error nil)))))
+
+(defun ses-exercise-startup ()
+  "Prepare for coverage tests"
+  ;;Clean up from any previous runs
+  (condition-case nil (kill-buffer "ses-example.ses") (error nil))
+  (condition-case nil (kill-buffer "ses-test.ses") (error nil))
+  (condition-case nil (delete-file "ses-test.ses") (file-error nil))
+  (delete-other-windows) ;Needed for "\C-xo" in ses-exercise-editing
+  (setq ses-mode-map nil) ;Force rebuild
+  (testcover-unmark-all "ses.el")
+  ;;Enable
+  (let ((testcover-1value-functions
+	 ;;forward-line always returns 0, for us.
+	 ;;remove-text-properties always returns t for us.
+	 ;;ses-recalculate-cell returns the same " " any time curcell is a cons
+	 ;;Macros ses-dorange and ses-dotimes-msg generate code that always
+	 ;;  returns nil
+	 (append '(forward-line remove-text-properties ses-recalculate-cell
+		   ses-dorange ses-dotimes-msg)
+		 testcover-1value-functions))
+	(testcover-constants
+	 ;;These maps get initialized, then never changed again
+	 (append '(ses-mode-map ses-mode-print-map ses-mode-edit-map)
+		 testcover-constants)))
+    (testcover-start "ses.el" t))
+  (require 'unsafep)) ;In case user has safe-functions = t!
+
+
+;;;#########################################################################
+(defun ses-exercise ()
+  "Executes all SES coverage tests and displays the results."
+  (interactive)
+  (ses-exercise-startup)
+  ;;Run the keyboard-macro tests
+  (let ((safe-functions nil)
+	(ses-initial-size '(1 . 1))
+	(ses-initial-column-width 7)
+	(ses-initial-default-printer "%.7g")
+	(ses-after-entry-functions '(forward-char))
+	(ses-mode-hook nil))
+    (ses-exercise-macros)
+    (ses-exercise-signals)
+    (ses-exercise-invalid-spreadsheets)
+    ;;Upgrade of old-style spreadsheet
+    (with-temp-buffer
+      (insert "       \n\n\n(ses-cell A1 nil nil nil nil)\n\n(ses-column-widths [7])\n(ses-column-printers [nil])\n(ses-default-printer \"%.7g\")\n\n( ;Global parameters (these are read first)\n 1 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n")
+      (ses-load))
+    ;;ses-vector-delete is always called from buffer-undo-list with the same
+    ;;symbol as argument.  We'll give it a different one here.
+    (let ((x [1 2 3]))
+      (ses-vector-delete 'x 0 0))
+    ;;ses-create-header-string behaves differently in a non-window environment
+    ;;but we always test under windows.
+    (let ((window-system (not window-system)))
+      (scroll-left 7)
+      (ses-create-header-string))
+    ;;Test for nonstandard after-entry functions
+    (let ((ses-after-entry-functions '(forward-line))
+	  ses-mode-hook)
+      (ses-read-cell 0 0 1)
+      (ses-read-symbol 0 0 t)))
+  ;;Tests with unsafep disabled
+  (let ((safe-functions t)
+	ses-mode-hook)
+    (message "<Checking safe-functions = t>")
+    (kill-buffer "ses-example.ses")
+    (find-file "ses-example.ses"))
+  ;;Checks for nonstandard default values for new spreadsheets
+  (let (ses-mode-hook)
+    (dolist (x '(("%.6g" 8 (2 . 2))
+		 ("%.8g" 6 (3 . 3))))
+      (let ((ses-initial-size            (nth 2 x))
+	    (ses-initial-column-width    (nth 1 x))
+	    (ses-initial-default-printer (nth 0 x)))
+	(with-temp-buffer
+	  (set-buffer-modified-p t)
+	  (ses-mode)))))
+  ;;Test error-handling in command hook, outside a macro.
+  ;;This will ring the bell.
+  (let (curcell-overlay)
+    (ses-command-hook))
+  ;;Due to use of run-with-timer, ses-command-hook sometimes gets called
+  ;;after we switch to another buffer.
+  (switch-to-buffer "*scratch*")
+  (ses-command-hook)
+  ;;Print results
+  (message "<Marking source code>")
+  (testcover-mark-all "ses.el")
+  (testcover-next-mark)
+  ;;Cleanup
+  (delete-other-windows)
+  (kill-buffer "ses-test.txt")
+  ;;Could do this here: (testcover-end "ses.el")
+  (message "Done"))
+
+;; testcover-ses.el ends here.
diff --git a/lisp/emacs-lisp/testcover-unsafep.el b/lisp/emacs-lisp/testcover-unsafep.el
new file mode 100644
index 00000000000..e54648e73ad
--- /dev/null
+++ b/lisp/emacs-lisp/testcover-unsafep.el
@@ -0,0 +1,139 @@
+;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage
+
+;; Copyright (C) 2002 Free Software Foundation, Inc.
+
+;; Author: Jonathan Yavner <jyavner@engineer.com>
+;; Maintainer: Jonathan Yavner <jyavner@engineer.com>
+;; Keywords: safety lisp utility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+(require 'testcover)
+
+;;;These forms are all considered safe
+(defconst testcover-unsafep-safe
+  '(((lambda (x) (* x 2)) 14)
+    (apply 'cdr (mapcar '(lambda (x) (car x)) y))
+    (cond ((= x 4) 5) (t 27))
+    (condition-case x (car y) (error (car x)))
+    (dolist (x y) (message "here: %s" x))
+    (dotimes (x 14 (* x 2)) (message "here: %d" x))
+    (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x)))
+    (let (x) (apply '(lambda (x) (* x 2)) 14))
+    (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2))
+    (let ((x 1) (y 2)) (setq x (+ x y)))
+    (let ((x 1)) (let ((y (+ x 3))) (* x y)))
+    (let* nil (current-time))
+    (let* ((x 1) (y (+ x 3))) (* x y))
+    (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3))
+    (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ")
+    (setq buffer-display-count 14 mark-active t)
+    ;;This is not safe if you insert it into a buffer!
+    (propertize "x" 'display '(height (progn (delete-file "x") 1))))
+  "List of forms that `unsafep' should decide are safe.")
+
+;;;These forms are considered unsafe
+(defconst testcover-unsafep-unsafe
+  '(( (add-to-list x y)
+      . (unquoted x))
+    ( (add-to-list y x)
+      . (unquoted y))
+    ( (add-to-list 'y x)
+      . (global-variable y))
+    ( (not (delete-file "unsafep.el"))
+      . (function delete-file))
+    ( (cond (t (aset local-abbrev-table 0 0)))
+      . (function aset))
+    ( (cond (t (setq unsafep-vars "")))
+      . (risky-local-variable unsafep-vars))
+    ( (condition-case format-alist 1)
+      . (risky-local-variable format-alist))
+    ( (condition-case x 1 (error (setq format-alist "")))
+      . (risky-local-variable format-alist))
+    ( (dolist (x (sort globalvar 'car)) (princ x))
+      . (function sort))
+    ( (dotimes (x 14) (delete-file "x"))
+      . (function delete-file))
+    ( (let ((post-command-hook "/tmp/")) 1)
+      . (risky-local-variable post-command-hook))
+    ( (let ((x (delete-file "x"))) 2)
+      . (function delete-file))
+    ( (let (x) (add-to-list 'x (delete-file "x")))
+      . (function delete-file))
+    ( (let (x) (condition-case y (setq x 1 z 2)))
+      . (global-variable z))
+    ( (let (x) (condition-case z 1 (error (delete-file "x"))))
+      . (function delete-file))
+    ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4))))
+      . (function setcar))
+    ( (let (y) (push (delete-file "x") y))
+      . (function delete-file))
+    ( (let* ((x 1)) (setq y 14))
+      . (global-variable y))
+    ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el")))
+      . (function kill-buffer))
+    ( (mapcar x y)
+      . (unquoted x))
+    ( (mapcar '(lambda (x) (rename-file x "x")) '("unsafep.el"))
+      . (function rename-file))
+    ( (mapconcat x1 x2 " ")
+      . (unquoted x1))
+    ( (pop format-alist)
+      . (risky-local-variable format-alist))
+    ( (push 1 format-alist)
+      . (risky-local-variable format-alist))
+    ( (setq buffer-display-count (delete-file "x"))
+      . (function delete-file))
+    ;;These are actualy safe (they signal errors)
+    ( (apply '(x) '(1 2 3))
+      . (function (x)))
+    ( (let (((x))) 1)
+      . (variable (x)))
+    ( (let (1) 2)
+      . (variable 1))
+    )
+  "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.")
+
+
+;;;#########################################################################
+(defun testcover-unsafep ()
+  "Executes all unsafep tests and displays the coverage results."
+  (interactive)
+  (testcover-unmark-all "unsafep.el")
+  (testcover-start "unsafep.el")
+  (let (save-functions)
+    (dolist (x testcover-unsafep-safe)
+      (if (unsafep x)
+	  (error "%S should be safe" x)))
+    (dolist (x testcover-unsafep-unsafe)
+      (if (not (equal (unsafep (car x)) (cdr x)))
+	  (error "%S should be unsafe: %s" (car x) (cdr x))))
+    (setq safe-functions t)
+    (if (or (unsafep '(delete-file "x"))
+	    (unsafep-function 'delete-file))
+	(error "safe-functions=t should allow delete-file"))
+    (setq safe-functions '(setcar))
+    (if (unsafep '(setcar x 1))
+	(error "safe-functions=(setcar) should allow setcar"))
+    (if (not (unsafep '(setcdr x 1)))
+	(error "safe-functions=(setcar) should not allow setcdr")))
+  (testcover-mark-all "unsafep.el")
+  (testcover-end "unsafep.el")
+  (message "Done"))
+
+;; testcover-unsafep.el ends here.
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
new file mode 100644
index 00000000000..8287611aa61
--- /dev/null
+++ b/lisp/emacs-lisp/testcover.el
@@ -0,0 +1,448 @@
+;;;; testcover.el -- Visual code-coverage tool
+
+;; Copyright (C) 2002 Free Software Foundation, Inc.
+
+;; Author: Jonathan Yavner <jyavner@engineer.com>
+;; Maintainer: Jonathan Yavner <jyavner@engineer.com>
+;; Keywords: lisp utility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+
+;;; Commentary:
+
+;; * Use `testcover-start' to instrument a Lisp file for coverage testing.
+;; * Use `testcover-mark-all' to add overlay "splotches" to the Lisp file's
+;;   buffer to show where coverage is lacking.  Normally, a red splotch
+;;   indicates the form was never evaluated; a brown splotch means it always
+;;   evaluted to the same value.
+;; * Use `testcover-next-mark' (bind it to a key!) to jump to the next spot
+;;   that has a splotch.
+
+;; * Basic algorithm: use `edebug' to mark up the function text with
+;;   instrumentation callbacks, then replace edebug's callbacks with ours.
+;; * To show good coverage, we want to see two values for every form, except
+;;   functions that always return the same value and `defconst' variables
+;;   need show only value for good coverage.  To avoid the brown splotch, the
+;;   definitions for constants and 1-valued functions must precede the
+;;   references.
+;; * Use the macro `1value' in your Lisp code to mark spots where the local
+;;   code environment causes a function or variable to always have the same
+;;   value, but the function or variable is not intrinsically 1-valued.
+;; * Use the macro `noreturn' in your Lisp code to mark function calls that
+;;   never return, because of the local code environment, even though the
+;;   function being called is capable of returning in other cases.
+
+;; Problems:
+;; * To detect different values, we store the form's result in a vector and
+;;   compare the next result using `equal'.  We don't copy the form's
+;;   result, so if caller alters it (`setcar', etc.) we'll think the next
+;;   call has the same value!  Also, equal thinks two strings are the same
+;;   if they differ only in properties.
+;; * Because we have only a "1value" class and no "always nil" class, we have
+;;   to treat as 1-valued any `and' whose last term is 1-valued, in case the
+;;   last term is always nil.  Example:
+;;     (and (< (point) 1000) (forward-char 10))
+;;   This form always returns nil.  Similarly, `if' and `cond' are
+;;   treated as 1-valued if all clauses are, in case those values are
+;;   always nil.
+
+(require 'edebug)
+(provide 'testcover)
+
+
+;;;==========================================================================
+;;; User options
+;;;==========================================================================
+
+(defgroup testcover nil
+  "Code-coverage tester"
+  :group 'lisp
+  :prefix "testcover-"
+  :version "21.1")
+
+(defcustom testcover-constants
+  '(nil t emacs-build-time emacs-version emacs-major-version
+    emacs-minor-version)
+  "Variables whose values never change.  No brown splotch is shown for
+these.  This list is quite incomplete!"
+  :group 'testcover
+  :type '(repeat variable))
+
+(defcustom testcover-1value-functions
+  '(backward-char barf-if-buffer-read-only beginning-of-line
+    buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark
+    delete-char delete-region ding error forward-char insert insert-and-inherit
+    kill-all-local-variables lambda mapc narrow-to-region noreturn push-mark
+    put-text-property run-hooks set-text-properties signal
+    substitute-key-definition suppress-keymap throw undo use-local-map while
+    widen yank)
+  "Functions that always return the same value.  No brown splotch is shown
+for these.  This list is quite incomplete!  Notes: Nobody ever changes the
+current global map.  The macro `lambda' is self-evaluating, hence always
+returns the same value (the function it defines may return varying values
+when called)."
+  :group 'testcover
+  :type 'hook)
+
+(defcustom testcover-noreturn-functions
+  '(error noreturn throw signal)
+  "Subset of `testcover-1value-functions' -- these never return.  We mark
+them as having returned nil just before calling them."
+  :group 'testcover
+  :type 'hook)
+
+(defcustom testcover-compose-functions
+  '(+ - * / length list make-keymap make-sparse-keymap message propertize
+    replace-regexp-in-string run-with-idle-timer
+    set-buffer-modified-p)
+  "Functions that are 1-valued if all their args are either constants or
+calls to one of the `testcover-1value-functions', so if that's true then no
+brown splotch is shown for these.  This list is quite incomplete!  Most
+side-effect-free functions should be here."
+  :group 'testcover
+  :type 'hook)
+
+(defcustom testcover-progn-functions
+  '(define-key fset function goto-char or overlay-put progn save-current-buffer
+    save-excursion save-match-data save-restriction save-selected-window
+    save-window-excursion set set-default setq setq-default
+    with-output-to-temp-buffer with-syntax-table with-temp-buffer
+    with-temp-file with-temp-message with-timeout)
+  "Functions whose return value is the same as their last argument.  No
+brown splotch is shown for these if the last argument is a constant or a
+call to one of the `testcover-1value-functions'.  This list is probably
+incomplete!  Note: `or' is here in case the last argument is a function that
+always returns nil."
+  :group 'testcover
+  :type 'hook)
+
+(defcustom testcover-prog1-functions
+  '(prog1 unwind-protect)
+  "Functions whose return value is the same as their first argument.  No
+brown splotch is shown for these if the first argument is a constant or a
+call to one of the `testcover-1value-functions'."
+  :group 'testcover
+  :type 'hook)
+
+(defface testcover-nohits-face
+  '((t (:background "DeepPink2")))
+  "Face for forms that had no hits during coverage test"
+  :group 'testcover)
+
+(defface testcover-1value-face
+  '((t (:background "Wheat2")))
+  "Face for forms that always produced the same value during coverage test"
+  :group 'testcover)
+
+
+;;;=========================================================================
+;;; Other variables
+;;;=========================================================================
+
+(defvar testcover-module-constants nil
+  "Symbols declared with defconst in the last file processed by
+`testcover-start'.")
+
+(defvar testcover-module-1value-functions nil
+  "Symbols declared with defun in the last file processed by
+`testcover-start', whose functions always return the same value.")
+
+(defvar testcover-vector nil
+  "Locally bound to coverage vector for function in progress.")
+
+
+;;;=========================================================================
+;;; Add instrumentation to your module
+;;;=========================================================================
+
+;;;###autoload
+(defun testcover-start (filename &optional byte-compile)
+  "Uses edebug to instrument all macros and functions in FILENAME, then
+changes the instrumentation from edebug to testcover--much faster, no
+problems with type-ahead or post-command-hook, etc.  If BYTE-COMPILE is
+non-nil, byte-compiles each function after instrumenting."
+  (interactive "f")
+  (let ((buf             (find-file filename))
+	(load-read-function 'testcover-read)
+	(edebug-all-defs t))
+    (setq edebug-form-data                       nil
+	  testcover-module-constants             nil
+	  testcover-module-1value-functions nil)
+    (eval-buffer buf))
+  (when byte-compile
+    (dolist (x (reverse edebug-form-data))
+      (when (fboundp (car x))
+	(message "Compiling %s..." (car x))
+	(byte-compile (car x))))))
+
+;;;###autoload
+(defun testcover-this-defun ()
+  "Start coverage on function under point."
+  (interactive)
+  (let* ((edebug-all-defs t)
+	 (x (symbol-function (eval-defun nil))))
+    (testcover-reinstrument x)
+    x))
+
+(defun testcover-read (&optional stream)
+  "Read a form using edebug, changing edebug callbacks to testcover callbacks."
+  (let ((x (edebug-read stream)))
+    (testcover-reinstrument x)
+    x))
+
+(defun testcover-reinstrument (form)
+  "Reinstruments FORM to use testcover instead of edebug.  This function
+modifies the list that FORM points to.  Result is non-nil if FORM will
+always return the same value."
+  (let ((fun (car-safe form)))
+    (cond
+     ((not fun) ;Atom
+      (or (not (symbolp form))
+	  (memq form testcover-constants)
+	  (memq form testcover-module-constants)))
+     ((consp fun) ;Embedded list
+      (testcover-reinstrument fun)
+      (testcover-reinstrument-list (cdr form))
+      nil)
+     ((or (memq fun testcover-1value-functions)
+	  (memq fun testcover-module-1value-functions))
+      ;;Always return same value
+      (testcover-reinstrument-list (cdr form))
+      t)
+     ((memq fun testcover-progn-functions)
+      ;;1-valued if last argument is
+      (testcover-reinstrument-list (cdr form)))
+     ((memq fun testcover-prog1-functions)
+      ;;1-valued if first argument is
+      (testcover-reinstrument-list (cddr form))
+      (testcover-reinstrument (cadr form)))
+     ((memq fun testcover-compose-functions)
+      ;;1-valued if all arguments are
+      (setq fun t)
+      (mapc #'(lambda (x) (setq fun (or (testcover-reinstrument x) fun)))
+	    (cdr form))
+      fun)
+     ((eq fun 'edebug-enter)
+      ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
+      ;;  => (testcover-enter 'SYM #'(lambda nil FORMS))
+      (setcar form 'testcover-enter)
+      (setcdr (nthcdr 1 form) (nthcdr 3 form))
+      (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage)))
+	(testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form))))))
+     ((eq fun 'edebug-after)
+      ;;(edebug-after (edebug-before XXX) YYY FORM)
+      ;; => (testcover-after YYY FORM), mark XXX as ok-coverage
+      (unless (eq (cadr form) 0)
+	(aset testcover-vector (cadr (cadr form)) 'ok-coverage))
+      (setq fun (nth 2 form))
+      (setcdr form (nthcdr 2 form))
+      (if (not (memq (car-safe (nth 2 form)) testcover-noreturn-functions))
+	  (setcar form 'testcover-after)
+	;;This function won't return, so set the value in advance
+	;;(edebug-after (edebug-before XXX) YYY FORM)
+	;;  => (progn (edebug-after YYY nil) FORM)
+	(setcar form 'progn)
+	(setcar (cdr form) `(testcover-after ,fun nil)))
+      (when (testcover-reinstrument (nth 2 form))
+	(aset testcover-vector fun '1value)))
+     ((eq fun 'defun)
+      (if (testcover-reinstrument-list (nthcdr 3 form))
+	  (push (cadr form) testcover-module-1value-functions)))
+     ((eq fun 'defconst)
+      ;;Define this symbol as 1-valued
+      (push (cadr form) testcover-module-constants)
+      (testcover-reinstrument-list (cddr form)))
+     ((memq fun '(dotimes dolist))
+      ;;Always returns third value from SPEC
+      (testcover-reinstrument-list (cddr form))
+      (setq fun (testcover-reinstrument-list (cadr form)))
+      (if (nth 2 (cadr form))
+	  fun
+	;;No third value, always returns nil
+	t))
+     ((memq fun '(let let*))
+      ;;Special parsing for second argument
+      (mapc 'testcover-reinstrument-list (cadr form))
+      (testcover-reinstrument-list (cddr form)))
+     ((eq fun 'if)
+      ;;1-valued if both THEN and ELSE clauses are
+      (testcover-reinstrument (cadr form))
+      (let ((then (testcover-reinstrument (nth 2 form)))
+	    (else (testcover-reinstrument-list (nthcdr 3 form))))
+	(and then else)))
+     ((memq fun '(when unless and))
+      ;;1-valued if last clause of BODY is
+      (testcover-reinstrument-list (cdr form)))
+     ((eq fun 'cond)
+      ;;1-valued if all clauses are
+      (testcover-reinstrument-clauses (cdr form)))
+     ((eq fun 'condition-case)
+      ;;1-valued if BODYFORM is and all HANDLERS are
+      (let ((body (testcover-reinstrument (nth 2 form)))
+	    (errs (testcover-reinstrument-clauses (mapcar #'cdr
+							  (nthcdr 3 form)))))
+	(and body errs)))
+     ((eq fun 'quote)
+      ;;Don't reinstrument what's inside!
+      ;;This doesn't apply within a backquote
+      t)
+     ((eq fun '\`)
+      ;;Quotes are not special within backquotes
+      (let ((testcover-1value-functions
+	     (cons 'quote testcover-1value-functions)))
+	(testcover-reinstrument (cadr form))))
+     ((eq fun '\,)
+      ;;In commas inside backquotes, quotes are special again
+      (let ((testcover-1value-functions
+	     (remq 'quote testcover-1value-functions)))
+	(testcover-reinstrument (cadr form))))
+     ((memq fun '(1value noreturn))
+      ;;Hack - pretend the arg is 1-valued here
+      (if (symbolp (cadr form)) ;A pseudoconstant variable
+	  t
+	(let ((testcover-1value-functions
+	       (cons (car (cadr form)) testcover-1value-functions)))
+	  (testcover-reinstrument (cadr form)))))
+     (t ;Some other function or weird thing
+      (testcover-reinstrument-list (cdr form))
+      nil))))
+
+(defun testcover-reinstrument-list (list)
+  "Reinstruments each form in LIST to use testcover instead of edebug.
+This function modifies the forms in LIST.  Result is `testcover-reinstrument's
+value for the last form in LIST.  If the LIST is empty, its evaluation will
+always be nil, so we return t for 1-valued."
+  (let ((result t))
+    (while (consp list)
+      (setq result (testcover-reinstrument (pop list))))
+    result))
+
+(defun testcover-reinstrument-clauses (clauselist)
+  "Reinstruments each list in CLAUSELIST.  Result is t if every
+clause is 1-valued."
+  (let ((result t))
+    (mapc #'(lambda (x)
+	      (setq result (and (testcover-reinstrument-list x) result)))
+	  clauselist)
+    result))
+
+(defun testcover-end (buffer)
+  "Turn off instrumentation of all macros and functions in FILENAME."
+  (interactive "b")
+  (let ((buf (find-file-noselect buffer)))
+    (eval-buffer buf t)))
+
+(defmacro 1value (form)
+  "For code-coverage testing, indicate that FORM is expected to always have
+the same value."
+  form)
+
+(defmacro noreturn (form)
+  "For code-coverage testing, indicate that FORM will always signal an error."
+  form)
+
+
+;;;=========================================================================
+;;; Accumulate coverage data
+;;;=========================================================================
+
+(defun testcover-enter (testcover-sym testcover-fun)
+  "Internal function for coverage testing.  Invokes TESTCOVER-FUN while
+binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM
+\(the name of the current function)."
+  (let ((testcover-vector (get testcover-sym 'edebug-coverage)))
+    (funcall testcover-fun)))
+
+(defun testcover-after (idx val)
+  "Internal function for coverage testing.  Returns VAL after installing it in
+`testcover-vector' at offset IDX."
+  (cond
+   ((eq (aref testcover-vector idx) 'unknown)
+    (aset testcover-vector idx val))
+   ((not (equal (aref testcover-vector idx) val))
+    (aset testcover-vector idx 'ok-coverage)))
+  val)
+
+
+;;;=========================================================================
+;;; Display the coverage data as color splotches on your code.
+;;;=========================================================================
+
+(defun testcover-mark (def)
+  "Marks one DEF (a function or macro symbol) to highlight its contained forms
+that did not get completely tested during coverage tests.
+  A marking of testcover-nohits-face (default = red) indicates that the
+form was never evaluated.  A marking of testcover-1value-face
+\(default = tan) indicates that the form always evaluated to the same value.
+  The forms throw, error, and signal are not marked.  They do not return and
+would always get a red mark.  Some forms that always return the same
+value (e.g., setq of a constant), always get a tan mark that can't be
+eliminated by adding more test cases."
+  (let* ((data     (get def 'edebug))
+	 (def-mark (car data))
+	 (points   (nth 2 data))
+	 (len      (length points))
+	 (changed (buffer-modified-p))
+	 (coverage (get def 'edebug-coverage))
+	 ov j item)
+    (or (and def-mark points coverage)
+	(error "Missing edebug data for function %s" def))
+    (set-buffer (marker-buffer def-mark))
+    (mapc 'delete-overlay (overlays-in def-mark
+				       (+ def-mark (aref points (1- len)) 1)))
+    (while (> len 0)
+      (setq len  (1- len)
+	    data (aref coverage len))
+      (when (and (not (eq data 'ok-coverage))
+		 (setq j (+ def-mark (aref points len))))
+	  (setq ov (make-overlay (1- j) j))
+	  (overlay-put ov 'face
+		       (if (memq data '(unknown 1value))
+			   'testcover-nohits-face
+			 'testcover-1value-face))))
+    (set-buffer-modified-p changed)))
+
+(defun testcover-mark-all (&optional buffer)
+  "Mark all forms in BUFFER that did not get completley tested during
+coverage tests.  This function creates many overlays.  SKIPFUNCS is a list
+of function-symbols that should not be marked."
+  (interactive "b")
+  (if buffer
+      (switch-to-buffer buffer))
+  (goto-char 1)
+  (dolist (x edebug-form-data)
+    (if (fboundp (car x))
+	(testcover-mark (car x)))))
+
+(defun testcover-unmark-all (buffer)
+  "Remove all overlays from FILENAME."
+  (interactive "b")
+  (condition-case nil
+      (progn
+	(set-buffer buffer)
+	(mapc 'delete-overlay (overlays-in 1 (buffer-size))))
+    (error nil)))  ;Ignore "No such buffer" errors
+
+(defun testcover-next-mark ()
+  "Moves point to next line in current buffer that has a splotch."
+  (interactive)
+  (goto-char (next-overlay-change (point)))
+  (end-of-line))
+
+;; testcover.el ends here.
diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el
new file mode 100644
index 00000000000..59b81f3ef89
--- /dev/null
+++ b/lisp/emacs-lisp/unsafep.el
@@ -0,0 +1,260 @@
+;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate
+
+;; Copyright (C) Free Software Foundation, Inc.
+
+;; Author: Jonathan Yavner <jyavner@engineer.com>
+;; Maintainer: Jonathan Yavner <jyavner@engineer.com>
+;; Keywords: safety lisp utility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This is a simplistic implementation that does not allow any modification of
+;; buffers or global variables.  It does no dataflow analysis, so functions
+;; like `funcall' and `setcar' are completely disallowed.  It is designed
+;; for "pure Lisp" formulas, like those in spreadsheets, that don't make any
+;; use of the text editing capabilities of Emacs.
+
+;; A formula is safe if:
+;;  1.  It's an atom.
+;;  2.  It's a function call to a safe function and all arguments are safe
+;;      formulas.
+;;  3.  It's a special form whose arguments are like a function's (and,
+;;	catch, if, or, prog1, prog2, progn, while, unwind-protect).
+;;  4.  It's a special form or macro that creates safe temporary bindings
+;;      (condition-case, dolist, dotimes, lambda, let, let*).
+;;  4.  It's one of (cond, quote) that have special parsing.
+;;  5.  It's one of (add-to-list, setq, push, pop) and the assignment variable
+;;      is safe.
+;;  6.  It's one of (apply, mapc, mapcar, mapconcat) and its first arg is a
+;;      quoted safe function.
+;;
+;; A function is safe if:
+;;  1.  It's a lambda containing safe formulas.
+;;  2.  It's a member of list `safe-functions', so the user says it's safe.
+;;  3.  It's a symbol with the `side-effect-free' property, defined by the
+;;      byte compiler or function author.
+;;  4.  It's a symbol with the `safe-function' property, defined here or by
+;;      the function author.  Value t indicates a function that is safe but
+;;      has innocuous side effects.  Other values will someday indicate
+;;      functions with side effects that are not always safe.
+;;  The `side-effect-free' and `safe-function' properties are provided for
+;;  built-in functions and for functions and macros defined in subr.el.
+;;
+;; A temporary binding is unsafe if its symbol:
+;;  1.  Has the `risky-local-variable' property.
+;;  2.  Has a name that ends with -command, font-lock-keywords(-[0-9]+)?,
+;;      font-lock-syntactic-keywords, -form, -forms, -frame-alist, -function,
+;;       -functions, -history, -hook, -hooks, -map, -map-alist, -mode-alist,
+;;       -predicate, or -program.
+;;
+;; An assignment variable is unsafe if:
+;;   1. It would be unsafe as a temporary binding.
+;;   2. It doesn't already have a temporary or buffer-local binding.
+
+;; There are unsafe forms that `unsafep' cannot detect.  Beware of these:
+;;   1. The form's result is a string with a display property containing a
+;;      form to be evaluated later, and you insert this result into a
+;;      buffer.  Always remove display properties before inserting!
+;;   2. The form alters a risky variable that was recently added to Emacs and
+;;      is not yet marked with the `risky-local-variable' property.
+;;   3. The form uses undocumented features of built-in functions that have
+;;      the `side-effect-free' property.  For example, in Emacs-20 if you
+;;      passed a circular list to `assoc', Emacs would crash.  Historically,
+;;      problems of this kind have been few and short-lived.
+
+(provide 'unsafep)
+(require 'byte-opt)  ;Set up the `side-effect-free' properties
+
+(defcustom safe-functions nil
+  "t to disable all safety checks, or a list of assumed-safe functions."
+  :group 'lisp
+  :type  '(choice (const :tag "No" nil) (const :tag "Yes" t) hook))
+
+(defvar unsafep-vars nil
+  "Dynamically-bound list of variables that have lexical bindings at this
+point in the parse.")
+(put 'unsafep-vars 'risky-local-variable t)
+
+;;Side-effect-free functions from subr.el
+(dolist (x '(assoc-default assoc-ignore-case butlast last match-string
+	     match-string-no-properties member-ignore-case remove remq))
+  (put x 'side-effect-free t))
+
+;;Other safe functions
+(dolist (x '(;;Special forms
+	     and catch if or prog1 prog2 progn while unwind-protect
+	     ;;Safe subrs that have some side-effects
+	     ding error message minibuffer-message random read-minibuffer
+	     signal sleep-for string-match throw y-or-n-p yes-or-no-p
+	     ;;Defsubst functions from subr.el
+	     caar cadr cdar cddr
+	     ;;Macros from subr.el
+	     save-match-data unless when with-temp-message
+	     ;;Functions from subr.el that have side effects
+	     read-passwd split-string replace-regexp-in-string
+	     play-sound-file))
+  (put x 'safe-function t))
+
+;;;###autoload
+(defun unsafep (form &optional unsafep-vars)
+  "Return nil if evaluating FORM couldn't possibly do any harm; otherwise
+result is a reason why FORM is unsafe.  UNSAFEP-VARS is a list of symbols
+with local bindings."
+  (catch 'unsafep
+    (if (or (eq safe-functions t)	    ;User turned off safety-checking
+	    (atom form))		    ;Atoms are never unsafe
+	(throw 'unsafep nil))
+    (let* ((fun    (car form))
+	   (reason (unsafep-function fun))
+	   arg)
+      (cond
+       ((not reason)
+	;;It's a normal function - unsafe if any arg is
+	(unsafep-progn (cdr form)))
+       ((eq fun 'quote)
+	;;Never unsafe
+	nil)
+       ((memq fun '(apply mapc mapcar mapconcat))
+	;;Unsafe if 1st arg isn't a quoted lambda
+	(setq arg (cadr form))
+	(cond
+	 ((memq (car-safe arg) '(quote function))
+	  (setq reason (unsafep-function (cadr arg))))
+	 ((eq (car-safe arg) 'lambda)
+	  ;;Self-quoting lambda
+	  (setq reason (unsafep arg unsafep-vars)))
+	 (t
+	  (setq reason `(unquoted ,arg))))
+	(or reason (unsafep-progn (cddr form))))
+       ((eq fun 'lambda)
+	;;First arg is temporary bindings
+	(mapc #'(lambda (x)
+		  (let ((y (unsafep-variable x t)))
+		    (if y (throw 'unsafep y)))
+		  (or (memq x '(&optional &rest))
+		      (push x unsafep-vars)))
+	      (cadr form))
+	(unsafep-progn (cddr form)))
+       ((eq fun 'let)
+	;;Creates temporary bindings in one step
+	(setq unsafep-vars (nconc (mapcar #'unsafep-let (cadr form))
+				  unsafep-vars))
+	(unsafep-progn (cddr form)))
+       ((eq fun 'let*)
+	;;Creates temporary bindings iteratively
+	(dolist (x (cadr form))
+	  (push (unsafep-let x) unsafep-vars))
+	(unsafep-progn (cddr form)))
+       ((eq fun 'setq)
+	;;Safe if odd arguments are local-var syms, evens are safe exprs
+	(setq arg (cdr form))
+	(while arg
+	  (setq reason (or (unsafep-variable (car arg) nil)
+			   (unsafep (cadr arg) unsafep-vars)))
+	  (if reason (throw 'unsafep reason))
+	  (setq arg (cddr arg))))
+       ((eq fun 'pop)
+	;;safe if arg is local-var sym
+	(unsafep-variable (cadr form) nil))
+       ((eq fun 'push)
+	;;Safe if 2nd arg is a local-var sym
+	(or (unsafep (cadr form) unsafep-vars)
+	    (unsafep-variable (nth 2 form) nil)))
+       ((eq fun 'add-to-list)
+	;;Safe if first arg is a quoted local-var sym
+	(setq arg (cadr form))
+	(if (not (eq (car-safe arg) 'quote))
+	    `(unquoted ,arg)
+	  (or (unsafep-variable (cadr arg) nil)
+	      (unsafep-progn (cddr form)))))
+       ((eq fun 'cond)
+	;;Special form with unusual syntax - safe if all args are
+	(dolist (x (cdr form))
+	  (setq reason (unsafep-progn x))
+	  (if reason (throw 'unsafep reason))))
+       ((memq fun '(dolist dotimes))
+	;;Safe if COUNT and RESULT are safe.  VAR is bound while checking BODY.
+	(setq arg (cadr form))
+	(or (unsafep-progn (cdr arg))
+	    (let ((unsafep-vars (cons (car arg) unsafep-vars)))
+	      (unsafep-progn (cddr form)))))
+       ((eq fun 'condition-case)
+	;;Special form with unusual syntax - safe if all args are
+	(or (unsafep-variable (cadr form) t)
+	    (unsafep (nth 2 form) unsafep-vars)
+	    (let ((unsafep-vars (cons (cadr form) unsafep-vars)))
+	      ;;var is bound only during handlers
+	      (dolist (x (nthcdr 3 form))
+		(setq reason (unsafep-progn (cdr x)))
+		(if reason (throw 'unsafep reason))))))
+       (t
+	;;First unsafep-function call above wasn't nil, no special case applies
+	reason)))))
+
+
+(defun unsafep-function (fun)
+  "Return nil if FUN is a safe function (either a safe lambda or a
+symbol that names a safe function).  Otherwise result is a reason code."
+  (cond
+   ((eq (car-safe fun) 'lambda)
+    (unsafep fun unsafep-vars))
+   ((not (and (symbolp fun)
+	      (or (get fun 'side-effect-free)
+		  (eq (get fun 'safe-function) t)
+		  (eq safe-functions t)
+		  (memq fun safe-functions))))
+    `(function ,fun))))
+
+(defun unsafep-progn (list)
+  "Return nil if all forms in LIST are safe, or the reason for the first
+unsafe form."
+  (catch 'unsafep-progn
+    (let (reason)
+      (dolist (x list)
+	(setq reason (unsafep x unsafep-vars))
+	(if reason (throw 'unsafep-progn reason))))))
+
+(defun unsafep-let (clause)
+  "CLAUSE is a let-binding, either SYM or (SYM) or (SYM VAL).  Throws a
+reason to `unsafep' if VAL isn't safe.  Returns SYM."
+  (let (reason sym)
+    (if (atom clause)
+	(setq sym clause)
+      (setq sym    (car clause)
+	    reason (unsafep (cadr clause) unsafep-vars)))
+    (setq reason (or (unsafep-variable sym t) reason))
+    (if reason (throw 'unsafep reason))
+    sym))
+
+(defun unsafep-variable (sym global-okay)
+  "Returns nil if SYM is lexically bound or is a non-risky buffer-local
+variable, otherwise a reason why it is unsafe.  Failing to be locally bound
+is okay if GLOBAL-OKAY is non-nil."
+  (cond
+   ((not (symbolp sym))
+    `(variable ,sym))
+   ((risky-local-variable-p sym)
+    `(risky-local-variable ,sym))
+   ((not (or global-okay
+	     (memq sym unsafep-vars)
+	     (local-variable-p sym)))
+    `(global-variable ,sym))))
+
+;; unsafep.el ends here.