diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/ChangeLog | 26 | ||||
| -rw-r--r-- | lisp/cus-load.el | 22 | ||||
| -rw-r--r-- | lisp/emacs-lisp/testcover-ses.el | 711 | ||||
| -rw-r--r-- | lisp/emacs-lisp/testcover-unsafep.el | 139 | ||||
| -rw-r--r-- | lisp/emacs-lisp/testcover.el | 448 | ||||
| -rw-r--r-- | lisp/emacs-lisp/unsafep.el | 260 | ||||
| -rw-r--r-- | lisp/files.el | 18 | ||||
| -rw-r--r-- | lisp/ses.el | 2914 |
8 files changed, 4523 insertions, 15 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e3dd28265e..491b50c998 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -895,6 +895,17 @@ * viper.el (viper-emacs-state-mode-list): Added modes. +2002-09-18 Jonathan Yavner <[email protected]> + + * emacs-lisp/testcover.el: New file. Uses edebug to instrument a + module of code, with graphical display of poor-coverage spots. + + * emacs-lisp/testcover-ses.el: New file. Demonstrates use of + testcover on a interactive module like ses. + + * emacs-lisp/testcover-unsafep.el: New file. Demonstrates use of + testcover on a noninteractive module like unsafep. + 2002-09-18 Miles Bader <[email protected]> * diff-mode.el (diff-mode): Don't evaluate `compilation-last-buffer' @@ -909,6 +920,21 @@ Don't output the C-x # message if `nowait'. (server-buffer-done): Use server-log's new arg. +2002-09-16 Jonathan Yavner <[email protected]> + + * ses.el: New file. + + * emacs-lisp/unsafep.el: New file. + + * files.el (auto-mode-alist): Add ".ses" for ses-mode. + (inhibit-quit): This is risky for unsafep, doesn't matter much for + anybody else. + (risky-local-variable-p): New function. Split off from + hack-one-local-variable so unsafep can use it. Add \|-history$ to + the list of disallowed local variable names (malicious user could + stuff a `display' property in there that would be activated when + na,Ao(Bve user called up the history). + 2002-09-16 Markus Rost <[email protected]> * ls-lisp.el (ls-lisp-format-time-list): Fix type and provide :tag's. diff --git a/lisp/cus-load.el b/lisp/cus-load.el index 4591db7b28..7045703527 100644 --- a/lisp/cus-load.el +++ b/lisp/cus-load.el @@ -37,8 +37,8 @@ (put 'ps-print-vertical 'custom-loads '("ps-print")) (put 'supercite-hooks 'custom-loads '("supercite")) (put 'vhdl-menu 'custom-loads '("vhdl-mode")) -(put 'chinese-calendar 'custom-loads '("cal-china")) (put 'gnus-newsrc 'custom-loads '("gnus-start")) +(put 'chinese-calendar 'custom-loads '("cal-china")) (put 'expand 'custom-loads '("expand")) (put 'bookmark 'custom-loads '("bookmark")) (put 'icon 'custom-loads '("icon")) @@ -221,8 +221,8 @@ (put 'auto-save 'custom-loads '("files" "startup")) (put 'tpu 'custom-loads '("tpu-edt" "tpu-extras")) (put 'w32 'custom-loads '("w32-vars")) -(put 'viper-hooks 'custom-loads '("viper-init")) (put 'gnus-cite 'custom-loads '("gnus-cite")) +(put 'viper-hooks 'custom-loads '("viper-init")) (put 'gnus-demon 'custom-loads '("gnus-demon")) (put 'reftex-optimizations-for-large-documents 'custom-loads '("reftex-vars")) (put 'viper-misc 'custom-loads '("viper-cmd" "viper-init" "viper")) @@ -265,18 +265,20 @@ (put 'ps-print 'custom-loads '("ps-print")) (put 'view 'custom-loads '("view" "calendar")) (put 'cwarn 'custom-loads '("cwarn")) +(put 'testcover 'custom-loads '("testcover")) (put 'gnus-score-default 'custom-loads '("gnus-score" "gnus-sum")) (put 'ebnf-except 'custom-loads '("ebnf2ps")) (put 'nnmail-duplicate 'custom-loads '("nnmail")) (put 'handwrite 'custom-loads '("handwrite")) (put 'tags 'custom-loads '("speedbar")) +(put 'ses 'custom-loads '("ses")) (put 'eshell-proc 'custom-loads '("esh-proc")) (put 'custom-browse 'custom-loads '("cus-edit")) (put 'mime 'custom-loads '("mailcap" "mm-bodies")) (put 'generic-x 'custom-loads '("generic-x")) (put 'partial-completion 'custom-loads '("complete")) (put 'whitespace 'custom-loads '("whitespace")) -(put 'maint 'custom-loads '("emacsbug" "gulp" "lisp-mnt")) +(put 'maint 'custom-loads '("gulp" "lisp-mnt" "emacsbug")) (put 'pages 'custom-loads '("page-ext")) (put 'message-interface 'custom-loads '("message")) (put 'diary 'custom-loads '("calendar" "diary-lib" "solar")) @@ -374,8 +376,8 @@ (put 'log-view 'custom-loads '("log-view")) (put 'PostScript 'custom-loads '("ps-mode")) (put 'abbrev-mode 'custom-loads '("abbrev" "cus-edit" "mailabbrev")) -(put 'eshell-term 'custom-loads '("em-term")) (put 'earcon 'custom-loads '("earcon")) +(put 'eshell-term 'custom-loads '("em-term")) (put 'feedmail-headers 'custom-loads '("feedmail")) (put 'hypermedia 'custom-loads '("wid-edit" "metamail" "browse-url" "goto-addr")) (put 'image 'custom-loads '("image-file")) @@ -466,14 +468,14 @@ (put 'bibtex 'custom-loads '("bibtex")) (put 'faces 'custom-loads '("faces" "loaddefs" "facemenu" "cus-edit" "font-lock" "hilit-chg" "paren" "ps-print" "speedbar" "time" "whitespace" "wid-edit" "woman" "gnus" "message" "cwarn" "make-mode")) (put 'gnus-summary-various 'custom-loads '("gnus-sum")) -(put 'applications 'custom-loads '("calendar" "cus-edit" "uniquify" "eshell" "spell")) +(put 'applications 'custom-loads '("calendar" "cus-edit" "ses" "uniquify" "eshell" "spell")) (put 'ebrowse-member 'custom-loads '("ebrowse")) (put 'terminal 'custom-loads '("terminal")) (put 'shadow 'custom-loads '("shadowfile" "shadow")) (put 'hl-line 'custom-loads '("hl-line")) (put 'eshell-glob 'custom-loads '("em-glob")) (put 'internal 'custom-loads '("startup" "cus-edit" "delim-col")) -(put 'lisp 'custom-loads '("simple" "lisp" "lisp-mode" "ielm" "xscheme" "advice" "bytecomp" "checkdoc" "cl-indent" "cust-print" "edebug" "eldoc" "elp" "find-func" "pp" "re-builder" "shadow" "trace" "scheme")) +(put 'lisp 'custom-loads '("simple" "lisp" "lisp-mode" "ielm" "unsafep" "xscheme" "advice" "bytecomp" "checkdoc" "cl-indent" "cust-print" "edebug" "eldoc" "elp" "find-func" "pp" "re-builder" "shadow" "testcover" "trace" "scheme")) (put 'local 'custom-loads '("calendar")) (put 'rlogin 'custom-loads '("rlogin")) (put 'debugger 'custom-loads '("debug")) @@ -848,10 +850,14 @@ as a PDF file <URL:http://www.ecma.ch/ecma1/STAND/ECMA-048.HTM>.") (custom-put-if-not 'sql-db2-options 'standard-value t) (custom-put-if-not 'cwarn 'custom-version "21.1") (custom-put-if-not 'cwarn 'group-documentation "Highlight suspicious C and C++ constructions.") +(custom-put-if-not 'testcover 'custom-version "21.1") +(custom-put-if-not 'testcover 'group-documentation "Code-coverage tester") (custom-put-if-not 'sgml-xml-mode 'custom-version "21.4") (custom-put-if-not 'sgml-xml-mode 'standard-value t) (custom-put-if-not 'message-buffer-naming-style 'custom-version "21.1") (custom-put-if-not 'message-buffer-naming-style 'standard-value t) +(custom-put-if-not 'ses 'custom-version "21.1") +(custom-put-if-not 'ses 'group-documentation "Simple Emacs Spreadsheet") (custom-put-if-not 'ps-footer-font-size 'custom-version "21.1") (custom-put-if-not 'ps-footer-font-size 'standard-value t) (custom-put-if-not 'hscroll-margin 'custom-version "21.3") @@ -872,10 +878,10 @@ as a PDF file <URL:http://www.ecma.ch/ecma1/STAND/ECMA-048.HTM>.") (custom-put-if-not 'vc-diff-switches 'standard-value t) (custom-put-if-not 'vcursor-interpret-input 'custom-version "20.3") (custom-put-if-not 'vcursor-interpret-input 'standard-value t) -(custom-put-if-not 'diary-sabbath-candles-minutes 'custom-version "21.1") -(custom-put-if-not 'diary-sabbath-candles-minutes 'standard-value t) (custom-put-if-not 'gnus-audio 'custom-version "21.1") (custom-put-if-not 'gnus-audio 'group-documentation "Playing sound in Gnus.") +(custom-put-if-not 'diary-sabbath-candles-minutes 'custom-version "21.1") +(custom-put-if-not 'diary-sabbath-candles-minutes 'standard-value t) (custom-put-if-not 'trailing-whitespace 'custom-version "21.1") (custom-put-if-not 'trailing-whitespace 'group-documentation nil) (custom-put-if-not 'fortran-comment-line-start 'custom-version "21.1") diff --git a/lisp/emacs-lisp/testcover-ses.el b/lisp/emacs-lisp/testcover-ses.el new file mode 100644 index 0000000000..3129d0a2c6 --- /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 <[email protected]> +;; Maintainer: Jonathan Yavner <[email protected]> +;; 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 0000000000..e54648e73a --- /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 <[email protected]> +;; Maintainer: Jonathan Yavner <[email protected]> +;; 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 0000000000..8287611aa6 --- /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 <[email protected]> +;; Maintainer: Jonathan Yavner <[email protected]> +;; 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 0000000000..59b81f3ef8 --- /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 <[email protected]> +;; Maintainer: Jonathan Yavner <[email protected]> +;; 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. diff --git a/lisp/files.el b/lisp/files.el index 6a893d958d..33ae2b3c94 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1617,6 +1617,7 @@ in that case, this function acts as if `enable-local-variables' were t." ;; and after the .scm.[0-9] and CVS' <file>.<rev> patterns too. ("\\.[1-9]\\'" . nroff-mode) ("\\.g\\'" . antlr-mode) + ("\\.ses\\'" . ses-mode) ("\\.in\\'" nil t))) "Alist of filename patterns vs corresponding major mode functions. Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL). @@ -2010,6 +2011,7 @@ is specified, returning t if it is specified." (put 'ignored-local-variables 'risky-local-variable t) (put 'eval 'risky-local-variable t) (put 'file-name-handler-alist 'risky-local-variable t) +(put 'inhibit-quit 'risky-local-variable t) (put 'minor-mode-alist 'risky-local-variable t) (put 'minor-mode-map-alist 'risky-local-variable t) (put 'minor-mode-overriding-map-alist 'risky-local-variable t) @@ -2058,6 +2060,14 @@ is specified, returning t if it is specified." ;; This one is safe because the user gets to check it before it is used. (put 'compile-command 'safe-local-variable t) +(defun risky-local-variable-p (sym) + "Returns non-nil if SYM could be dangerous as a file-local variable." + (or (memq sym ignored-local-variables) + (get sym 'risky-local-variable) + (and (string-match "-hooks?$\\|-functions?$\\|-forms?$\\|-program$\\|-command$\\|-predicate$\\|font-lock-keywords$\\|font-lock-keywords-[0-9]+$\\|font-lock-syntactic-keywords$\\|-frame-alist$\\|-mode-alist$\\|-map$\\|-map-alist$" + (symbol-name sym)) + (not (get sym 'safe-local-variable))))) + (defcustom safe-local-eval-forms nil "*Expressions that are considered \"safe\" in an `eval:' local variable. Add expressions to this list if you want Emacs to evaluate them, when @@ -2122,15 +2132,9 @@ is considered risky." ((eq var 'coding) ;; We have already handled coding: tag in set-auto-coding. nil) - ((memq var ignored-local-variables) - nil) ;; "Setting" eval means either eval it or do nothing. ;; Likewise for setting hook variables. - ((or (get var 'risky-local-variable) - (and - (string-match "-hooks?$\\|-functions?$\\|-forms?$\\|-program$\\|-command$\\|-predicate$\\|font-lock-keywords$\\|font-lock-keywords-[0-9]+$\\|font-lock-syntactic-keywords$\\|-frame-alist$\\|-mode-alist$\\|-map$\\|-map-alist$" - (symbol-name var)) - (not (get var 'safe-local-variable)))) + ((risky-local-variable-p var) ;; Permit evalling a put of a harmless property. ;; if the args do nothing tricky. (if (or (and (eq var 'eval) diff --git a/lisp/ses.el b/lisp/ses.el new file mode 100644 index 0000000000..097ec7e6c1 --- /dev/null +++ b/lisp/ses.el @@ -0,0 +1,2914 @@ +;;;; ses.el -- Simple Emacs Spreadsheet + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Jonathan Yavner <[email protected]> +;; Maintainer: Jonathan Yavner <[email protected]> +;; Keywords: spreadsheet + +;; 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. + +;;; To-do list: +;; * Do something about control characters & octal codes in cell print +;; areas. Currently they distort the columnar appearance, but fixing them +;; seems like too much work? Use text-char-description? +;; * Input validation functions. How specified? +;; * Menubar and popup menus. +;; * Faces (colors & styles) in print cells. +;; * Move a column by dragging its letter in the header line. +;; * Left-margin column for row number. +;; * Move a row by dragging its number in the left-margin. + +(require 'unsafep) + + +;;;---------------------------------------------------------------------------- +;;;; User-customizable variables +;;;---------------------------------------------------------------------------- + +(defgroup ses nil + "Simple Emacs Spreadsheet" + :group 'applications + :prefix "ses-" + :version "21.1") + +(defcustom ses-initial-size '(1 . 1) + "Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)." + :group 'ses + :type '(cons (integer :tag "numrows") (integer :tag "numcols"))) + +(defcustom ses-initial-column-width 7 + "Initial width of columns in a new spreadsheet." + :group 'ses + :type '(integer :match (lambda (widget value) (> value 0)))) + +(defcustom ses-initial-default-printer "%.7g" + "Initial default printer for a new spreadsheet." + :group 'ses + :type '(choice string + (list :tag "Parenthesized string" string) + function)) + +(defcustom ses-after-entry-functions '(forward-char) + "Things to do after entering a value into a cell. An abnormal hook that +usually runs a cursor-movement function. Each function is called with ARG=1." + :group 'ses + :type 'hook + :options '(forward-char backward-char next-line previous-line)) + +(defcustom ses-mode-hook nil + "Hook functions to be run upon entering SES mode." + :group 'ses + :type 'hook) + + +;;;---------------------------------------------------------------------------- +;;;; Global variables and constants +;;;---------------------------------------------------------------------------- + +(defvar ses-read-cell-history nil + "List of formulas that have been typed in.") + +(defvar ses-read-printer-history nil + "List of printer functions that have been typed in.") + +(defvar ses-mode-map nil + "Local keymap for Simple Emacs Spreadsheet.") + +(defvar ses-mode-print-map nil + "Local keymap for SES print area.") + +(defvar ses-mode-edit-map nil + "Local keymap for SES minibuffer cell-editing.") + +;Key map used for 'x' key. +(defalias 'ses-export-keymap + (let ((map (make-sparse-keymap "SES export"))) + (define-key map "T" (cons " tab-formulas" 'ses-export-tsf)) + (define-key map "t" (cons " tab-values" 'ses-export-tsv)) + map)) + +(defconst ses-print-data-boundary "\n\014\n" + "Marker string denoting the boundary between print area and data area") + +(defconst ses-initial-global-parameters + "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n" + "Initial contents for the three-element list at the bottom of the data area") + +(defconst ses-initial-file-trailer + ";;; Local Variables:\n;;; mode: ses\n;;; End:\n" + "Initial contents for the file-trailer area at the bottom of the file.") + +(defconst ses-initial-file-contents + (concat " \n" ;One blank cell in print area + ses-print-data-boundary + "(ses-cell A1 nil nil nil nil)\n" ;One blank cell in data area + "\n" ;End-of-row terminator for the one row in data area + "(ses-column-widths [7])\n" + "(ses-column-printers [nil])\n" + "(ses-default-printer \"%.7g\")\n" + "(ses-header-row 0)\n" + ses-initial-global-parameters + ses-initial-file-trailer) + "The initial contents of an empty spreadsheet.") + +(defconst ses-cell-size 4 + "A cell consists of a SYMBOL, a FORMULA, a PRINTER-function, and a list of +REFERENCES.") + +(defconst ses-paramlines-plist + '(column-widths 2 col-printers 3 default-printer 4 header-row 5 + file-format 8 numrows 9 numcols 10) + "Offsets from last cell line to various parameter lines in the data area +of a spreadsheet.") + +(defconst ses-box-prop '(:box (:line-width 2 :style released-button)) + "Display properties to create a raised box for cells in the header line.") + +(defconst ses-standard-printer-functions + '(ses-center ses-center-span ses-dashfill ses-dashfill-span + ses-tildefill-span) + "List of print functions to be included in initial history of printer +functions. None of these standard-printer functions is suitable for use as a +column printer or a global-default printer because they invoke the column or +default printer and then modify its output.") + +(eval-and-compile + (defconst ses-localvars + '(blank-line cells col-printers column-widths curcell curcell-overlay + default-printer deferred-narrow deferred-recalc deferred-write + file-format header-hscroll header-row header-string linewidth + mode-line-process next-line-add-newlines numcols numrows + symbolic-formulas transient-mark-mode) + "Buffer-local variables used by SES.")) + +;;When compiling, create all the buffer locals and give them values +(eval-when-compile + (dolist (x ses-localvars) + (make-local-variable x) + (set x nil))) + + +;;; +;;; "Side-effect variables". They are set in one function, altered in +;;; another as a side effect, then read back by the first, as a way of +;;; passing back more than one value. These declarations are just to make +;;; the compiler happy, and to conform to standard Emacs-Lisp practice (I +;;; think the make-local-variable trick above is cleaner). +;;; + +(defvar ses-relocate-return nil + "Set by `ses-relocate-formula' and `ses-relocate-range', read by +`ses-relocate-all'. Set to 'delete if a cell-reference was deleted from a +formula--so the formula needs recalculation. Set to 'range if the size of a +`ses-range' was changed--so both the formula's value and list of dependents +need to be recalculated.") + +(defvar ses-call-printer-return nil + "Set to t if last cell printer invoked by `ses-call-printer' requested +left-justification of the result. Set to error-signal if ses-call-printer +encountered an error during printing. Nil otherwise.") + +(defvar ses-start-time nil + "Time when current operation started. Used by `ses-time-check' to decide +when to emit a progress message.") + + +;;;---------------------------------------------------------------------------- +;;;; Macros +;;;---------------------------------------------------------------------------- + +(defmacro ses-get-cell (row col) + "Return the cell structure that stores information about cell (ROW,COL)." + `(aref (aref cells ,row) ,col)) + +(defmacro ses-cell-symbol (row &optional col) + "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value. (0,0) => A1." + `(aref ,(if col `(ses-get-cell ,row ,col) row) 0)) + +(defmacro ses-cell-formula (row &optional col) + "From a CELL or a pair (ROW,COL), get the function that computes its value." + `(aref ,(if col `(ses-get-cell ,row ,col) row) 1)) + +(defmacro ses-cell-printer (row &optional col) + "From a CELL or a pair (ROW,COL), get the function that prints its value." + `(aref ,(if col `(ses-get-cell ,row ,col) row) 2)) + +(defmacro ses-cell-references (row &optional col) + "From a CELL or a pair (ROW,COL), get the list of symbols for cells whose +functions refer to its value." + `(aref ,(if col `(ses-get-cell ,row ,col) row) 3)) + +(defmacro ses-cell-value (row &optional col) + "From a CELL or a pair (ROW,COL), get the current value for that cell." + `(symbol-value (ses-cell-symbol ,row ,col))) + +(defmacro ses-col-width (col) + "Return the width for column COL." + `(aref column-widths ,col)) + +(defmacro ses-col-printer (col) + "Return the default printer for column COL." + `(aref col-printers ,col)) + +(defmacro ses-sym-rowcol (sym) + "From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0). Result +is nil if SYM is not a symbol that names a cell." + `(and (symbolp ,sym) (get ,sym 'ses-cell))) + +(defmacro ses-cell (sym value formula printer references) + "Load a cell SYM from the spreadsheet file. Does not recompute VALUE from +FORMULA, does not reprint using PRINTER, does not check REFERENCES. This is a +macro to prevent propagate-on-load viruses. Safety-checking for FORMULA and +PRINTER are deferred until first use." + (let ((rowcol (ses-sym-rowcol sym))) + (ses-formula-record formula) + (ses-printer-record printer) + (or (atom formula) + (eq safe-functions t) + (setq formula `(ses-safe-formula ,formula))) + (or (not printer) + (stringp printer) + (eq safe-functions t) + (setq printer `(ses-safe-printer ,printer))) + (aset (aref cells (car rowcol)) + (cdr rowcol) + (vector sym formula printer references))) + (set sym value) + sym) + +(defmacro ses-column-widths (widths) + "Load the vector of column widths from the spreadsheet file. This is a +macro to prevent propagate-on-load viruses." + (or (and (vectorp widths) (= (length widths) numcols)) + (error "Bad column-width vector")) + ;;To save time later, we also calculate the total width of each line in the + ;;print area (excluding the terminating newline) + (setq column-widths widths + linewidth (apply '+ -1 (mapcar '1+ widths)) + blank-line (concat (make-string linewidth ? ) "\n")) + t) + +(defmacro ses-column-printers (printers) + "Load the vector of column printers from the spreadsheet file and checks +them for safety. This is a macro to prevent propagate-on-load viruses." + (or (and (vectorp printers) (= (length printers) numcols)) + (error "Bad column-printers vector")) + (dotimes (x numcols) + (aset printers x (ses-safe-printer (aref printers x)))) + (setq col-printers printers) + (mapc 'ses-printer-record printers) + t) + +(defmacro ses-default-printer (def) + "Load the global default printer from the spreadsheet file and checks it +for safety. This is a macro to prevent propagate-on-load viruses." + (setq default-printer (ses-safe-printer def)) + (ses-printer-record def) + t) + +(defmacro ses-header-row (row) + "Load the header row from the spreadsheet file and checks it +for safety. This is a macro to prevent propagate-on-load viruses." + (or (and (wholenump row) (< row numrows)) + (error "Bad header-row")) + (setq header-row row) + t) + +(defmacro ses-dotimes-msg (spec msg &rest body) + "(ses-dotimes-msg (VAR LIMIT) MSG BODY...): Like `dotimes', but +a message is emitted using MSG every second or so during the loop." + (let ((msgvar (make-symbol "msg")) + (limitvar (make-symbol "limit")) + (var (car spec)) + (limit (cadr spec))) + `(let ((,limitvar ,limit) + (,msgvar ,msg)) + (setq ses-start-time (float-time)) + (message ,msgvar) + (setq ,msgvar (concat ,msgvar " (%d%%)")) + (dotimes (,var ,limitvar) + (ses-time-check ,msgvar '(/ (* ,var 100) ,limitvar)) + ,@body) + (message nil)))) + +(put 'ses-dotimes-msg 'lisp-indent-function 2) +(def-edebug-spec ses-dotimes-msg ((symbolp form) form body)) + +(defmacro ses-dorange (curcell &rest body) + "Execute BODY repeatedly, with the variables `row' and `col' set to each +cell in the range specified by CURCELL. The range is available in the +variables `minrow', `maxrow', `mincol', and `maxcol'." + (let ((cur (make-symbol "cur")) + (min (make-symbol "min")) + (max (make-symbol "max")) + (r (make-symbol "r")) + (c (make-symbol "c"))) + `(let* ((,cur ,curcell) + (,min (ses-sym-rowcol (if (consp ,cur) (car ,cur) ,cur))) + (,max (ses-sym-rowcol (if (consp ,cur) (cdr ,cur) ,cur)))) + (let ((minrow (car ,min)) + (maxrow (car ,max)) + (mincol (cdr ,min)) + (maxcol (cdr ,max)) + row col) + (if (or (> minrow maxrow) (> mincol maxcol)) + (error "Empty range")) + (dotimes (,r (- maxrow minrow -1)) + (setq row (+ ,r minrow)) + (dotimes (,c (- maxcol mincol -1)) + (setq col (+ ,c mincol)) + ,@body)))))) + +(put 'ses-dorange 'lisp-indent-function 'defun) +(def-edebug-spec ses-dorange (form body)) + +;;Support for coverage testing. +(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) + + +;;;---------------------------------------------------------------------------- +;;;; Utility functions +;;;---------------------------------------------------------------------------- + +(defun ses-vector-insert (array idx new) + "Create a new vector which is one larger than ARRAY and has NEW inserted +before element IDX." + (let* ((len (length array)) + (result (make-vector (1+ len) new))) + (dotimes (x len) + (aset result + (if (< x idx) x (1+ x)) + (aref array x))) + result)) + +;;Allow ARRAY to be a symbol for use in buffer-undo-list +(defun ses-vector-delete (array idx count) + "Create a new vector which is a copy of ARRAY with COUNT objects removed +starting at element IDX. ARRAY is either a vector or a symbol whose value +is a vector--if a symbol, the new vector is assigned as the symbol's value." + (let* ((a (if (arrayp array) array (symbol-value array))) + (len (- (length a) count)) + (result (make-vector len nil))) + (dotimes (x len) + (aset result x (aref a (if (< x idx) x (+ x count))))) + (if (symbolp array) + (set array result)) + result)) + +(defun ses-delete-line (count) + "Like `kill-line', but no kill ring." + (let ((pos (point))) + (forward-line count) + (delete-region pos (point)))) + +(defun ses-printer-validate (printer) + "Signals an error if PRINTER is not a valid SES cell printer." + (or (not printer) + (stringp printer) + (functionp printer) + (and (stringp (car-safe printer)) (not (cdr printer))) + (error "Invalid printer function")) + printer) + +(defun ses-printer-record (printer) + "Add PRINTER to `ses-read-printer-history' if not already there, after first +checking that it is a valid printer function." + (ses-printer-validate printer) + ;;To speed things up, we avoid calling prin1 for the very common "nil" case. + (if printer + (add-to-list 'ses-read-printer-history (prin1-to-string printer)))) + +(defun ses-formula-record (formula) + "If FORMULA is of the form 'symbol, adds it to the list of symbolic formulas +for this spreadsheet." + (when (and (eq (car-safe formula) 'quote) + (symbolp (cadr formula))) + (add-to-list 'symbolic-formulas + (list (symbol-name (cadr formula)))))) + +(defun ses-column-letter (col) + "Converts a column number to A..Z or AA..ZZ" + (if (< col 26) + (char-to-string (+ ?A col)) + (string (+ ?@ (/ col 26)) (+ ?A (% col 26))))) + +(defun ses-create-cell-symbol (row col) + "Produce a symbol that names the cell (ROW,COL). (0,0) => 'A1." + (intern (concat (ses-column-letter col) (number-to-string (1+ row))))) + +(defun ses-create-cell-variable-range (minrow maxrow mincol maxcol) + "Create buffer-local variables for cells. This is undoable." + (push `(ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) + buffer-undo-list) + (let (sym xrow xcol) + (dotimes (row (1+ (- maxrow minrow))) + (dotimes (col (1+ (- maxcol mincol))) + (setq xrow (+ row minrow) + xcol (+ col mincol) + sym (ses-create-cell-symbol xrow xcol)) + (put sym 'ses-cell (cons xrow xcol)) + (make-local-variable sym))))) + +;;;We do not delete the ses-cell properties for the cell-variables, in case a +;;;formula that refers to this cell is in the kill-ring and is later pasted +;;;back in. +(defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol) + "Destroy buffer-local variables for cells. This is undoable." + (let (sym) + (dotimes (row (1+ (- maxrow minrow))) + (dotimes (col (1+ (- maxcol mincol))) + (setq sym (ses-create-cell-symbol (+ row minrow) (+ col mincol))) + (if (boundp sym) + (push `(ses-set-with-undo ,sym ,(symbol-value sym)) + buffer-undo-list)) + (kill-local-variable sym)))) + (push `(ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) + buffer-undo-list)) + +(defun ses-reset-header-string () + "Flags the header string for update. Upon undo, the header string will be +updated again." + (push '(ses-reset-header-string) buffer-undo-list) + (setq header-hscroll -1)) + +;;Split this code off into a function to avoid coverage-testing difficulties +(defun ses-time-check (format arg) + "If `ses-start-time' is more than a second ago, call `message' with FORMAT +and (eval ARG) and reset `ses-start-time' to the current time." + (when (> (- (float-time) ses-start-time) 1.0) + (message format (eval arg)) + (setq ses-start-time (float-time))) + nil) + + +;;;---------------------------------------------------------------------------- +;;;; The cells +;;;---------------------------------------------------------------------------- + +(defun ses-set-cell (row col field val) + "Install VAL as the contents for field FIELD (named by a quoted symbol) of +cell (ROW,COL). This is undoable. The cell's data will be updated through +`post-command-hook'." + (let ((cell (ses-get-cell row col)) + (elt (plist-get '(value t symbol 0 formula 1 printer 2 references 3) + field)) + change) + (or elt (signal 'args-out-of-range nil)) + (setq change (if (eq elt t) + (ses-set-with-undo (ses-cell-symbol cell) val) + (ses-aset-with-undo cell elt val))) + (if change + (add-to-list 'deferred-write (cons row col)))) + nil) ;Make coverage-tester happy + +(defun ses-cell-set-formula (row col formula) + "Store a new formula for (ROW . COL) and enqueues the cell for +recalculation via `post-command-hook'. Updates the reference lists for the +cells that this cell refers to. Does not update cell value or reprint the +cell. To avoid inconsistencies, this function is not interruptible, which +means Emacs will crash if FORMULA contains a circular list." + (let* ((cell (ses-get-cell row col)) + (old (ses-cell-formula cell))) + (let ((sym (ses-cell-symbol cell)) + (oldref (ses-formula-references old)) + (newref (ses-formula-references formula)) + (inhibit-quit t) + x xrow xcol) + (add-to-list 'deferred-recalc sym) + ;;Delete old references from this cell. Skip the ones that are also + ;;in the new list. + (dolist (ref oldref) + (unless (memq ref newref) + (setq x (ses-sym-rowcol ref) + xrow (car x) + xcol (cdr x)) + (ses-set-cell xrow xcol 'references + (delq sym (ses-cell-references xrow xcol))))) + ;;Add new ones. Skip ones left over from old list + (dolist (ref newref) + (setq x (ses-sym-rowcol ref) + xrow (car x) + xcol (cdr x) + x (ses-cell-references xrow xcol)) + (or (memq sym x) + (ses-set-cell xrow xcol 'references (cons sym x)))) + (ses-formula-record formula) + (ses-set-cell row col 'formula formula)))) + +(defun ses-calculate-cell (row col force) + "Calculate and print the value for cell (ROW,COL) using the cell's formula +function and print functions, if any. Result is nil for normal operation, or +the error signal if the formula or print function failed. The old value is +left unchanged if it was *skip* and the new value is nil. + Any cells that depend on this cell are queued for update after the end of +processing for the current keystroke, unless the new value is the same as +the old and FORCE is nil." + (let ((cell (ses-get-cell row col)) + formula-error printer-error) + (let ((symbol (ses-cell-symbol cell)) + (oldval (ses-cell-value cell)) + (formula (ses-cell-formula cell)) + newval) + (if (eq (car-safe formula) 'ses-safe-formula) + (ses-set-cell row col 'formula (ses-safe-formula (cadr formula)))) + (condition-case sig + (setq newval (eval formula)) + (error + (setq formula-error sig + newval '*error*))) + (if (and (not newval) (eq oldval '*skip*)) + ;;Don't lose the *skip* - previous field spans this one + (setq newval '*skip*)) + (when (or force (not (eq newval oldval))) + (add-to-list 'deferred-write (cons row col)) ;In case force=t + (ses-set-cell row col 'value newval) + (dolist (ref (ses-cell-references cell)) + (add-to-list 'deferred-recalc ref)))) + (setq printer-error (ses-print-cell row col)) + (or formula-error printer-error))) + +(defun ses-clear-cell (row col) + "Delete formula and printer for cell (ROW,COL)." + (ses-set-cell row col 'printer nil) + (ses-cell-set-formula row col nil)) + +(defun ses-update-cells (list &optional force) + "Recalculate cells in LIST, checking for dependency loops. Prints +progress messages every second. Dependent cells are not recalculated +if the cell's value is unchanged if FORCE is nil." + (let ((deferred-recalc list) + (nextlist list) + (pos (point)) + curlist prevlist rowcol formula) + (with-temp-message " " + (while (and deferred-recalc (not (equal nextlist prevlist))) + ;;In each loop, recalculate cells that refer only to other cells that + ;;have already been recalculated or aren't in the recalculation + ;;region. Repeat until all cells have been processed or until the + ;;set of cells being worked on stops changing. + (if prevlist + (message "Recalculating... (%d cells left)" + (length deferred-recalc))) + (setq curlist deferred-recalc + deferred-recalc nil + prevlist nextlist) + (while curlist + (setq rowcol (ses-sym-rowcol (car curlist)) + formula (ses-cell-formula (car rowcol) (cdr rowcol))) + (or (catch 'ref + (dolist (ref (ses-formula-references formula)) + (when (or (memq ref curlist) + (memq ref deferred-recalc)) + ;;This cell refers to another that isn't done yet + (add-to-list 'deferred-recalc (car curlist)) + (throw 'ref t)))) + ;;ses-update-cells is called from post-command-hook, so + ;;inhibit-quit is implicitly bound to t. + (when quit-flag + ;;Abort the recalculation. User will probably undo now. + (error "Quit")) + (ses-calculate-cell (car rowcol) (cdr rowcol) force)) + (setq curlist (cdr curlist))) + (dolist (ref deferred-recalc) + (add-to-list 'nextlist ref)) + (setq nextlist (sort (copy-sequence nextlist) 'string<)) + (if (equal nextlist prevlist) + ;;We'll go around the loop one more time. + (add-to-list 'nextlist t))) + (when deferred-recalc + ;;Just couldn't finish these + (dolist (x deferred-recalc) + (let ((rowcol (ses-sym-rowcol x))) + (ses-set-cell (car rowcol) (cdr rowcol) 'value '*error*) + (1value (ses-print-cell (car rowcol) (cdr rowcol))))) + (error "Circular references: %s" deferred-recalc)) + (message " ")) + ;;Can't use save-excursion here: if the cell under point is + ;;updated, save-excusion's marker will move past the cell. + (goto-char pos))) + + +;;;---------------------------------------------------------------------------- +;;;; The print area +;;;---------------------------------------------------------------------------- + +;;;We turn off point-motion-hooks and explicitly position the cursor, in case +;;;the intangible properties have gotten screwed up (e.g., when +;;;ses-goto-print is called during a recursive ses-print-cell). +(defun ses-goto-print (row col) + "Move point to print area for cell (ROW,COL)." + (let ((inhibit-point-motion-hooks t)) + (goto-char 1) + (forward-line row) + (dotimes (c col) + (forward-char (1+ (ses-col-width c)))))) + +(defun ses-set-curcell () + "Sets `curcell' to the current cell symbol, or a cons (BEG,END) for a +region, or nil if cursor is not at a cell." + (if (or (not mark-active) + deactivate-mark + (= (region-beginning) (region-end))) + ;;Single cell + (setq curcell (get-text-property (point) 'intangible)) + ;;Range + (let ((bcell (get-text-property (region-beginning) 'intangible)) + (ecell (get-text-property (1- (region-end)) 'intangible))) + (setq curcell (if (and bcell ecell) + (cons bcell ecell) + nil)))) + nil) + +(defun ses-check-curcell (&rest args) + "Signal an error if curcell is inappropriate. The end marker is +appropriate if some argument is 'end. A range is appropriate if some +argument is 'range. A single cell is appropriate unless some argument is +'needrange." + (if (eq curcell t) + ;;curcell recalculation was postponed, but user typed ahead + (ses-set-curcell)) + (cond + ((not curcell) + (or (memq 'end args) + (error "Not at cell"))) + ((consp curcell) + (or (memq 'range args) + (memq 'needrange args) + (error "Can't use a range"))) + ((memq 'needrange args) + (error "Need a range")))) + +(defun ses-print-cell (row col) + "Format and print the value of cell (ROW,COL) to the print area, using the +cell's printer function. If the cell's new print form is too wide, it will +spill over into the following cell, but will not run off the end of the row +or overwrite the next non-nil field. Result is nil for normal operation, or +the error signal if the printer function failed and the cell was formatted +with \"%s\". If the cell's value is *skip*, nothing is printed because the +preceding cell has spilled over." + (catch 'ses-print-cell + (let* ((cell (ses-get-cell row col)) + (value (ses-cell-value cell)) + (printer (ses-cell-printer cell)) + (maxcol (1+ col)) + text sig startpos x) + ;;Create the string to print + (cond + ((eq value '*skip*) + ;;Don't print anything + (throw 'ses-print-cell nil)) + ((eq value '*error*) + (setq text (make-string (ses-col-width col) ?#))) + (t + ;;Deferred safety-check on printer + (if (eq (car-safe printer) 'ses-safe-printer) + (ses-set-cell row col 'printer + (setq printer (ses-safe-printer (cadr printer))))) + ;;Print the value + (setq text (ses-call-printer (or printer + (ses-col-printer col) + default-printer) + value)) + (if (consp ses-call-printer-return) + ;;Printer returned an error + (setq sig ses-call-printer-return)))) + ;;Adjust print width to match column width + (let ((width (ses-col-width col)) + (len (length text))) + (cond + ((< len width) + ;;Fill field to length with spaces + (setq len (make-string (- width len) ? ) + text (if (eq ses-call-printer-return t) + (concat text len) + (concat len text)))) + ((> len width) + ;;Spill over into following cells, if possible + (let ((maxwidth width)) + (while (and (> len maxwidth) + (< maxcol numcols) + (or (not (setq x (ses-cell-value row maxcol))) + (eq x '*skip*))) + (unless x + ;;Set this cell to '*skip* so it won't overwrite our spillover + (ses-set-cell row maxcol 'value '*skip*)) + (setq maxwidth (+ maxwidth (ses-col-width maxcol) 1) + maxcol (1+ maxcol))) + (if (<= len maxwidth) + ;;Fill to complete width of all the fields spanned + (setq text (concat text (make-string (- maxwidth len) ? ))) + ;;Not enough room to end of line or next non-nil field. Truncate + ;;if string; otherwise fill with error indicator + (setq sig `(error "Too wide" ,text)) + (if (stringp value) + (setq text (substring text 0 maxwidth)) + (setq text (make-string maxwidth ?#)))))))) + ;;Substitute question marks for tabs and newlines. Newlines are + ;;used as row-separators; tabs could confuse the reimport logic. + (setq text (replace-regexp-in-string "[\t\n]" "?" text)) + (ses-goto-print row col) + (setq startpos (point)) + ;;Install the printed result. This is not interruptible. + (let ((inhibit-read-only t) + (inhibit-quit t)) + (delete-char (1+ (length text))) + ;;We use concat instead of inserting separate strings in order to + ;;reduce the number of cells in the undo list. + (setq x (concat text (if (< maxcol numcols) " " "\n"))) + ;;We use set-text-properties to prevent a wacky print function + ;;from inserting rogue properties, and to ensure that the keymap + ;;property is inherited (is it a bug that only unpropertied strings + ;;actually inherit from surrounding text?) + (set-text-properties 0 (length x) nil x) + (insert-and-inherit x) + (put-text-property startpos (point) 'intangible + (ses-cell-symbol cell)) + (when (and (zerop row) (zerop col)) + ;;Reconstruct special beginning-of-buffer attributes + (put-text-property 1 (point) 'keymap 'ses-mode-print-map) + (put-text-property 1 (point) 'read-only 'ses) + (put-text-property 1 2 'front-sticky t))) + (if (= row (1- header-row)) + ;;This line is part of the header - force recalc + (ses-reset-header-string)) + ;;If this cell (or a preceding one on the line) previously spilled over + ;;and has gotten shorter, redraw following cells on line recursively. + (when (and (< maxcol numcols) (eq (ses-cell-value row maxcol) '*skip*)) + (ses-set-cell row maxcol 'value nil) + (ses-print-cell row maxcol)) + ;;Return to start of cell + (goto-char startpos) + sig))) + +(defun ses-call-printer (printer &optional value) + "Invokes PRINTER (a string or parenthesized string or function-symbol or +lambda of one argument) on VALUE. Result is the the printed cell as a +string. The variable `ses-call-printer-return' is set to t if the printer +used parenthesis to request left-justification, or the error-signal if the +printer signalled one (and \"%s\" is used as the default printer), else nil." + (setq ses-call-printer-return nil) + (unless value + (setq value "")) + (condition-case signal + (cond + ((stringp printer) + (format printer value)) + ((stringp (car-safe printer)) + (setq ses-call-printer-return t) + (format (car printer) value)) + (t + (setq value (funcall printer value)) + (if (stringp value) + value + (or (stringp (car-safe value)) + (error "Printer should return \"string\" or (\"string\")")) + (setq ses-call-printer-return t) + (car value)))) + (error + (setq ses-call-printer-return signal) + (prin1-to-string value t)))) + +(defun ses-adjust-print-width (col change) + "Insert CHANGE spaces in front of column COL, or at end of line if +COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind +inhibit-quit to t." + (let ((inhibit-read-only t) + (blank (if (> change 0) (make-string change ? ))) + (at-end (= col numcols))) + (ses-set-with-undo 'linewidth (+ linewidth change)) + ;;ses-set-with-undo always returns t for strings. + (1value (ses-set-with-undo 'blank-line + (concat (make-string linewidth ? ) "\n"))) + (dotimes (row numrows) + (ses-goto-print row col) + (when at-end + ;;Insert new columns before newline + (let ((inhibit-point-motion-hooks t)) + (backward-char 1))) + (if blank + (insert blank) + (delete-char (- change)))))) + +(defun ses-print-cell-new-width (row col) + "Same as ses-print-cell, except if the cell's value is *skip*, the preceding +nonskipped cell is reprinted. This function is used when the width of +cell (ROW,COL) has changed." + (if (not (eq (ses-cell-value row col) '*skip*)) + (ses-print-cell row col) + ;;Cell was skipped over - reprint previous + (ses-goto-print row col) + (backward-char 1) + (let ((rowcol (ses-sym-rowcol (get-text-property (point) 'intangible)))) + (ses-print-cell (car rowcol) (cdr rowcol))))) + + +;;;---------------------------------------------------------------------------- +;;;; The data area +;;;---------------------------------------------------------------------------- + +(defun ses-goto-data (def &optional col) + "Move point to data area for (DEF,COL). If DEF is a row number, COL is the +column number for a data cell -- otherwise DEF is one of the symbols +column-widths, col-printers, default-printer, numrows, or numcols." + (if (< (point-max) (buffer-size)) + (setq deferred-narrow t)) + (widen) + (let ((inhibit-point-motion-hooks t)) ;In case intangible attrs are wrong + (goto-char 1) + (if col + ;;It's a cell + (forward-line (+ numrows 2 (* def (1+ numcols)) col)) + ;;Convert def-symbol to offset + (setq def (plist-get ses-paramlines-plist def)) + (or def (signal 'args-out-of-range nil)) + (forward-line (+ (* numrows (+ numcols 2)) def))))) + +(defun ses-set-parameter (def value &optional elem) + "Sets parameter DEF to VALUE (with undo) and writes the value to the data +area. See `ses-goto-data' for meaning of DEF. Newlines in the data +are escaped. If ELEM is specified, it is the array subscript within DEF to +be set to VALUE." + (save-excursion + ;;We call ses-goto-data early, using the old values of numrows and + ;;numcols in case one of them is being changed. + (ses-goto-data def) + (if elem + (ses-aset-with-undo (symbol-value def) elem value) + (ses-set-with-undo def value)) + (let ((inhibit-read-only t) + (fmt (plist-get '(column-widths "(ses-column-widths %S)" + col-printers "(ses-column-printers %S)" + default-printer "(ses-default-printer %S)" + header-row "(ses-header-row %S)" + file-format " %S ;SES file-format" + numrows " %S ;numrows" + numcols " %S ;numcols") + def))) + (delete-region (point) (line-end-position)) + (insert (format fmt (symbol-value def)))))) + +(defun ses-write-cells () + "`deferred-write' is a list of (ROW,COL) for cells to be written from +buffer-local variables to data area. Newlines in the data are escaped." + (let* ((inhibit-read-only t) + (print-escape-newlines t) + rowcol row col cell sym formula printer text) + (setq ses-start-time (float-time)) + (with-temp-message " " + (save-excursion + (while deferred-write + (ses-time-check "Writing... (%d cells left)" + '(length deferred-write)) + (setq rowcol (pop deferred-write) + row (car rowcol) + col (cdr rowcol) + cell (ses-get-cell row col) + sym (ses-cell-symbol cell) + formula (ses-cell-formula cell) + printer (ses-cell-printer cell)) + (if (eq (car-safe formula) 'ses-safe-formula) + (setq formula (cadr formula))) + (if (eq (car-safe printer) 'ses-safe-printer) + (setq printer (cadr printer))) + ;;This is noticably faster than (format "%S %S %S %S %S") + (setq text (concat "(ses-cell " + (symbol-name sym) + " " + (prin1-to-string (symbol-value sym)) + " " + (prin1-to-string formula) + " " + (prin1-to-string printer) + " " + (if (atom (ses-cell-references cell)) + "nil" + (concat "(" + (mapconcat 'symbol-name + (ses-cell-references cell) + " ") + ")")) + ")")) + (ses-goto-data row col) + (delete-region (point) (line-end-position)) + (insert text))) + (message " ")))) + + +;;;---------------------------------------------------------------------------- +;;;; Formula relocation +;;;---------------------------------------------------------------------------- + +(defun ses-formula-references (formula &optional result-so-far) + "Produce a list of symbols for cells that this formula's value +refers to. For recursive calls, RESULT-SO-FAR is the list being constructed, +or t to get a wrong-type-argument error when the first reference is found." + (if (atom formula) + (if (ses-sym-rowcol formula) + ;;Entire formula is one symbol + (add-to-list 'result-so-far formula) + ) ;;Ignore other atoms + (dolist (cur formula) + (cond + ((ses-sym-rowcol cur) + ;;Save this reference + (add-to-list 'result-so-far cur)) + ((eq (car-safe cur) 'ses-range) + ;;All symbols in range are referenced + (dolist (x (cdr (macroexpand cur))) + (add-to-list 'result-so-far x))) + ((and (consp cur) (not (eq (car cur) 'quote))) + ;;Recursive call for subformulas + (setq result-so-far (ses-formula-references cur result-so-far))) + (t + ;;Ignore other stuff + )))) + result-so-far) + +(defun ses-relocate-formula (formula startrow startcol rowincr colincr) + "Produce a copy of FORMULA where all symbols that refer to cells in row +STARTROW or above and col STARTCOL or above are altered by adding ROWINCR +and COLINCR. STARTROW and STARTCOL are 0-based. Example: + (ses-relocate-formula '(+ A1 B2 D3) 1 2 1 -1) + => (+ A1 B2 C4) +If ROWINCR or COLINCR is negative, references to cells being deleted are +removed. Example: + (ses-relocate-formula '(+ A1 B2 D3) 0 1 0 -1) + => (+ A1 C3) +Sets `ses-relocate-return' to 'delete if cell-references were removed." + (let (rowcol result) + (if (or (atom formula) (eq (car formula) 'quote)) + (if (setq rowcol (ses-sym-rowcol formula)) + (ses-relocate-symbol formula rowcol + startrow startcol rowincr colincr) + formula) ;Pass through as-is + (dolist (cur formula) + (setq rowcol (ses-sym-rowcol cur)) + (cond + (rowcol + (setq cur (ses-relocate-symbol cur rowcol + startrow startcol rowincr colincr)) + (if cur + (push cur result) + ;;Reference to a deleted cell. Set a flag in ses-relocate-return. + ;;don't change the flag if it's already 'range, since range + ;;implies 'delete. + (unless ses-relocate-return + (setq ses-relocate-return 'delete)))) + ((eq (car-safe cur) 'ses-range) + (setq cur (ses-relocate-range cur startrow startcol rowincr colincr)) + (if cur + (push cur result))) + ((or (atom cur) (eq (car cur) 'quote)) + ;;Constants pass through unchanged + (push cur result)) + (t + ;;Recursively copy and alter subformulas + (push (ses-relocate-formula cur startrow startcol + rowincr colincr) + result)))) + (nreverse result)))) + +(defun ses-relocate-symbol (sym rowcol startrow startcol rowincr colincr) + "Relocate one symbol SYM, whichs corresponds to ROWCOL (a cons of ROW and +COL). Cells starting at (STARTROW,STARTCOL) are being shifted +by (ROWINCR,COLINCR)." + (let ((row (car rowcol)) + (col (cdr rowcol))) + (if (or (< row startrow) (< col startcol)) + sym + (setq row (+ row rowincr) + col (+ col colincr)) + (if (and (>= row startrow) (>= col startcol) + (< row numrows) (< col numcols)) + ;;Relocate this variable + (ses-create-cell-symbol row col) + ;;Delete reference to a deleted cell + nil)))) + +(defun ses-relocate-range (range startrow startcol rowincr colincr) + "Relocate one RANGE, of the form '(ses-range min max). Cells starting +at (STARTROW,STARTCOL) are being shifted by (ROWINCR,COLINCR). Result is the +new range, or nil if the entire range is deleted. If new rows are being added +just beyond the end of a row range, or new columns just beyond a column range, +the new rows/columns will be added to the range. Sets `ses-relocate-return' +if the range was altered." + (let* ((minorig (cadr range)) + (minrowcol (ses-sym-rowcol minorig)) + (min (ses-relocate-symbol minorig minrowcol + startrow startcol + rowincr colincr)) + (maxorig (nth 2 range)) + (maxrowcol (ses-sym-rowcol maxorig)) + (max (ses-relocate-symbol maxorig maxrowcol + startrow startcol + rowincr colincr)) + field) + (cond + ((and (not min) (not max)) + (setq range nil)) ;;The entire range is deleted + ((zerop colincr) + ;;Inserting or deleting rows + (setq field 'car) + (if (not min) + ;;Chopped off beginning of range + (setq min (ses-create-cell-symbol startrow (cdr minrowcol)) + ses-relocate-return 'range)) + (if (not max) + (if (> rowincr 0) + ;;Trying to insert a nonexistent row + (setq max (ses-create-cell-symbol (1- numrows) (cdr minrowcol))) + ;;End of range is being deleted + (setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol)) + ses-relocate-return 'range)) + (and (> rowincr 0) + (= (car maxrowcol) (1- startrow)) + (= (cdr minrowcol) (cdr maxrowcol)) + ;;Insert after ending row of vertical range - include it + (setq max (ses-create-cell-symbol (+ startrow rowincr -1) + (cdr maxrowcol)))))) + (t + ;;Inserting or deleting columns + (setq field 'cdr) + (if (not min) + ;;Chopped off beginning of range + (setq min (ses-create-cell-symbol (car minrowcol) startcol) + ses-relocate-return 'range)) + (if (not max) + (if (> colincr 0) + ;;Trying to insert a nonexistent column + (setq max (ses-create-cell-symbol (car maxrowcol) (1- numcols))) + ;;End of range is being deleted + (setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol)) + ses-relocate-return 'range)) + (and (> colincr 0) + (= (cdr maxrowcol) (1- startcol)) + (= (car minrowcol) (car maxrowcol)) + ;;Insert after ending column of horizontal range - include it + (setq max (ses-create-cell-symbol (car maxrowcol) + (+ startcol colincr -1))))))) + (when range + (if (/= (- (funcall field maxrowcol) + (funcall field minrowcol)) + (- (funcall field (ses-sym-rowcol max)) + (funcall field (ses-sym-rowcol min)))) + ;;This range has changed size + (setq ses-relocate-return 'range)) + (list 'ses-range min max)))) + +(defun ses-relocate-all (minrow mincol rowincr colincr) + "Alter all cell values, symbols, formulas, and reference-lists to relocate +the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR +to each symbol." + (let (reform) + (let (mycell newval) + (ses-dotimes-msg (row numrows) "Relocating formulas..." + (dotimes (col numcols) + (setq ses-relocate-return nil + mycell (ses-get-cell row col) + newval (ses-relocate-formula (ses-cell-formula mycell) + minrow mincol rowincr colincr)) + (ses-set-cell row col 'formula newval) + (if (eq ses-relocate-return 'range) + ;;This cell contains a (ses-range X Y) where a cell has been + ;;inserted or deleted in the middle of the range. + (push (cons row col) reform)) + (if ses-relocate-return + ;;This cell referred to a cell that's been deleted or is no + ;;longer part of the range. We can't fix that now because + ;;reference lists cells have been partially updated. + (add-to-list 'deferred-recalc + (ses-create-cell-symbol row col))) + (setq newval (ses-relocate-formula (ses-cell-references mycell) + minrow mincol rowincr colincr)) + (ses-set-cell row col 'references newval) + (and (>= row minrow) (>= col mincol) + (ses-set-cell row col 'symbol + (ses-create-cell-symbol row col)))))) + ;;Relocate the cell values + (let (oldval myrow mycol xrow xcol) + (cond + ((and (<= rowincr 0) (<= colincr 0)) + ;;Deletion of rows and/or columns + (ses-dotimes-msg (row (- numrows minrow)) "Relocating variables..." + (setq myrow (+ row minrow)) + (dotimes (col (- numcols mincol)) + (setq mycol (+ col mincol) + xrow (- myrow rowincr) + xcol (- mycol colincr)) + (if (and (< xrow numrows) (< xcol numcols)) + (setq oldval (ses-cell-value xrow xcol)) + ;;Cell is off the end of the array + (setq oldval (symbol-value (ses-create-cell-symbol xrow xcol)))) + (ses-set-cell myrow mycol 'value oldval)))) + ((and (wholenump rowincr) (wholenump colincr)) + ;;Insertion of rows and/or columns. Run the loop backwards. + (let ((disty (1- numrows)) + (distx (1- numcols)) + myrow mycol) + (ses-dotimes-msg (row (- numrows minrow)) "Relocating variables..." + (setq myrow (- disty row)) + (dotimes (col (- numcols mincol)) + (setq mycol (- distx col) + xrow (- myrow rowincr) + xcol (- mycol colincr)) + (if (or (< xrow minrow) (< xcol mincol)) + ;;Newly-inserted value + (setq oldval nil) + ;;Transfer old value + (setq oldval (ses-cell-value xrow xcol))) + (ses-set-cell myrow mycol 'value oldval))) + t)) ;Make testcover happy by returning non-nil here + (t + (error "ROWINCR and COLINCR must have the same sign")))) + ;;Reconstruct reference lists for cells that contain ses-ranges that + ;;have changed size. + (when reform + (message "Fixing ses-ranges...") + (let (row col) + (setq ses-start-time (float-time)) + (while reform + (ses-time-check "Fixing ses-ranges... (%d left)" '(length reform)) + (setq row (caar reform) + col (cdar reform) + reform (cdr reform)) + (ses-cell-set-formula row col (ses-cell-formula row col)))) + (message nil)))) + + +;;;---------------------------------------------------------------------------- +;;;; Undo control +;;;---------------------------------------------------------------------------- + +(defadvice undo-more (around ses-undo-more activate preactivate) + "Define a meaning for conses in buffer-undo-list whose car is a symbol +other than t or nil. To undo these, apply the car--a function--to the +cdr--its arglist." + (let ((ses-count (ad-get-arg 0))) + (catch 'undo + (dolist (ses-x pending-undo-list) + (unless ses-x + ;;End of undo boundary + (setq ses-count (1- ses-count)) + (if (<= ses-count 0) + ;;We've seen enough boundaries - stop undoing + (throw 'undo nil))) + (and (consp ses-x) (symbolp (car ses-x)) (fboundp (car ses-x)) + ;;Undo using apply + (apply (car ses-x) (cdr ses-x))))) + (if (not (eq major-mode 'ses-mode)) + ad-do-it + ;;Here is some extra code for SES mode. + (setq deferred-narrow (or deferred-narrow (< (point-max) (buffer-size)))) + (widen) + (condition-case x + ad-do-it + (error + ;;Restore narrow if appropriate + (ses-command-hook) + (signal (car x) (cdr x))))))) + +(defun ses-begin-change () + "For undo, remember current buffer-position before we start changing hidden +stuff." + (let ((inhibit-read-only t)) + (insert-and-inherit "X") + (delete-region (1- (point)) (point)))) + +(defun ses-set-with-undo (sym newval) + "Like set, but undoable. Result is t if value has changed." + ;;We avoid adding redundant entries to the undo list, but this is + ;;unavoidable for strings because equal ignores text properties and there's + ;;no easy way to get the whole property list to see if it's different! + (unless (and (boundp sym) + (equal (symbol-value sym) newval) + (not (stringp newval))) + (push (if (boundp sym) + `(ses-set-with-undo ,sym ,(symbol-value sym)) + `(ses-unset-with-undo ,sym)) + buffer-undo-list) + (set sym newval) + t)) + +(defun ses-unset-with-undo (sym) + "Set SYM to be unbound. This is undoable." + (when (1value (boundp sym)) ;;Always bound, except after a programming error + (push `(ses-set-with-undo ,sym ,(symbol-value sym)) buffer-undo-list) + (makunbound sym))) + +(defun ses-aset-with-undo (array idx newval) + "Like aset, but undoable. Result is t if element has changed" + (unless (equal (aref array idx) newval) + (push `(ses-aset-with-undo ,array ,idx ,(aref array idx)) buffer-undo-list) + (aset array idx newval) + t)) + + +;;;---------------------------------------------------------------------------- +;;;; Startup for major mode +;;;---------------------------------------------------------------------------- + +(defun ses-build-mode-map () + "Set up `ses-mode-map', `ses-mode-print-map', and `ses-mode-edit-map' with +standard keymap bindings for SES." + (message "Building mode map...") + ;;;Define ses-mode-map + (let ((keys '("\C-c\M-\C-l" ses-reconstruct-all + "\C-c\C-l" ses-recalculate-all + "\C-c\C-n" ses-renarrow-buffer + "\C-c\C-c" ses-recalculate-cell + "\C-c\M-\C-s" ses-sort-column + "\C-c\M-\C-h" ses-read-header-row + "\C-c\C-t" ses-truncate-cell + "\C-c\C-j" ses-jump + "\C-c\C-p" ses-read-default-printer + "\M-\C-l" ses-reprint-all + [?\S-\C-l] ses-reprint-all + [header-line mouse-2] ses-sort-column-click)) + (newmap (make-sparse-keymap))) + (while keys + (define-key (1value newmap) (car keys) (cadr keys)) + (setq keys (cddr keys))) + (setq ses-mode-map (1value newmap))) + ;;;Define ses-mode-print-map + (let ((keys '(;;At least three ways to define shift-tab--and some PC systems + ;;won't generate it at all! + [S-tab] backward-char + [backtab] backward-char + [S-iso-backtab] backward-char + [S-iso-lefttab] backward-char + [tab] ses-forward-or-insert + "\C-i" ses-forward-or-insert ;Needed for ses-coverage.el? + "\M-o" ses-insert-column + "\C-o" ses-insert-row + "\C-m" ses-edit-cell + "\M-k" ses-delete-column + "\M-y" ses-yank-pop + "\C-k" ses-delete-row + "\C-j" ses-append-row-jump-first-column + "\M-h" ses-mark-row + "\M-H" ses-mark-column + "\C-d" ses-clear-cell-forward + "\C-?" ses-clear-cell-backward + "(" ses-read-cell + "\"" ses-read-cell + "'" ses-read-symbol + "=" ses-edit-cell + "j" ses-jump + "p" ses-read-cell-printer + "w" ses-set-column-width + "x" ses-export-keymap + "\M-p" ses-read-column-printer)) + (repl '(;;We'll replace these wherever they appear in the keymap + clipboard-kill-region ses-kill-override + end-of-line ses-end-of-line + kill-line ses-delete-row + kill-region ses-kill-override + open-line ses-insert-row)) + (numeric "0123456789.-") + (newmap (make-keymap))) + ;;Get rid of printables + (suppress-keymap (1value newmap) t) + ;;These keys insert themselves as the beginning of a numeric value + (dotimes (x (length (1value numeric))) + (define-key (1value newmap) + (substring (1value numeric) x (1+ x)) + 'ses-read-cell)) + ;;Override these global functions wherever they're bound + (while repl + (substitute-key-definition (car repl) (cadr repl) + (1value newmap) + (current-global-map)) + (setq repl (cddr repl))) + ;;Apparently substitute-key-definition doesn't catch this? + (define-key (1value newmap) [(menu-bar) edit cut] 'ses-kill-override) + ;;Define our other local keys + (while keys + (define-key (1value newmap) (car keys) (cadr keys)) + (setq keys (cddr keys))) + ;;Keymap property wants the map as a function, not a variable + (fset 'ses-mode-print-map (1value newmap)) + (setq ses-mode-print-map (1value newmap))) + ;;;Define ses-mode-edit-map + (let ((keys '("\C-c\C-r" ses-insert-range + "\C-c\C-s" ses-insert-ses-range + [S-mouse-3] ses-insert-range-click + [C-S-mouse-3] ses-insert-ses-range-click + "\M-\C-i" lisp-complete-symbol)) + (newmap (make-sparse-keymap))) + (1value (set-keymap-parent (1value newmap) (1value minibuffer-local-map))) + (while keys + (define-key (1value newmap) (car keys) (cadr keys)) + (setq keys (cddr keys))) + (setq ses-mode-edit-map (1value newmap))) + (message nil)) + +(defun ses-load () + "Parse the current buffer and sets up buffer-local variables. Does not +execute cell formulas or print functions." + (widen) + ;;Read our global parameters, which should be a 3-element list + (goto-char (point-max)) + (search-backward ";;; Local Variables:\n" nil t) + (backward-list 1) + (let ((params (condition-case nil (read (current-buffer)) (error nil))) + sym) + (or (and (= (safe-length params) 3) + (numberp (car params)) + (numberp (cadr params)) + (> (cadr params) 0) + (numberp (nth 2 params)) + (> (nth 2 params) 0)) + (error "Invalid SES file")) + (setq file-format (car params) + numrows (cadr params) + numcols (nth 2 params)) + (when (= file-format 1) + (let (buffer-undo-list) ;This is not undoable + (ses-goto-data 'header-row) + (insert "(ses-header-row 0)\n") + (ses-set-parameter 'file-format 2) + (message "Upgrading from SES-1 file format"))) + (or (= file-format 2) + (error "This file needs a newer version of the SES library code.")) + (ses-create-cell-variable-range 0 (1- numrows) 0 (1- numcols)) + ;;Initialize cell array + (setq cells (make-vector numrows nil)) + (dotimes (row numrows) + (aset cells row (make-vector numcols nil)))) + ;;Skip over print area, which we assume is correct + (goto-char 1) + (forward-line numrows) + (or (looking-at ses-print-data-boundary) + (error "Missing marker between print and data areas")) + (forward-char (length ses-print-data-boundary)) + ;;Initialize printer and symbol lists + (mapc 'ses-printer-record ses-standard-printer-functions) + (setq symbolic-formulas nil) + ;;Load cell definitions + (dotimes (row numrows) + (dotimes (col numcols) + (let* ((x (read (current-buffer))) + (rowcol (ses-sym-rowcol (car-safe (cdr-safe x))))) + (or (and (looking-at "\n") + (eq (car-safe x) 'ses-cell) + (eq row (car rowcol)) + (eq col (cdr rowcol))) + (error "Cell-def error")) + (eval x))) + (or (looking-at "\n\n") + (error "Missing blank line between rows"))) + ;;Load global parameters + (let ((widths (read (current-buffer))) + (n1 (char-after (point))) + (printers (read (current-buffer))) + (n2 (char-after (point))) + (def-printer (read (current-buffer))) + (n3 (char-after (point))) + (head-row (read (current-buffer))) + (n4 (char-after (point)))) + (or (and (eq (car-safe widths) 'ses-column-widths) + (= n1 ?\n) + (eq (car-safe printers) 'ses-column-printers) + (= n2 ?\n) + (eq (car-safe def-printer) 'ses-default-printer) + (= n3 ?\n) + (eq (car-safe head-row) 'ses-header-row) + (= n4 ?\n)) + (error "Invalid SES global parameters")) + (1value (eval widths)) + (1value (eval def-printer)) + (1value (eval printers)) + (1value (eval head-row))) + ;;Should be back at global-params + (forward-char 1) + (or (looking-at (replace-regexp-in-string "1" "[0-9]+" + ses-initial-global-parameters)) + (error "Problem with column-defs or global-params")) + ;;Check for overall newline count in definitions area + (forward-line 3) + (let ((start (point))) + (ses-goto-data 'numrows) + (or (= (point) start) + (error "Extraneous newlines someplace?")))) + +(defun ses-setup () + "Set up for display of only the printed cell values. + +Narrows the buffer to show only the print area. Gives it `read-only' and +`intangible' properties. Sets up highlighting for current cell." + (interactive) + (let ((end 1) + (inhibit-read-only t) + (was-modified (buffer-modified-p)) + pos sym) + (ses-goto-data 0 0) ;;Include marker between print-area and data-area + (set-text-properties (point) (buffer-size) nil) ;Delete garbage props + (mapc 'delete-overlay (overlays-in 1 (buffer-size))) + ;;The print area is read-only (except for our special commands) and uses a + ;;special keymap. + (put-text-property 1 (1- (point)) 'read-only 'ses) + (put-text-property 1 (1- (point)) 'keymap 'ses-mode-print-map) + ;;For the beginning of the buffer, we want the read-only and keymap + ;;attributes to be inherited from the first character + (put-text-property 1 2 'front-sticky t) + ;;Create intangible properties, which also indicate which cell the text + ;;came from. + (ses-dotimes-msg (row numrows) "Finding cells..." + (dotimes (col numcols) + (setq pos end + sym (ses-cell-symbol row col)) + ;;Include skipped cells following this one + (while (and (< col (1- numcols)) + (eq (ses-cell-value row (1+ col)) '*skip*)) + (setq end (+ end (ses-col-width col) 1) + col (1+ col))) + (setq end (+ end (ses-col-width col) 1)) + (put-text-property pos end 'intangible sym))) + ;;Adding these properties did not actually alter the text + (unless was-modified + (set-buffer-modified-p nil) + (buffer-disable-undo) + (buffer-enable-undo))) + ;;Create the underlining overlay. It's impossible for (point) to be 2, + ;;because column A must be at least 1 column wide. + (setq curcell-overlay (make-overlay 2 2)) + (overlay-put curcell-overlay 'face 'underline)) + +(defun ses-cleanup () + "Cleanup when changing a buffer from SES mode to something else. Delete +overlay, remove special text properties." + (widen) + (let ((inhibit-read-only t) + (was-modified (buffer-modified-p)) + end) + ;;Delete read-only, keymap, and intangible properties + (set-text-properties 1 (point-max) nil) + ;;Delete overlay + (mapc 'delete-overlay (overlays-in 1 (point-max))) + (unless was-modified + (set-buffer-modified-p nil)))) + +;;;###autoload +(defun ses-mode () + "Major mode for Simple Emacs Spreadsheet. See \"ses-readme.txt\" for more info. + +Key definitions: +\\{ses-mode-map} +These key definitions are active only in the print area (the visible part): +\\{ses-mode-print-map} +These are active only in the minibuffer, when entering or editing a formula: +\\{ses-mode-edit-map}" + (interactive) + (unless (and (boundp 'deferred-narrow) + (eq deferred-narrow 'ses-mode)) + (kill-all-local-variables) + (mapc 'make-local-variable ses-localvars) + (setq major-mode 'ses-mode + mode-name "SES" + next-line-add-newlines nil + truncate-lines t + ;;SES deliberately puts lots of trailing whitespace in its buffer + show-trailing-whitespace nil + ;;Cell ranges do not work reasonably without this + transient-mark-mode t) + (unless (and ses-mode-map ses-mode-print-map ses-mode-edit-map) + (ses-build-mode-map)) + (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t)) + (1value (add-hook 'before-revert-hook 'ses-cleanup nil t)) + (setq curcell nil + deferred-recalc nil + deferred-write nil + header-hscroll -1 ;Flag for "initial recalc needed" + header-line-format '(:eval (progn + (when (/= (window-hscroll) + header-hscroll) + ;;Reset header-hscroll first, to + ;;avoid recursion problems when + ;;debugging ses-create-header-string + (setq header-hscroll (window-hscroll)) + (ses-create-header-string)) + header-string))) + (let ((was-empty (zerop (buffer-size))) + (was-modified (buffer-modified-p))) + (save-excursion + (if was-empty + ;;Initialize buffer to contain one cell, for now + (insert ses-initial-file-contents)) + (ses-load) + (ses-setup)) + (when was-empty + (unless (equal ses-initial-default-printer (1value default-printer)) + (1value (ses-read-default-printer ses-initial-default-printer))) + (unless (= ses-initial-column-width (1value (ses-col-width 0))) + (1value (ses-set-column-width 0 ses-initial-column-width))) + (ses-set-curcell) + (if (> (car ses-initial-size) (1value numrows)) + (1value (ses-insert-row (1- (car ses-initial-size))))) + (if (> (cdr ses-initial-size) (1value numcols)) + (1value (ses-insert-column (1- (cdr ses-initial-size))))) + (ses-write-cells) + (set-buffer-modified-p was-modified) + (buffer-disable-undo) + (buffer-enable-undo) + (goto-char 1))) + (use-local-map ses-mode-map) + ;;Set the deferred narrowing flag (we can't narrow until after + ;;after-find-file completes). If .ses is on the auto-load alist and the + ;;file has "mode: ses", our ses-mode function will be called twice! Use + ;;a special flag to detect this (will be reset by ses-command-hook). + ;;For find-alternate-file, post-command-hook doesn't get run for some + ;;reason, so use an idle timer to make sure. + (setq deferred-narrow 'ses-mode) + (1value (add-hook 'post-command-hook 'ses-command-hook nil t)) + (run-with-idle-timer 0.01 nil 'ses-command-hook) + (run-hooks 'ses-mode-hook))) + +(put 'ses-mode 'mode-class 'special) + +(defun ses-command-hook () + "Invoked from `post-command-hook'. If point has moved to a different cell, +moves the underlining overlay. Performs any recalculations or cell-data +writes that have been deferred. If buffer-narrowing has been deferred, +narrows the buffer now." + (condition-case err + (when (eq major-mode 'ses-mode) ;Otherwise, not our buffer anymore + (when deferred-recalc + ;;We reset the deferred list before starting on the recalc -- in case + ;;of error, we don't want to retry the recalc after every keystroke! + (let ((old deferred-recalc)) + (setq deferred-recalc nil) + (ses-update-cells old))) + (if deferred-write + ;;We don't reset the deferred list before starting -- the most + ;;likely error is keyboard-quit, and we do want to keep trying + ;;these writes after a quit. + (ses-write-cells)) + (when deferred-narrow + ;;We're not allowed to narrow the buffer until after-find-file has + ;;read the local variables at the end of the file. Now it's safe to + ;;do the narrowing. + (save-excursion + (goto-char 1) + (forward-line numrows) + (narrow-to-region 1 (point))) + (setq deferred-narrow nil)) + ;;Update the modeline + (let ((oldcell curcell)) + (ses-set-curcell) + (unless (eq curcell oldcell) + (cond + ((not curcell) + (setq mode-line-process nil)) + ((atom curcell) + (setq mode-line-process (list " cell " (symbol-name curcell)))) + (t + (setq mode-line-process (list " range " + (symbol-name (car curcell)) + "-" + (symbol-name (cdr curcell)))))) + (force-mode-line-update))) + ;;Use underline overlay for single-cells only, turn off otherwise + (if (listp curcell) + (move-overlay curcell-overlay 2 2) + (let ((next (next-single-property-change (point) 'intangible))) + (move-overlay curcell-overlay (point) (1- next)))) + (when (not (pos-visible-in-window-p)) + ;;Scrolling will happen later + (run-with-idle-timer 0.01 nil 'ses-command-hook) + (setq curcell t))) + ;;Prevent errors in this post-command-hook from silently erasing the hook! + (error + (unless executing-kbd-macro + (ding)) + (message (error-message-string err)))) + nil) ;Make coverage-tester happy + +(defun ses-create-header-string () + "Sets up `header-string' as the buffer's header line, based on the +current set of columns and window-scroll position." + (let ((totwidth (- 1 (window-hscroll))) + result width result x) + (if window-system + ;;Leave room for the left-side fringe + (push " " result)) + (dotimes (col numcols) + (setq width (ses-col-width col) + totwidth (+ totwidth width 1)) + (if (= totwidth 2) ;Scrolled so intercolumn space is leftmost + (push " " result)) + (when (> totwidth 2) + (if (> header-row 0) + (save-excursion + (ses-goto-print (1- header-row) col) + (setq x (buffer-substring-no-properties (point) + (+ (point) width))) + (if (>= width (1- totwidth)) + (setq x (substring x (- width totwidth -2)))) + (push (propertize x 'face ses-box-prop) result)) + (setq x (ses-column-letter col)) + (push (propertize x 'face ses-box-prop) result) + (push (propertize (make-string (- width (length x)) ?.) + 'display `((space :align-to ,(1- totwidth))) + 'face ses-box-prop) + result)) + ;;Allow the following space to be squished to make room for the 3-D box + ;;Coverage test ignores properties, thinks this is always a space! + (push (1value (propertize " " 'display `((space :align-to ,totwidth)))) + result))) + (if (> header-row 0) + (push (propertize (format " [row %d]" header-row) + 'display '((height (- 1)))) + result)) + (setq header-string (apply 'concat (nreverse result))))) + + +;;;---------------------------------------------------------------------------- +;;;; Redisplay and recalculation +;;;---------------------------------------------------------------------------- + +(defun ses-jump (sym) + "Move point to cell SYM." + (interactive "SJump to cell: ") + (let ((rowcol (ses-sym-rowcol sym))) + (or rowcol (error "Invalid cell name")) + (if (eq (symbol-value sym) '*skip*) + (error "Cell is covered by preceding cell")) + (ses-goto-print (car rowcol) (cdr rowcol)))) + +(defun ses-jump-safe (cell) + "Like `ses-jump', but no error if invalid cell." + (condition-case nil + (ses-jump cell) + (error))) + +(defun ses-reprint-all (&optional nonarrow) + "Recreate the display area. Calls all printer functions. Narrows to +print area if NONARROW is nil." + (interactive "*P") + (widen) + (unless nonarrow + (setq deferred-narrow t)) + (let ((startcell (get-text-property (point) 'intangible)) + (inhibit-read-only t)) + (ses-begin-change) + (goto-char 1) + (search-forward ses-print-data-boundary) + (backward-char (length ses-print-data-boundary)) + (delete-region 1 (point)) + ;;Insert all blank lines before printing anything, so ses-print-cell can + ;;find the data area when inserting or deleting *skip* values for cells + (dotimes (row numrows) + (insert-and-inherit blank-line)) + (ses-dotimes-msg (row numrows) "Reprinting..." + (if (eq (ses-cell-value row 0) '*skip*) + ;;Column deletion left a dangling skip + (ses-set-cell row 0 'value nil)) + (dotimes (col numcols) + (ses-print-cell row col)) + (beginning-of-line 2)) + (ses-jump-safe startcell))) + +(defun ses-recalculate-cell () + "Recalculate and reprint the current cell or range. + +For an individual cell, shows the error if the formula or printer +signals one, or otherwise shows the cell's complete value. For a range, the +cells are recalculated in \"natural\" order, so cells that other cells refer +to are recalculated first." + (interactive "*") + (ses-check-curcell 'range) + (ses-begin-change) + (let (sig) + (setq ses-start-time (float-time)) + (if (atom curcell) + (setq sig (ses-sym-rowcol curcell) + sig (ses-calculate-cell (car sig) (cdr sig) t)) + ;;First, recalculate all cells that don't refer to other cells and + ;;produce a list of cells with references. + (ses-dorange curcell + (ses-time-check "Recalculating... %s" '(ses-cell-symbol row col)) + (condition-case nil + (progn + ;;The t causes an error if the cell has references. + ;;If no references, the t will be the result value. + (1value (ses-formula-references (ses-cell-formula row col) t)) + (setq sig (ses-calculate-cell row col t))) + (wrong-type-argument + ;;The formula contains a reference + (add-to-list 'deferred-recalc (ses-cell-symbol row col)))))) + ;;Do the update now, so we can force recalculation + (let ((x deferred-recalc)) + (setq deferred-recalc nil) + (condition-case hold + (ses-update-cells x t) + (error (setq sig hold)))) + (cond + (sig + (message (error-message-string sig))) + ((consp curcell) + (message " ")) + (t + (princ (symbol-value curcell)))))) + +(defun ses-recalculate-all () + "Recalculate and reprint all cells." + (interactive "*") + (let ((startcell (get-text-property (point) 'intangible)) + (curcell (cons 'A1 (ses-cell-symbol (1- numrows) (1- numcols))))) + (ses-recalculate-cell) + (ses-jump-safe startcell))) + +(defun ses-truncate-cell () + "Reprint current cell, but without spillover into any following blank +cells." + (interactive "*") + (ses-check-curcell) + (let* ((rowcol (ses-sym-rowcol curcell)) + (row (car rowcol)) + (col (cdr rowcol))) + (when (and (< col (1- numcols)) ;;Last column can't spill over, anyway + (eq (ses-cell-value row (1+ col)) '*skip*)) + ;;This cell has spill-over. We'll momentarily pretend the following + ;;cell has a `t' in it. + (eval `(let ((,(ses-cell-symbol row (1+ col)) t)) + (ses-print-cell row col))) + ;;Now remove the *skip*. ses-print-cell is always nil here + (ses-set-cell row (1+ col) 'value nil) + (1value (ses-print-cell row (1+ col)))))) + +(defun ses-reconstruct-all () + "Reconstruct buffer based on cell data stored in Emacs variables." + (interactive "*") + (ses-begin-change) + ;;Reconstruct reference lists. + (let (refs x yrow ycol) + ;;Delete old reference lists + (ses-dotimes-msg (row numrows) "Deleting references..." + (dotimes (col numcols) + (ses-set-cell row col 'references nil))) + ;;Create new reference lists + (ses-dotimes-msg (row numrows) "Computing references..." + (dotimes (col numcols) + (dolist (ref (ses-formula-references (ses-cell-formula row col))) + (setq x (ses-sym-rowcol ref) + yrow (car x) + ycol (cdr x)) + (ses-set-cell yrow ycol 'references + (cons (ses-cell-symbol row col) + (ses-cell-references yrow ycol))))))) + ;;Delete everything and reconstruct basic data area + (if (< (point-max) (buffer-size)) + (setq deferred-narrow t)) + (widen) + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (if (search-backward ";;; Local Variables:\n" nil t) + (delete-region 1 (point)) + ;;Buffer is quite screwed up - can't even save the user-specified locals + (delete-region 1 (point-max)) + (insert ses-initial-file-trailer) + (goto-char 1)) + ;;Create a blank display area + (dotimes (row numrows) + (insert blank-line)) + (insert ses-print-data-boundary) + ;;Placeholders for cell data + (insert (make-string (* numrows (1+ numcols)) ?\n)) + ;;Placeholders for col-widths, col-printers, default-printer, header-row + (insert "\n\n\n\n") + (insert ses-initial-global-parameters)) + (ses-set-parameter 'column-widths column-widths) + (ses-set-parameter 'col-printers col-printers) + (ses-set-parameter 'default-printer default-printer) + (ses-set-parameter 'header-row header-row) + (ses-set-parameter 'numrows numrows) + (ses-set-parameter 'numcols numcols) + ;;Keep our old narrowing + (ses-setup) + (ses-recalculate-all) + (goto-char 1)) + + +;;;---------------------------------------------------------------------------- +;;;; Input of cell formulas +;;;---------------------------------------------------------------------------- + +(defun ses-edit-cell (row col newval) + "Display current cell contents in minibuffer, for editing. Returns nil if +cell formula was unsafe and user declined confirmation." + (interactive + (progn + (barf-if-buffer-read-only) + (ses-check-curcell) + (let* ((rowcol (ses-sym-rowcol curcell)) + (row (car rowcol)) + (col (cdr rowcol)) + (formula (ses-cell-formula row col)) + initial) + (if (eq (car-safe formula) 'ses-safe-formula) + (setq formula (cadr formula))) + (if (eq (car-safe formula) 'quote) + (setq initial (format "'%S" (cadr formula))) + (setq initial (prin1-to-string formula))) + (if (stringp formula) + ;;Position cursor inside close-quote + (setq initial (cons initial (length initial)))) + (list row col + (read-from-minibuffer (format "Cell %s: " curcell) + initial + ses-mode-edit-map + t ;Convert to Lisp object + 'ses-read-cell-history))))) + (when (ses-warn-unsafe newval 'unsafep) + (ses-begin-change) + (ses-cell-set-formula row col newval) + t)) + +(defun ses-read-cell (row col newval) + "Self-insert for initial character of cell function." + (interactive + (let ((initial (this-command-keys)) + (rowcol (progn (ses-check-curcell) (ses-sym-rowcol curcell)))) + (barf-if-buffer-read-only) + (if (string= initial "\"") + (setq initial "\"\"") ;Enter a string + (if (string= initial "(") + (setq initial "()"))) ;Enter a formula list + (list (car rowcol) + (cdr rowcol) + (read-from-minibuffer (format "Cell %s: " curcell) + (cons initial 2) + ses-mode-edit-map + t ;Convert to Lisp object + 'ses-read-cell-history)))) + (when (ses-edit-cell row col newval) + (ses-command-hook) ;Update cell widths before movement + (dolist (x ses-after-entry-functions) + (funcall x 1)))) + +(defun ses-read-symbol (row col symb) + "Self-insert for a symbol as a cell formula. The set of all symbols that +have been used as formulas in this spreadsheet is available for completions." + (interactive + (let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol curcell))) + newval) + (barf-if-buffer-read-only) + (setq newval (completing-read (format "Cell %s ': " curcell) + symbolic-formulas)) + (list (car rowcol) + (cdr rowcol) + (if (string= newval "") + nil ;Don't create zero-length symbols! + (list 'quote (intern newval)))))) + (when (ses-edit-cell row col symb) + (ses-command-hook) ;Update cell widths before movement + (dolist (x ses-after-entry-functions) + (funcall x 1)))) + +(defun ses-clear-cell-forward (count) + "Delete formula and printer for current cell and then move to next cell. +With prefix, deletes several cells." + (interactive "*p") + (if (< count 0) + (1value (ses-clear-cell-backward (- count))) + (ses-check-curcell) + (ses-begin-change) + (dotimes (x count) + (ses-set-curcell) + (let ((rowcol (ses-sym-rowcol curcell))) + (or rowcol (signal 'end-of-buffer nil)) + (ses-clear-cell (car rowcol) (cdr rowcol))) + (forward-char 1)))) + +(defun ses-clear-cell-backward (count) + "Move to previous cell and then delete it. With prefix, deletes several +cells." + (interactive "*p") + (if (< count 0) + (1value (ses-clear-cell-forward (- count))) + (ses-check-curcell 'end) + (ses-begin-change) + (dotimes (x count) + (backward-char 1) ;Will signal 'beginning-of-buffer if appropriate + (ses-set-curcell) + (let ((rowcol (ses-sym-rowcol curcell))) + (ses-clear-cell (car rowcol) (cdr rowcol)))))) + + +;;;---------------------------------------------------------------------------- +;;;; Input of cell-printer functions +;;;---------------------------------------------------------------------------- + +(defun ses-read-printer (prompt default) + "Common code for `ses-read-cell-printer', `ses-read-column-printer', and `ses-read-default-printer'. +PROMPT should end with \": \". Result is t if operation was cancelled." + (barf-if-buffer-read-only) + (if (eq default t) + (setq default "") + (setq prompt (format "%s [currently %S]: " + (substring prompt 0 -2) + default))) + (let ((new (read-from-minibuffer prompt + nil ;Initial contents + ses-mode-edit-map + t ;Evaluate the result + 'ses-read-printer-history + (prin1-to-string default)))) + (if (equal new default) + ;;User changed mind, decided not to change printer + (setq new t) + (ses-printer-validate new) + (or (not new) + (stringp new) + (stringp (car-safe new)) + (ses-warn-unsafe new 'unsafep-function) + (setq new t))) + new)) + +(defun ses-read-cell-printer (newval) + "Set the printer function for the current cell or range. + +A printer function is either a string (a format control-string with one +%-sequence -- result from format will be right-justified), or a list of one +string (result from format will be left-justified), or a lambda-expression of +one argument, or a symbol that names a function of one argument. In the +latter two cases, the function's result should be either a string (will be +right-justified) or a list of one string (will be left-justified)." + (interactive + (let ((default t) + prompt) + (ses-check-curcell 'range) + ;;Default is none if not all cells in range have same printer + (catch 'ses-read-cell-printer + (ses-dorange curcell + (setq x (ses-cell-printer row col)) + (if (eq (car-safe x) 'ses-safe-printer) + (setq x (cadr x))) + (if (eq default t) + (setq default x) + (unless (equal default x) + ;;Range contains differing printer functions + (setq default t) + (throw 'ses-read-cell-printer t))))) + (list (ses-read-printer (format "Cell %S printer: " curcell) default)))) + (unless (eq newval t) + (ses-begin-change) + (ses-dorange curcell + (ses-set-cell row col 'printer newval) + (ses-print-cell row col)))) + +(defun ses-read-column-printer (col newval) + "Set the printer function for the current column. See +`ses-read-cell-printer' for input forms." + (interactive + (let ((col (cdr (ses-sym-rowcol curcell)))) + (ses-check-curcell) + (list col (ses-read-printer (format "Column %s printer: " + (ses-column-letter col)) + (ses-col-printer col))))) + + (unless (eq newval t) + (ses-begin-change) + (ses-set-parameter 'col-printers newval col) + (save-excursion + (dotimes (row numrows) + (ses-print-cell row col))))) + +(defun ses-read-default-printer (newval) + "Set the default printer function for cells that have no other. See +`ses-read-cell-printer' for input forms." + (interactive + (list (ses-read-printer "Default printer: " default-printer))) + (unless (eq newval t) + (ses-begin-change) + (ses-set-parameter 'default-printer newval) + (ses-reprint-all t))) + + +;;;---------------------------------------------------------------------------- +;;;; Spreadsheet size adjustments +;;;---------------------------------------------------------------------------- + +(defun ses-insert-row (count) + "Insert a new row before the current one. With prefix, insert COUNT rows +before current one." + (interactive "*p") + (ses-check-curcell 'end) + (or (> count 0) (signal 'args-out-of-range nil)) + (ses-begin-change) + (let ((inhibit-quit t) + (inhibit-read-only t) + (row (or (car (ses-sym-rowcol curcell)) numrows)) + newrow) + ;;Create a new set of cell-variables + (ses-create-cell-variable-range numrows (+ numrows count -1) + 0 (1- numcols)) + (ses-set-parameter 'numrows (+ numrows count)) + ;;Insert each row + (ses-goto-print row 0) + (ses-dotimes-msg (x count) "Inserting row..." + ;;Create a row of empty cells. The `symbol' fields will be set by + ;;the call to ses-relocate-all. + (setq newrow (make-vector numcols nil)) + (dotimes (col numcols) + (aset newrow col (make-vector ses-cell-size nil))) + (setq cells (ses-vector-insert cells row newrow)) + (push `(ses-vector-delete cells ,row 1) buffer-undo-list) + (insert blank-line)) + ;;Insert empty lines in cell data area (will be replaced by + ;;ses-relocate-all) + (ses-goto-data row 0) + (insert (make-string (* (1+ numcols) count) ?\n)) + (ses-relocate-all row 0 count 0) + ;;If any cell printers insert constant text, insert that text + ;;into the line. + (let ((cols (mapconcat #'ses-call-printer col-printers nil)) + (global (ses-call-printer default-printer))) + (if (or (> (length cols) 0) (> (length global) 0)) + (dotimes (x count) + (dotimes (col numcols) + ;;These cells are always nil, only constant formatting printed + (1value (ses-print-cell (+ x row) col)))))) + (when (> header-row row) + ;;Inserting before header + (ses-set-parameter 'header-row (+ header-row count)) + (ses-reset-header-string))) + ;;Reconstruct text attributes + (ses-setup) + ;;Return to current cell + (if curcell + (ses-jump-safe curcell) + (ses-goto-print (1- numrows) 0))) + +(defun ses-delete-row (count) + "Delete the current row. With prefix, Deletes COUNT rows starting from the +current one." + (interactive "*p") + (ses-check-curcell) + (or (> count 0) (signal 'args-out-of-range nil)) + (let ((inhibit-quit t) + (inhibit-read-only t) + (row (car (ses-sym-rowcol curcell))) + pos) + (setq count (min count (- numrows row))) + (ses-begin-change) + (ses-set-parameter 'numrows (- numrows count)) + ;;Delete lines from print area + (ses-goto-print row 0) + (ses-delete-line count) + ;;Delete lines from cell data area + (ses-goto-data row 0) + (ses-delete-line (* count (1+ numcols))) + ;;Relocate variables and formulas + (ses-set-with-undo 'cells (ses-vector-delete cells row count)) + (ses-relocate-all row 0 (- count) 0) + (ses-destroy-cell-variable-range numrows (+ numrows count -1) + 0 (1- numcols)) + (when (> header-row row) + (if (<= header-row (+ row count)) + ;;Deleting the header row + (ses-set-parameter 'header-row 0) + (ses-set-parameter 'header-row (- header-row count))) + (ses-reset-header-string))) + ;;Reconstruct attributes + (ses-setup) + (ses-jump-safe curcell)) + +(defun ses-insert-column (count &optional col width printer) + "Insert a new column before COL (default is the current one). With prefix, +insert COUNT columns before current one. If COL is specified, the new +column(s) get the specified WIDTH and PRINTER (otherwise they're taken from +the current column)." + (interactive "*p") + (ses-check-curcell) + (or (> count 0) (signal 'args-out-of-range nil)) + (or col + (setq col (cdr (ses-sym-rowcol curcell)) + width (ses-col-width col) + printer (ses-col-printer col))) + (ses-begin-change) + (let ((inhibit-quit t) + (inhibit-read-only t) + (widths column-widths) + (printers col-printers) + has-skip) + ;;Create a new set of cell-variables + (ses-create-cell-variable-range 0 (1- numrows) + numcols (+ numcols count -1)) + ;;Insert each column. + (ses-dotimes-msg (x count) "Inserting column..." + ;;Create a column of empty cells. The `symbol' fields will be set by + ;;the call to ses-relocate-all. + (ses-adjust-print-width col (1+ width)) + (ses-set-parameter 'numcols (1+ numcols)) + (dotimes (row numrows) + (and (< (1+ col) numcols) (eq (ses-cell-value row col) '*skip*) + ;;Inserting in the middle of a spill-over + (setq has-skip t)) + (ses-aset-with-undo cells row + (ses-vector-insert (aref cells row) + col + (make-vector ses-cell-size nil))) + ;;Insert empty lines in cell data area (will be replaced by + ;;ses-relocate-all) + (ses-goto-data row col) + (insert ?\n)) + ;;Insert column width and printer + (setq widths (ses-vector-insert widths col width) + printers (ses-vector-insert printers col printer))) + (ses-set-parameter 'column-widths widths) + (ses-set-parameter 'col-printers printers) + (ses-reset-header-string) + (ses-relocate-all 0 col 0 count) + (if has-skip + (ses-reprint-all t) + (when (or (> (length (ses-call-printer printer)) 0) + (> (length (ses-call-printer default-printer)) 0)) + ;;Either column printer or global printer inserts some constant text + ;;Reprint the new columns to insert that text. + (dotimes (x numrows) + (dotimes (y count) + ;Always nil here - this is a blank column + (1value (ses-print-cell-new-width x (+ y col)))))) + (ses-setup))) + (ses-jump-safe curcell)) + +(defun ses-delete-column (count) + "Delete the current column. With prefix, Deletes COUNT columns starting +from the current one." + (interactive "*p") + (ses-check-curcell) + (or (> count 0) (signal 'args-out-of-range nil)) + (let ((inhibit-quit t) + (inhibit-read-only t) + (rowcol (ses-sym-rowcol curcell)) + (width 0) + new col origrow has-skip) + (setq origrow (car rowcol) + col (cdr rowcol) + count (min count (- numcols col))) + (if (= count numcols) + (error "Can't delete all columns!")) + ;;Determine width of column(s) being deleted + (dotimes (x count) + (setq width (+ width (ses-col-width (+ col x)) 1))) + (ses-begin-change) + (ses-set-parameter 'numcols (- numcols count)) + (ses-adjust-print-width col (- width)) + (ses-dotimes-msg (row numrows) "Deleting column..." + ;;Delete lines from cell data area + (ses-goto-data row col) + (ses-delete-line count) + ;;Delete cells. Check if deletion area begins or ends with a skip. + (if (or (eq (ses-cell-value row col) '*skip*) + (and (< col numcols) + (eq (ses-cell-value row (+ col count)) '*skip*))) + (setq has-skip t)) + (ses-aset-with-undo cells row + (ses-vector-delete (aref cells row) col count))) + ;;Update globals + (ses-set-parameter 'column-widths + (ses-vector-delete column-widths col count)) + (ses-set-parameter 'col-printers + (ses-vector-delete col-printers col count)) + (ses-reset-header-string) + ;;Relocate variables and formulas + (ses-relocate-all 0 col 0 (- count)) + (ses-destroy-cell-variable-range 0 (1- numrows) + numcols (+ numcols count -1)) + (if has-skip + (ses-reprint-all t) + (ses-setup)) + (if (>= col numcols) + (setq col (1- col))) + (ses-goto-print origrow col))) + +(defun ses-forward-or-insert (&optional count) + "Move to next cell in row, or inserts a new cell if already in last one, or +inserts a new row if at bottom of print area. Repeat COUNT times." + (interactive "p") + (ses-check-curcell 'end) + (setq deactivate-mark t) ;Doesn't combine well with ranges + (dotimes (x count) + (ses-set-curcell) + (if (not curcell) + (progn ;At bottom of print area + (barf-if-buffer-read-only) + (ses-insert-row 1)) + (let ((col (cdr (ses-sym-rowcol curcell)))) + (when (/= 32 + (char-before (next-single-property-change (point) + 'intangible))) + ;;We're already in last nonskipped cell on line. Need to create a + ;;new column. + (barf-if-buffer-read-only) + (ses-insert-column (- count x) + numcols + (ses-col-width col) + (ses-col-printer col))))) + (forward-char))) + +(defun ses-append-row-jump-first-column () + "Insert a new row after current one and jumps to its first column." + (interactive "*") + (ses-check-curcell) + (ses-begin-change) + (beginning-of-line 2) + (ses-set-curcell) + (ses-insert-row 1)) + +(defun ses-set-column-width (col newwidth) + "Set the width of the current column." + (interactive + (let ((col (cdr (progn (ses-check-curcell) (ses-sym-rowcol curcell))))) + (barf-if-buffer-read-only) + (list col + (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (read-from-minibuffer (format "Column %s width [currently %d]: " + (ses-column-letter col) + (ses-col-width col)) + nil ;No initial contents + nil ;No override keymap + t ;Convert to Lisp object + nil ;No history + (number-to-string + (ses-col-width col))))))) ;Default value + (if (< newwidth 1) + (error "Invalid column width")) + (ses-begin-change) + (ses-reset-header-string) + (save-excursion + (let ((inhibit-quit t)) + (ses-adjust-print-width col (- newwidth (ses-col-width col))) + (ses-set-parameter 'column-widths newwidth col)) + (dotimes (row numrows) + (ses-print-cell-new-width row col)))) + + +;;;---------------------------------------------------------------------------- +;;;; Cut and paste, import and export +;;;---------------------------------------------------------------------------- + +(defadvice copy-region-as-kill (around ses-copy-region-as-kill + activate preactivate) + "It doesn't make sense to copy read-only or intangible attributes into the +kill ring. It probably doesn't make sense to copy keymap properties. +We'll assume copying front-sticky properties doesn't make sense, either. + +This advice also includes some SES-specific code because otherwise it's too +hard to override how mouse-1 works." + (when (> beg end) + (let ((temp beg)) + (setq beg end + end temp))) + (if (not (and (eq major-mode 'ses-mode) + (eq (get-text-property beg 'read-only) 'ses) + (eq (get-text-property (1- end) 'read-only) 'ses))) + ad-do-it ;Normal copy-region-as-kill + (kill-new (ses-copy-region beg end)))) + +(defun ses-copy-region (beg end) + "Treat the region as rectangular. Convert the intangible attributes to +SES attributes recording the contents of the cell as of the time of copying." + (let* ((inhibit-point-motion-hooks t) + (x (mapconcat 'ses-copy-region-helper + (extract-rectangle beg (1- end)) "\n"))) + (remove-text-properties 0 (length x) + '(read-only t + intangible t + keymap t + front-sticky t) + x) + x)) + +(defun ses-copy-region-helper (line) + "Converts one line (of a rectangle being extracted from a spreadsheet) to +external form by attaching to each print cell a 'ses attribute that records +the corresponding data cell." + (or (> (length line) 1) + (error "Empty range")) + (let ((inhibit-read-only t) + (pos 0) + mycell next sym rowcol) + (while pos + (setq sym (get-text-property pos 'intangible line) + next (next-single-property-change pos 'intangible line) + rowcol (ses-sym-rowcol sym) + mycell (ses-get-cell (car rowcol) (cdr rowcol))) + (put-text-property pos (or next (length line)) + 'ses + (list (ses-cell-symbol mycell) + (ses-cell-formula mycell) + (ses-cell-printer mycell)) + line) + (setq pos next))) + line) + +(defun ses-kill-override (beg end) + "Generic override for any commands that kill text. We clear the killed +cells instead of deleting them." + (interactive "r") + (ses-check-curcell 'needrange) + ;;For some reason, the text-read-only error is not caught by + ;;`delete-region', so we have to use subterfuge. + (let ((buffer-read-only t)) + (1value (condition-case x + (noreturn (funcall (lookup-key (current-global-map) + (this-command-keys)) + beg end)) + (buffer-read-only nil)))) ;The expected error + ;;Because the buffer was marked read-only, the kill command turned itself + ;;into a copy. Now we clear the cells or signal the error. First we + ;;check whether the buffer really is read-only. + (barf-if-buffer-read-only) + (ses-begin-change) + (ses-dorange curcell + (ses-clear-cell row col)) + (ses-jump (car curcell))) + +(defadvice yank (around ses-yank activate preactivate) + "In SES mode, the yanked text is inserted as cells. + +If the text contains 'ses attributes (meaning it went to the kill-ring from a +SES buffer), the formulas and print functions are restored for the cells. If +the text contains tabs, this is an insertion of tab-separated formulas. +Otherwise the text is inserted as the formula for the current cell. + +When inserting cells, the formulas are usually relocated to keep the same +relative references to neighboring cells. This is best if the formulas +generally refer to other cells within the yanked text. You can use the C-u +prefix to specify insertion without relocation, which is best when the +formulas refer to cells outsite the yanked text. + +When inserting formulas, the text is treated as a string constant if it doesn't +make sense as a sexp or would otherwise be considered a symbol. Use 'sym to +explicitly insert a symbol, or use the C-u prefix to treat all unmarked words +as symbols." + (if (not (and (eq major-mode 'ses-mode) + (eq (get-text-property (point) 'keymap) 'ses-mode-print-map))) + ad-do-it ;Normal non-SES yank + (ses-check-curcell 'end) + (push-mark (point)) + (let ((text (current-kill (cond + ((listp arg) 0) + ((eq arg '-) -1) + (t (1- arg)))))) + (or (ses-yank-cells text arg) + (ses-yank-tsf text arg) + (ses-yank-one (ses-yank-resize 1 1) + text + 0 + (if (memq (aref text (1- (length text))) '(?\t ?\n)) + ;;Just one cell - delete final tab or newline + (1- (length text))) + arg))) + (if (consp arg) + (exchange-point-and-mark)))) + +(defun ses-yank-pop (arg) + "Replace just-yanked stretch of killed text with a different stretch. +This command is allowed only immediately after a `yank' or a `yank-pop', when +the region contains a stretch of reinserted previously-killed text. We +replace it with a different stretch of killed text. + Unlike standard `yank-pop', this function uses `undo' to delete the +previous insertion." + (interactive "*p") + (or (eq last-command 'yank) + ;;Use noreturn here just to avoid a "poor-coverage" warning in its + ;;macro definition. + (noreturn (error "Previous command was not a yank"))) + (undo) + (ses-set-curcell) + (yank (1+ (or arg 1))) + (setq this-command 'yank)) + +(defun ses-yank-cells (text arg) + "If the TEXT has a proper set of 'ses attributes, inserts the text as +cells, else return nil. The cells are reprinted--the supplied text is +ignored because the column widths, default printer, etc. at yank time might +be different from those at kill-time. ARG is a list to indicate that +formulas are to be inserted without relocation." + (let ((first (get-text-property 0 'ses text)) + (last (get-text-property (1- (length text)) 'ses text))) + (when (and first last) ;;Otherwise not proper set of attributes + (setq first (ses-sym-rowcol (car first)) + last (ses-sym-rowcol (car last))) + (let* ((needrows (- (car last) (car first) -1)) + (needcols (- (cdr last) (cdr first) -1)) + (rowcol (ses-yank-resize needrows needcols)) + (rowincr (- (car rowcol) (car first))) + (colincr (- (cdr rowcol) (cdr first))) + (pos 0) + myrow mycol x) + (ses-dotimes-msg (row needrows) "Yanking..." + (setq myrow (+ row (car rowcol))) + (dotimes (col needcols) + (setq mycol (+ col (cdr rowcol)) + last (get-text-property pos 'ses text) + pos (next-single-property-change pos 'ses text) + x (ses-sym-rowcol (car last))) + (if (not last) + ;;Newline - all remaining cells on row are skipped + (setq x (cons (- myrow rowincr) (+ needcols colincr -1)) + last (list nil nil nil) + pos (1- pos))) + (if (/= (car x) (- myrow rowincr)) + (error "Cell row error")) + (if (< (- mycol colincr) (cdr x)) + ;;Some columns were skipped + (let ((oldcol mycol)) + (while (< (- mycol colincr) (cdr x)) + (ses-clear-cell myrow mycol) + (setq col (1+ col) + mycol (1+ mycol))) + (ses-print-cell myrow (1- oldcol)))) ;;This inserts *skip* + (when (car last) ;Skip this for *skip* cells + (setq x (nth 2 last)) + (unless (equal x (ses-cell-printer myrow mycol)) + (or (not x) + (stringp x) + (eq (car-safe x) 'ses-safe-printer) + (setq x `(ses-safe-printer ,x))) + (ses-set-cell myrow mycol 'printer x)) + (setq x (cadr last)) + (if (atom arg) + (setq x (ses-relocate-formula x 0 0 rowincr colincr))) + (or (atom x) + (eq (car-safe x) 'ses-safe-formula) + (setq x `(ses-safe-formula ,x))) + (ses-cell-set-formula myrow mycol x))) + (when pos + (if (get-text-property pos 'ses text) + (error "Missing newline between rows")) + (setq pos (next-single-property-change pos 'ses text)))) + t)))) + +(defun ses-yank-one (rowcol text from to arg) + "Insert the substring [FROM,TO] of TEXT as the formula for cell ROWCOL (a +cons of ROW and COL). Treat plain symbols as strings unless ARG is a list." + (let ((val (condition-case nil + (read-from-string text from to) + (error (cons nil from))))) + (cond + ((< (cdr val) (or to (length text))) + ;;Invalid sexp - leave it as a string + (setq val (substring text from to))) + ((and (car val) (symbolp (car val))) + (if (consp arg) + (setq val (list 'quote (car val))) ;Keep symbol + (setq val (substring text from to)))) ;Treat symbol as text + (t + (setq val (car val)))) + (let ((row (car rowcol)) + (col (cdr rowcol))) + (or (atom val) + (setq val `(ses-safe-formula ,val))) + (ses-cell-set-formula row col val)))) + +(defun ses-yank-tsf (text arg) + "If TEXT contains tabs and/or newlines, treats the tabs as +column-separators and the newlines as row-separators and inserts the text as +cell formulas--else return nil. Treat plain symbols as strings unless ARG +is a list. Ignore a final newline." + (if (or (not (string-match "[\t\n]" text)) + (= (match-end 0) (length text))) + ;;Not TSF format + nil + (if (/= (aref text (1- (length text))) ?\n) + (setq text (concat text "\n"))) + (let ((pos -1) + (spots (list -1)) + (cols 0) + (needrows 0) + needcols rowcol) + ;;Find all the tabs and newlines + (while (setq pos (string-match "[\t\n]" text (1+ pos))) + (push pos spots) + (setq cols (1+ cols)) + (when (eq (aref text pos) ?\n) + (if (not needcols) + (setq needcols cols) + (or (= needcols cols) + (error "Inconsistent row lengths"))) + (setq cols 0 + needrows (1+ needrows)))) + ;;Insert the formulas + (setq rowcol (ses-yank-resize needrows needcols)) + (dotimes (row needrows) + (dotimes (col needcols) + (ses-yank-one (cons (+ (car rowcol) needrows (- row) -1) + (+ (cdr rowcol) needcols (- col) -1)) + text (1+ (cadr spots)) (car spots) arg) + (setq spots (cdr spots)))) + (ses-goto-print (+ (car rowcol) needrows -1) + (+ (cdr rowcol) needcols -1)) + t))) + +(defun ses-yank-resize (needrows needcols) + "If this yank will require inserting rows and/or columns, asks for +confirmation and then inserts them. Result is (row,col) for top left of yank +spot, or error signal if user requests cancel." + (ses-begin-change) + (let ((rowcol (if curcell (ses-sym-rowcol curcell) (cons numrows 0))) + rowbool colbool) + (setq needrows (- (+ (car rowcol) needrows) numrows) + needcols (- (+ (cdr rowcol) needcols) numcols) + rowbool (> needrows 0) + colbool (> needcols 0)) + (when (or rowbool colbool) + ;;Need to insert. Get confirm + (or (y-or-n-p (format "Yank will insert %s%s%s. Continue " + (if rowbool (format "%d rows" needrows) "") + (if (and rowbool colbool) " and " "") + (if colbool (format "%d columns" needcols) ""))) + (error "Cancelled")) + (when rowbool + (let (curcell) + (save-excursion + (ses-goto-print numrows 0) + (ses-insert-row needrows)))) + (when colbool + (ses-insert-column needcols + numcols + (ses-col-width (1- numcols)) + (ses-col-printer (1- numcols))))) + rowcol)) + +(defun ses-export-tsv (beg end) + "Export values from the current range, with tabs between columns and +newlines between rows. Result is placed in kill ring." + (interactive "r") + (ses-export-tab nil)) + +(defun ses-export-tsf (beg end) + "Export formulas from the current range, with tabs between columns and +newlines between rows. Result is placed in kill ring." + (interactive "r") + (ses-export-tab t)) + +(defun ses-export-tab (want-formulas) + "Export the current range with tabs between columns and newlines between +rows. Result is placed in kill ring. The export is values unless +WANT-FORMULAS is non-nil. Newlines and tabs in the export text are escaped." + (ses-check-curcell 'needrange) + (let ((print-escape-newlines t) + result item) + (ses-dorange curcell + (setq item (if want-formulas + (ses-cell-formula row col) + (ses-cell-value row col))) + (if (eq (car-safe item) 'ses-safe-formula) + ;;Hide our deferred safety-check marker + (setq item (cadr item))) + (if (or (not item) (eq item '*skip*)) + (setq item "")) + (when (eq (car-safe item) 'quote) + (push "'" result) + (setq item (cadr item))) + (setq item (prin1-to-string item t)) + (setq item (replace-regexp-in-string "\t" "\\\\t" item)) + (push item result) + (cond + ((< col maxcol) + (push "\t" result)) + ((< row maxrow) + (push "\n" result)))) + (setq result (apply 'concat (nreverse result))) + (kill-new result))) + + +;;;---------------------------------------------------------------------------- +;;;; Other user commands +;;;---------------------------------------------------------------------------- + +(defun ses-read-header-row (row) + (interactive "NHeader row: ") + (if (or (< row 0) (> row numrows)) + (error "Invalid header-row")) + (ses-begin-change) + (ses-set-parameter 'header-row row) + (ses-reset-header-string)) + +(defun ses-mark-row () + "Marks the entirety of current row as a range." + (interactive) + (ses-check-curcell 'range) + (let ((row (car (ses-sym-rowcol (or (car-safe curcell) curcell))))) + (push-mark (point)) + (ses-goto-print (1+ row) 0) + (push-mark (point) nil t) + (ses-goto-print row 0))) + +(defun ses-mark-column () + "Marks the entirety of current column as a range." + (interactive) + (ses-check-curcell 'range) + (let ((col (cdr (ses-sym-rowcol (or (car-safe curcell) curcell)))) + (row 0)) + (push-mark (point)) + (ses-goto-print (1- numrows) col) + (forward-char 1) + (push-mark (point) nil t) + (while (eq '*skip* (ses-cell-value row col)) + ;;Skip over initial cells in column that can't be selected + (setq row (1+ row))) + (ses-goto-print row col))) + +(defun ses-end-of-line () + "Move point to last cell on line." + (interactive) + (ses-check-curcell 'end 'range) + (when curcell ;Otherwise we're at the bottom row, which is empty anyway + (let ((col (1- numcols)) + row rowcol) + (if (symbolp curcell) + ;;Single cell + (setq row (car (ses-sym-rowcol curcell))) + ;;Range - use whichever end of the range the point is at + (setq rowcol (ses-sym-rowcol (if (< (point) (mark)) + (car curcell) + (cdr curcell)))) + ;;If range already includes the last cell in a row, point is actually + ;;in the following row + (if (<= (cdr rowcol) (1- col)) + (setq row (car rowcol)) + (setq row (1+ (car rowcol))) + (if (= row numrows) + ;;Already at end - can't go anywhere + (setq col 0)))) + (when (< row numrows) ;Otherwise it's a range that includes last cell + (while (eq (ses-cell-value row col) '*skip*) + ;;Back to beginning of multi-column cell + (setq col (1- col))) + (ses-goto-print row col))))) + +(defun ses-renarrow-buffer () + "Narrow the buffer so only the print area is visible. Use after \\[widen]." + (interactive) + (setq deferred-narrow t)) + +(defun ses-sort-column (sorter &optional reverse) + "Sorts the range by a specified column. With prefix, sorts in +REVERSE order." + (interactive "*sSort column: \nP") + (ses-check-curcell 'needrange) + (let ((min (ses-sym-rowcol (car curcell))) + (max (ses-sym-rowcol (cdr curcell)))) + (let ((minrow (car min)) + (mincol (cdr min)) + (maxrow (car max)) + (maxcol (cdr max)) + keys extracts end) + (setq sorter (cdr (ses-sym-rowcol (intern (concat sorter "1"))))) + (or (and sorter (>= sorter mincol) (<= sorter maxcol)) + (error "Invalid sort column")) + ;;Get key columns and sort them + (dotimes (x (- maxrow minrow -1)) + (ses-goto-print (+ minrow x) sorter) + (setq end (next-single-property-change (point) 'intangible)) + (push (cons (buffer-substring-no-properties (point) end) + (+ minrow x)) + keys)) + (setq keys (sort keys #'(lambda (x y) (string< (car x) (car y))))) + ;;Extract the lines in reverse sorted order + (or reverse + (setq keys (nreverse keys))) + (dolist (x keys) + (ses-goto-print (cdr x) (1+ maxcol)) + (setq end (point)) + (ses-goto-print (cdr x) mincol) + (push (ses-copy-region (point) end) extracts)) + (deactivate-mark) + ;;Paste the lines sequentially + (dotimes (x (- maxrow minrow -1)) + (ses-goto-print (+ minrow x) mincol) + (ses-set-curcell) + (ses-yank-cells (pop extracts) nil))))) + +(defun ses-sort-column-click (event reverse) + (interactive "*e\nP") + (setq event (event-end event)) + (select-window (posn-window event)) + (setq event (car (posn-col-row event))) ;Click column + (let ((col 0)) + (while (and (< col numcols) (> event (ses-col-width col))) + (setq event (- event (ses-col-width col) 1) + col (1+ col))) + (if (>= col numcols) + (ding) + (ses-sort-column (ses-column-letter col) reverse)))) + +(defun ses-insert-range () + "Inserts into minibuffer the list of cells currently highlighted in the +spreadsheet." + (interactive "*") + (let (x) + (with-current-buffer (window-buffer minibuffer-scroll-window) + (ses-command-hook) ;For ses-coverage + (ses-check-curcell 'needrange) + (setq x (cdr (macroexpand `(ses-range ,(car curcell) ,(cdr curcell)))))) + (insert (substring (prin1-to-string (nreverse x)) 1 -1)))) + +(defun ses-insert-ses-range () + "Inserts \"(ses-range x y)\" in the minibuffer to represent the currently +highlighted range in the spreadsheet." + (interactive "*") + (let (x) + (with-current-buffer (window-buffer minibuffer-scroll-window) + (ses-command-hook) ;For ses-coverage + (ses-check-curcell 'needrange) + (setq x (format "(ses-range %S %S)" (car curcell) (cdr curcell)))) + (insert x))) + +(defun ses-insert-range-click (event) + "Mouse version of `ses-insert-range'." + (interactive "*e") + (mouse-set-point event) + (ses-insert-range)) + +(defun ses-insert-ses-range-click (event) + "Mouse version of `ses-insert-ses-range'." + (interactive "*e") + (mouse-set-point event) + (ses-insert-ses-range)) + + +;;;---------------------------------------------------------------------------- +;;;; Checking formulas for safety +;;;---------------------------------------------------------------------------- + +(defun ses-safe-printer (printer) + "Returns PRINTER if safe, or the substitute printer `ses-unsafe' otherwise." + (if (or (stringp printer) + (stringp (car-safe printer)) + (not printer) + (ses-warn-unsafe printer 'unsafep-function)) + printer + 'ses-unsafe)) + +(defun ses-safe-formula (formula) + "Returns FORMULA if safe, or the substitute formula *unsafe* otherwise." + (if (ses-warn-unsafe formula 'unsafep) + formula + `(ses-unsafe ',formula))) + +(defun ses-warn-unsafe (formula checker) + "Applies CHECKER to FORMULA. If result is non-nil, asks user for +confirmation about FORMULA, which might be unsafe. Returns t if formula +is safe or user allows execution anyway. Always returns t if +`safe-functions' is t." + (if (eq safe-functions t) + t + (setq checker (funcall checker formula)) + (if (not checker) + t + (y-or-n-p (format "Formula %S\nmight be unsafe %S. Process it? " + formula checker))))) + + +;;;---------------------------------------------------------------------------- +;;;; Standard formulas +;;;---------------------------------------------------------------------------- + +(defmacro ses-range (from to) + "Expands to a list of cell-symbols for the range. The range automatically +expands to include any new row or column inserted into its middle. The SES +library code specifically looks for the symbol `ses-range', so don't create an +alias for this macro!" + (let (result) + (ses-dorange (cons from to) + (push (ses-cell-symbol row col) result)) + (cons 'list result))) + +(defun ses-delete-blanks (&rest args) + "Return ARGS reversed, with the blank elements (nil and *skip*) removed." + (let (result) + (dolist (cur args) + (and cur (not (eq cur '*skip*)) + (push cur result))) + result)) + +(defun ses+ (&rest args) + "Compute the sum of the arguments, ignoring blanks." + (apply '+ (apply 'ses-delete-blanks args))) + +(defun ses-average (list) + "Computes the sum of the numbers in LIST, divided by their length. Blanks +are ignored. Result is always floating-point, even if all args are integers." + (setq list (apply 'ses-delete-blanks list)) + (/ (float (apply '+ list)) (length list))) + +(defmacro ses-select (fromrange test torange) + "Select cells in FROMRANGE that are `equal' to TEST. For each match, return +the corresponding cell from TORANGE. The ranges are macroexpanded but not +evaluated so they should be either (ses-range BEG END) or (list ...). The +TEST is evaluated." + (setq fromrange (cdr (macroexpand fromrange)) + torange (cdr (macroexpand torange)) + test (eval test)) + (or (= (length fromrange) (length torange)) + (error "ses-select: Ranges not same length")) + (let (result) + (dolist (x fromrange) + (if (equal test (symbol-value x)) + (push (car torange) result)) + (setq torange (cdr torange))) + (cons 'list result))) + +;;All standard formulas are safe +(dolist (x '(ses-range ses-delete-blanks ses+ ses-average ses-select)) + (put x 'side-effect-free t)) + + +;;;---------------------------------------------------------------------------- +;;;; Standard print functions +;;;---------------------------------------------------------------------------- + +;;These functions use the variables 'row' and 'col' that are +;;dynamically bound by ses-print-cell. We define these varables at +;;compile-time to make the compiler happy. +(eval-when-compile + (make-local-variable 'row) + (make-local-variable 'col) + ;;Don't use setq -- that gives a "free variable" compiler warning + (set 'row nil) + (set 'col nil)) + +(defun ses-center (value &optional span fill) + "Print VALUE, centered within column. FILL is the fill character for +centering (default = space). SPAN indicates how many additional rightward +columns to include in width (default = 0)." + (let ((printer (or (ses-col-printer col) default-printer)) + (width (ses-col-width col)) + half) + (or fill (setq fill ? )) + (or span (setq span 0)) + (setq value (ses-call-printer printer value)) + (dotimes (x span) + (setq width (+ width 1 (ses-col-width (+ col span (- x)))))) + (setq width (- width (length value))) + (if (<= width 0) + value ;Too large for field, anyway + (setq half (make-string (/ width 2) fill)) + (concat half value half + (if (> (% width 2) 0) (char-to-string fill)))))) + +(defun ses-center-span (value &optional fill) + "Print VALUE, centered within the span that starts in the current column +and continues until the next nonblank column. FILL specifies the fill +character (default = space)." + (let ((end (1+ col))) + (while (and (< end numcols) + (memq (ses-cell-value row end) '(nil *skip*))) + (setq end (1+ end))) + (ses-center value (- end col 1) fill))) + +(defun ses-dashfill (value &optional span) + "Print VALUE centered using dashes. SPAN indicates how many rightward +columns to include in width (default = 0)." + (ses-center value span ?-)) + +(defun ses-dashfill-span (value) + "Print VALUE, centered using dashes within the span that starts in the +current column and continues until the next nonblank column." + (ses-center-span value ?-)) + +(defun ses-tildefill-span (value) + "Print VALUE, centered using tildes within the span that starts in the +current column and continues until the next nonblank column." + (ses-center-span value ?~)) + +(defun ses-unsafe (value) + "Substitute for an unsafe formula or printer" + (error "Unsafe formula or printer")) + +;;All standard printers are safe, including ses-unsafe! +(dolist (x (cons 'ses-unsafe ses-standard-printer-functions)) + (put x 'side-effect-free t)) + +(provide 'ses) + +;; ses.el ends here. |