mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-24 14:30:43 -08:00
Code Issues Projects Releases Wiki Activity

New major mode "SES" for spreadsheets.

Browse source 
New function (unsafep X) determines whether X is a safe Lisp form.
New support module testcover.el for coverage testing.
This commit is contained in:
Jonathan Yavner 2002-09-28 18:45:56 +00:00
parent 6209bd8c0a
commit 7ed9159a5c
16 changed files with 5722 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

711
lisp/emacs-lisp/testcover-ses.el Normal file
View file

@ -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.

139
lisp/emacs-lisp/testcover-unsafep.el Normal file
View file

@ -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.

448
lisp/emacs-lisp/testcover.el Normal file
View file

@ -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.

260
lisp/emacs-lisp/unsafep.el Normal file
View file

@ -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.