1;;; ses.el -- Simple Emacs Spreadsheet -*- coding: utf-8 -*- 2 3;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 4 5;; Author: Jonathan Yavner <jyavner@member.fsf.org> 6;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> 7;; Keywords: spreadsheet 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;;; To-do list: 29 30;; * Use $ or … for truncated fields 31;; * Add command to make a range of columns be temporarily invisible. 32;; * Allow paste of one cell to a range of cells -- copy formula to each. 33;; * Do something about control characters & octal codes in cell print 34;; areas. Use string-width? 35;; * Input validation functions. How specified? 36;; * Faces (colors & styles) in print cells. 37;; * Move a column by dragging its letter in the header line. 38;; * Left-margin column for row number. 39;; * Move a row by dragging its number in the left-margin. 40 41 42;;; Code: 43 44(require 'unsafep) 45 46 47;;---------------------------------------------------------------------------- 48;; User-customizable variables 49;;---------------------------------------------------------------------------- 50 51(defgroup ses nil 52 "Simple Emacs Spreadsheet." 53 :group 'applications 54 :prefix "ses-" 55 :version "21.1") 56 57(defcustom ses-initial-size '(1 . 1) 58 "Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)." 59 :group 'ses 60 :type '(cons (integer :tag "numrows") (integer :tag "numcols"))) 61 62(defcustom ses-initial-column-width 7 63 "Initial width of columns in a new spreadsheet." 64 :group 'ses 65 :type '(integer :match (lambda (widget value) (> value 0)))) 66 67(defcustom ses-initial-default-printer "%.7g" 68 "Initial default printer for a new spreadsheet." 69 :group 'ses 70 :type '(choice string 71 (list :tag "Parenthesized string" string) 72 function)) 73 74(defcustom ses-after-entry-functions '(forward-char) 75 "Things to do after entering a value into a cell. 76An abnormal hook that usually runs a cursor-movement function. 77Each function is called with ARG=1." 78 :group 'ses 79 :type 'hook 80 :options '(forward-char backward-char next-line previous-line)) 81 82(defcustom ses-mode-hook nil 83 "Hook functions to be run upon entering SES mode." 84 :group 'ses 85 :type 'hook) 86 87 88;;---------------------------------------------------------------------------- 89;; Global variables and constants 90;;---------------------------------------------------------------------------- 91 92(defvar ses-read-cell-history nil 93 "List of formulas that have been typed in.") 94 95(defvar ses-read-printer-history nil 96 "List of printer functions that have been typed in.") 97 98(easy-menu-define ses-header-line-menu nil 99 "Context menu when mouse-3 is used on the header-line in an SES buffer." 100 '("SES header row" 101 ["Set current row" ses-set-header-row t] 102 ["Unset row" ses-unset-header-row (> ses--header-row 0)])) 103 104(defconst ses-mode-map 105 (let ((keys `("\C-c\M-\C-l" ses-reconstruct-all 106 "\C-c\C-l" ses-recalculate-all 107 "\C-c\C-n" ses-renarrow-buffer 108 "\C-c\C-c" ses-recalculate-cell 109 "\C-c\M-\C-s" ses-sort-column 110 "\C-c\M-\C-h" ses-set-header-row 111 "\C-c\C-t" ses-truncate-cell 112 "\C-c\C-j" ses-jump 113 "\C-c\C-p" ses-read-default-printer 114 "\M-\C-l" ses-reprint-all 115 [?\S-\C-l] ses-reprint-all 116 [header-line down-mouse-3] ,ses-header-line-menu 117 [header-line mouse-2] ses-sort-column-click)) 118 (newmap (make-sparse-keymap))) 119 (while keys 120 (define-key (1value newmap) (car keys) (cadr keys)) 121 (setq keys (cddr keys))) 122 newmap) 123 "Local keymap for Simple Emacs Spreadsheet.") 124 125(easy-menu-define ses-menu ses-mode-map 126 "Menu bar menu for SES." 127 '("SES" 128 ["Insert row" ses-insert-row (ses-in-print-area)] 129 ["Delete row" ses-delete-row (ses-in-print-area)] 130 ["Insert column" ses-insert-column (ses-in-print-area)] 131 ["Delete column" ses-delete-column (ses-in-print-area)] 132 ["Set column printer" ses-read-column-printer t] 133 ["Set column width" ses-set-column-width t] 134 ["Set default printer" ses-read-default-printer t] 135 ["Jump to cell" ses-jump t] 136 ["Set cell printer" ses-read-cell-printer t] 137 ["Recalculate cell" ses-recalculate-cell t] 138 ["Truncate cell display" ses-truncate-cell t] 139 ["Export values" ses-export-tsv t] 140 ["Export formulas" ses-export-tsf t])) 141 142(defconst ses-mode-edit-map 143 (let ((keys '("\C-c\C-r" ses-insert-range 144 "\C-c\C-s" ses-insert-ses-range 145 [S-mouse-3] ses-insert-range-click 146 [C-S-mouse-3] ses-insert-ses-range-click 147 "\M-\C-i" lisp-complete-symbol)) 148 (newmap (make-sparse-keymap))) 149 (set-keymap-parent newmap minibuffer-local-map) 150 (while keys 151 (define-key newmap (pop keys) (pop keys))) 152 newmap) 153 "Local keymap for SES minibuffer cell-editing.") 154 155;Local keymap for SES print area 156(defalias 'ses-mode-print-map 157 (let ((keys '([backtab] backward-char 158 [tab] ses-forward-or-insert 159 "\C-i" ses-forward-or-insert ;Needed for ses-coverage.el? 160 "\M-o" ses-insert-column 161 "\C-o" ses-insert-row 162 "\C-m" ses-edit-cell 163 "\M-k" ses-delete-column 164 "\M-y" ses-yank-pop 165 "\C-k" ses-delete-row 166 "\C-j" ses-append-row-jump-first-column 167 "\M-h" ses-mark-row 168 "\M-H" ses-mark-column 169 "\C-d" ses-clear-cell-forward 170 "\C-?" ses-clear-cell-backward 171 "(" ses-read-cell 172 "\"" ses-read-cell 173 "'" ses-read-symbol 174 "=" ses-edit-cell 175 "j" ses-jump 176 "p" ses-read-cell-printer 177 "w" ses-set-column-width 178 "x" ses-export-keymap 179 "\M-p" ses-read-column-printer)) 180 (repl '(;;We'll replace these wherever they appear in the keymap 181 clipboard-kill-region ses-kill-override 182 end-of-line ses-end-of-line 183 kill-line ses-delete-row 184 kill-region ses-kill-override 185 open-line ses-insert-row)) 186 (numeric "0123456789.-") 187 (newmap (make-keymap))) 188 ;;Get rid of printables 189 (suppress-keymap newmap t) 190 ;;These keys insert themselves as the beginning of a numeric value 191 (dotimes (x (length numeric)) 192 (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell)) 193 ;;Override these global functions wherever they're bound 194 (while repl 195 (substitute-key-definition (car repl) (cadr repl) newmap 196 (current-global-map)) 197 (setq repl (cddr repl))) 198 ;;Apparently substitute-key-definition doesn't catch this? 199 (define-key newmap [(menu-bar) edit cut] 'ses-kill-override) 200 ;;Define our other local keys 201 (while keys 202 (define-key newmap (car keys) (cadr keys)) 203 (setq keys (cddr keys))) 204 newmap)) 205 206;;Helptext for ses-mode wants keymap as variable, not function 207(defconst ses-mode-print-map (symbol-function 'ses-mode-print-map)) 208 209;;Key map used for 'x' key. 210(defalias 'ses-export-keymap 211 (let ((map (make-sparse-keymap "SES export"))) 212 (define-key map "T" (cons " tab-formulas" 'ses-export-tsf)) 213 (define-key map "t" (cons " tab-values" 'ses-export-tsv)) 214 map)) 215 216(defconst ses-print-data-boundary "\n\014\n" 217 "Marker string denoting the boundary between print area and data area.") 218 219(defconst ses-initial-global-parameters 220 "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n" 221 "Initial contents for the three-element list at the bottom of the data area.") 222 223(defconst ses-initial-file-trailer 224 ";; Local Variables:\n;; mode: ses\n;; End:\n" 225 "Initial contents for the file-trailer area at the bottom of the file.") 226 227(defconst ses-initial-file-contents 228 (concat " \n" ;One blank cell in print area 229 ses-print-data-boundary 230 "(ses-cell A1 nil nil nil nil)\n" ;One blank cell in data area 231 "\n" ;End-of-row terminator for the one row in data area 232 "(ses-column-widths [7])\n" 233 "(ses-column-printers [nil])\n" 234 "(ses-default-printer \"%.7g\")\n" 235 "(ses-header-row 0)\n" 236 ses-initial-global-parameters 237 ses-initial-file-trailer) 238 "The initial contents of an empty spreadsheet.") 239 240(defconst ses-box-prop '(:box (:line-width 2 :style released-button)) 241 "Display properties to create a raised box for cells in the header line.") 242 243(defconst ses-standard-printer-functions 244 '(ses-center ses-center-span ses-dashfill ses-dashfill-span 245 ses-tildefill-span) 246 "List of print functions to be included in initial history of printer 247functions. None of these standard-printer functions is suitable for use as a 248column printer or a global-default printer because they invoke the column or 249default printer and then modify its output.") 250 251 252;;---------------------------------------------------------------------------- 253;; Local variables and constants 254;;---------------------------------------------------------------------------- 255 256(eval-and-compile 257 (defconst ses-localvars 258 '(ses--blank-line ses--cells ses--col-printers ses--col-widths ses--curcell 259 ses--curcell-overlay ses--default-printer ses--deferred-narrow 260 ses--deferred-recalc ses--deferred-write ses--file-format 261 ses--header-hscroll ses--header-row ses--header-string ses--linewidth 262 ses--numcols ses--numrows ses--symbolic-formulas ses--data-marker 263 ses--params-marker 264 ;;Global variables that we override 265 mode-line-process next-line-add-newlines transient-mark-mode) 266 "Buffer-local variables used by SES.")) 267 268;;When compiling, create all the buffer locals and give them values 269(eval-when-compile 270 (dolist (x ses-localvars) 271 (make-local-variable x) 272 (set x nil))) 273 274(defconst ses-paramlines-plist 275 '(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3 276 ses--header-row -2 ses--file-format 1 ses--numrows 2 277 ses--numcols 3) 278 "Offsets from 'Global parameters' line to various parameter lines in the 279data area of a spreadsheet.") 280 281 282;; 283;; "Side-effect variables". They are set in one function, altered in 284;; another as a side effect, then read back by the first, as a way of 285;; passing back more than one value. These declarations are just to make 286;; the compiler happy, and to conform to standard Emacs-Lisp practice (I 287;; think the make-local-variable trick above is cleaner). 288;; 289 290(defvar ses-relocate-return nil 291 "Set by `ses-relocate-formula' and `ses-relocate-range', read by 292`ses-relocate-all'. Set to 'delete if a cell-reference was deleted from a 293formula--so the formula needs recalculation. Set to 'range if the size of a 294`ses-range' was changed--so both the formula's value and list of dependents 295need to be recalculated.") 296 297(defvar ses-call-printer-return nil 298 "Set to t if last cell printer invoked by `ses-call-printer' requested 299left-justification of the result. Set to error-signal if ses-call-printer 300encountered an error during printing. Otherwise nil.") 301 302(defvar ses-start-time nil 303 "Time when current operation started. Used by `ses-time-check' to decide 304when to emit a progress message.") 305 306 307;;---------------------------------------------------------------------------- 308;; Macros 309;;---------------------------------------------------------------------------- 310 311(defmacro ses-get-cell (row col) 312 "Return the cell structure that stores information about cell (ROW,COL)." 313 `(aref (aref ses--cells ,row) ,col)) 314 315;; We might want to use defstruct here, but cells are explicitly used as 316;; arrays in ses-set-cell, so we'd need to fix this first. --Stef 317(defsubst ses-make-cell (&optional symbol formula printer references) 318 (vector symbol formula printer references)) 319 320(defmacro ses-cell-symbol (row &optional col) 321 "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value. (0,0) => A1." 322 `(aref ,(if col `(ses-get-cell ,row ,col) row) 0)) 323 324(defmacro ses-cell-formula (row &optional col) 325 "From a CELL or a pair (ROW,COL), get the function that computes its value." 326 `(aref ,(if col `(ses-get-cell ,row ,col) row) 1)) 327 328(defmacro ses-cell-printer (row &optional col) 329 "From a CELL or a pair (ROW,COL), get the function that prints its value." 330 `(aref ,(if col `(ses-get-cell ,row ,col) row) 2)) 331 332(defmacro ses-cell-references (row &optional col) 333 "From a CELL or a pair (ROW,COL), get the list of symbols for cells whose 334functions refer to its value." 335 `(aref ,(if col `(ses-get-cell ,row ,col) row) 3)) 336 337(defmacro ses-cell-value (row &optional col) 338 "From a CELL or a pair (ROW,COL), get the current value for that cell." 339 `(symbol-value (ses-cell-symbol ,row ,col))) 340 341(defmacro ses-col-width (col) 342 "Return the width for column COL." 343 `(aref ses--col-widths ,col)) 344 345(defmacro ses-col-printer (col) 346 "Return the default printer for column COL." 347 `(aref ses--col-printers ,col)) 348 349(defmacro ses-sym-rowcol (sym) 350 "From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0). Result 351is nil if SYM is not a symbol that names a cell." 352 `(and (symbolp ,sym) (get ,sym 'ses-cell))) 353 354(defmacro ses-cell (sym value formula printer references) 355 "Load a cell SYM from the spreadsheet file. Does not recompute VALUE from 356FORMULA, does not reprint using PRINTER, does not check REFERENCES. This is a 357macro to prevent propagate-on-load viruses. Safety-checking for FORMULA and 358PRINTER are deferred until first use." 359 (let ((rowcol (ses-sym-rowcol sym))) 360 (ses-formula-record formula) 361 (ses-printer-record printer) 362 (or (atom formula) 363 (eq safe-functions t) 364 (setq formula `(ses-safe-formula ,formula))) 365 (or (not printer) 366 (stringp printer) 367 (eq safe-functions t) 368 (setq printer `(ses-safe-printer ,printer))) 369 (aset (aref ses--cells (car rowcol)) 370 (cdr rowcol) 371 (ses-make-cell sym formula printer references))) 372 (set sym value) 373 sym) 374 375(defmacro ses-column-widths (widths) 376 "Load the vector of column widths from the spreadsheet file. This is a 377macro to prevent propagate-on-load viruses." 378 (or (and (vectorp widths) (= (length widths) ses--numcols)) 379 (error "Bad column-width vector")) 380 ;;To save time later, we also calculate the total width of each line in the 381 ;;print area (excluding the terminating newline) 382 (setq ses--col-widths widths 383 ses--linewidth (apply '+ -1 (mapcar '1+ widths)) 384 ses--blank-line (concat (make-string ses--linewidth ?\s) "\n")) 385 t) 386 387(defmacro ses-column-printers (printers) 388 "Load the vector of column printers from the spreadsheet file and checks 389them for safety. This is a macro to prevent propagate-on-load viruses." 390 (or (and (vectorp printers) (= (length printers) ses--numcols)) 391 (error "Bad column-printers vector")) 392 (dotimes (x ses--numcols) 393 (aset printers x (ses-safe-printer (aref printers x)))) 394 (setq ses--col-printers printers) 395 (mapc 'ses-printer-record printers) 396 t) 397 398(defmacro ses-default-printer (def) 399 "Load the global default printer from the spreadsheet file and checks it 400for safety. This is a macro to prevent propagate-on-load viruses." 401 (setq ses--default-printer (ses-safe-printer def)) 402 (ses-printer-record def) 403 t) 404 405(defmacro ses-header-row (row) 406 "Load the header row from the spreadsheet file and checks it 407for safety. This is a macro to prevent propagate-on-load viruses." 408 (or (and (wholenump row) (or (zerop ses--numrows) (< row ses--numrows))) 409 (error "Bad header-row")) 410 (setq ses--header-row row) 411 t) 412 413(defmacro ses-dorange (curcell &rest body) 414 "Execute BODY repeatedly, with the variables `row' and `col' set to each 415cell in the range specified by CURCELL. The range is available in the 416variables `minrow', `maxrow', `mincol', and `maxcol'." 417 (declare (indent defun) (debug (form body))) 418 (let ((cur (make-symbol "cur")) 419 (min (make-symbol "min")) 420 (max (make-symbol "max")) 421 (r (make-symbol "r")) 422 (c (make-symbol "c"))) 423 `(let* ((,cur ,curcell) 424 (,min (ses-sym-rowcol (if (consp ,cur) (car ,cur) ,cur))) 425 (,max (ses-sym-rowcol (if (consp ,cur) (cdr ,cur) ,cur)))) 426 (let ((minrow (car ,min)) 427 (maxrow (car ,max)) 428 (mincol (cdr ,min)) 429 (maxcol (cdr ,max)) 430 row col) 431 (if (or (> minrow maxrow) (> mincol maxcol)) 432 (error "Empty range")) 433 (dotimes (,r (- maxrow minrow -1)) 434 (setq row (+ ,r minrow)) 435 (dotimes (,c (- maxcol mincol -1)) 436 (setq col (+ ,c mincol)) 437 ,@body)))))) 438 439;;Support for coverage testing. 440(defmacro 1value (form) 441 "For code-coverage testing, indicate that FORM is expected to always have 442the same value." 443 form) 444(defmacro noreturn (form) 445 "For code-coverage testing, indicate that FORM will always signal an error." 446 form) 447 448 449;;---------------------------------------------------------------------------- 450;; Utility functions 451;;---------------------------------------------------------------------------- 452 453(defun ses-vector-insert (array idx new) 454 "Create a new vector which is one larger than ARRAY and has NEW inserted 455before element IDX." 456 (let* ((len (length array)) 457 (result (make-vector (1+ len) new))) 458 (dotimes (x len) 459 (aset result 460 (if (< x idx) x (1+ x)) 461 (aref array x))) 462 result)) 463 464;;Allow ARRAY to be a symbol for use in buffer-undo-list 465(defun ses-vector-delete (array idx count) 466 "Create a new vector which is a copy of ARRAY with COUNT objects removed 467starting at element IDX. ARRAY is either a vector or a symbol whose value 468is a vector--if a symbol, the new vector is assigned as the symbol's value." 469 (let* ((a (if (arrayp array) array (symbol-value array))) 470 (len (- (length a) count)) 471 (result (make-vector len nil))) 472 (dotimes (x len) 473 (aset result x (aref a (if (< x idx) x (+ x count))))) 474 (if (symbolp array) 475 (set array result)) 476 result)) 477 478(defun ses-delete-line (count) 479 "Like `kill-line', but no kill ring." 480 (let ((pos (point))) 481 (forward-line count) 482 (delete-region pos (point)))) 483 484(defun ses-printer-validate (printer) 485 "Signals an error if PRINTER is not a valid SES cell printer." 486 (or (not printer) 487 (stringp printer) 488 (functionp printer) 489 (and (stringp (car-safe printer)) (not (cdr printer))) 490 (error "Invalid printer function")) 491 printer) 492 493(defun ses-printer-record (printer) 494 "Add PRINTER to `ses-read-printer-history' if not already there, after first 495checking that it is a valid printer function." 496 (ses-printer-validate printer) 497 ;;To speed things up, we avoid calling prin1 for the very common "nil" case. 498 (if printer 499 (add-to-list 'ses-read-printer-history (prin1-to-string printer)))) 500 501(defun ses-formula-record (formula) 502 "If FORMULA is of the form 'symbol, adds it to the list of symbolic formulas 503for this spreadsheet." 504 (when (and (eq (car-safe formula) 'quote) 505 (symbolp (cadr formula))) 506 (add-to-list 'ses--symbolic-formulas 507 (list (symbol-name (cadr formula)))))) 508 509(defun ses-column-letter (col) 510 "Converts a column number to A..Z or AA..ZZ" 511 (if (< col 26) 512 (char-to-string (+ ?A col)) 513 (string (+ ?@ (/ col 26)) (+ ?A (% col 26))))) 514 515(defun ses-create-cell-symbol (row col) 516 "Produce a symbol that names the cell (ROW,COL). (0,0) => 'A1." 517 (intern (concat (ses-column-letter col) (number-to-string (1+ row))))) 518 519(defun ses-create-cell-variable-range (minrow maxrow mincol maxcol) 520 "Create buffer-local variables for cells. This is undoable." 521 (push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) 522 buffer-undo-list) 523 (let (sym xrow xcol) 524 (dotimes (row (1+ (- maxrow minrow))) 525 (dotimes (col (1+ (- maxcol mincol))) 526 (setq xrow (+ row minrow) 527 xcol (+ col mincol) 528 sym (ses-create-cell-symbol xrow xcol)) 529 (put sym 'ses-cell (cons xrow xcol)) 530 (make-local-variable sym))))) 531 532;;We do not delete the ses-cell properties for the cell-variables, in case a 533;;formula that refers to this cell is in the kill-ring and is later pasted 534;;back in. 535(defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol) 536 "Destroy buffer-local variables for cells. This is undoable." 537 (let (sym) 538 (dotimes (row (1+ (- maxrow minrow))) 539 (dotimes (col (1+ (- maxcol mincol))) 540 (setq sym (ses-create-cell-symbol (+ row minrow) (+ col mincol))) 541 (if (boundp sym) 542 (push `(apply ses-set-with-undo ,sym ,(symbol-value sym)) 543 buffer-undo-list)) 544 (kill-local-variable sym)))) 545 (push `(apply ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) 546 buffer-undo-list)) 547 548(defun ses-reset-header-string () 549 "Flags the header string for update. Upon undo, the header string will be 550updated again." 551 (push '(apply ses-reset-header-string) buffer-undo-list) 552 (setq ses--header-hscroll -1)) 553 554;;Split this code off into a function to avoid coverage-testing difficulties 555(defun ses-time-check (format arg) 556 "If `ses-start-time' is more than a second ago, call `message' with FORMAT 557and (eval ARG) and reset `ses-start-time' to the current time." 558 (when (> (- (float-time) ses-start-time) 1.0) 559 (message format (eval arg)) 560 (setq ses-start-time (float-time))) 561 nil) 562 563 564;;---------------------------------------------------------------------------- 565;; The cells 566;;---------------------------------------------------------------------------- 567 568(defun ses-set-cell (row col field val) 569 "Install VAL as the contents for field FIELD (named by a quoted symbol) of 570cell (ROW,COL). This is undoable. The cell's data will be updated through 571`post-command-hook'." 572 (let ((cell (ses-get-cell row col)) 573 (elt (plist-get '(value t symbol 0 formula 1 printer 2 references 3) 574 field)) 575 change) 576 (or elt (signal 'args-out-of-range nil)) 577 (setq change (if (eq elt t) 578 (ses-set-with-undo (ses-cell-symbol cell) val) 579 (ses-aset-with-undo cell elt val))) 580 (if change 581 (add-to-list 'ses--deferred-write (cons row col)))) 582 nil) ;Make coverage-tester happy 583 584(defun ses-cell-set-formula (row col formula) 585 "Store a new formula for (ROW . COL) and enqueues the cell for 586recalculation via `post-command-hook'. Updates the reference lists for the 587cells that this cell refers to. Does not update cell value or reprint the 588cell. To avoid inconsistencies, this function is not interruptible, which 589means Emacs will crash if FORMULA contains a circular list." 590 (let* ((cell (ses-get-cell row col)) 591 (old (ses-cell-formula cell))) 592 (let ((sym (ses-cell-symbol cell)) 593 (oldref (ses-formula-references old)) 594 (newref (ses-formula-references formula)) 595 (inhibit-quit t) 596 x xrow xcol) 597 (add-to-list 'ses--deferred-recalc sym) 598 ;;Delete old references from this cell. Skip the ones that are also 599 ;;in the new list. 600 (dolist (ref oldref) 601 (unless (memq ref newref) 602 (setq x (ses-sym-rowcol ref) 603 xrow (car x) 604 xcol (cdr x)) 605 (ses-set-cell xrow xcol 'references 606 (delq sym (ses-cell-references xrow xcol))))) 607 ;;Add new ones. Skip ones left over from old list 608 (dolist (ref newref) 609 (setq x (ses-sym-rowcol ref) 610 xrow (car x) 611 xcol (cdr x) 612 x (ses-cell-references xrow xcol)) 613 (or (memq sym x) 614 (ses-set-cell xrow xcol 'references (cons sym x)))) 615 (ses-formula-record formula) 616 (ses-set-cell row col 'formula formula)))) 617 618(defun ses-calculate-cell (row col force) 619 "Calculate and print the value for cell (ROW,COL) using the cell's formula 620function and print functions, if any. Result is nil for normal operation, or 621the error signal if the formula or print function failed. The old value is 622left unchanged if it was *skip* and the new value is nil. 623 Any cells that depend on this cell are queued for update after the end of 624processing for the current keystroke, unless the new value is the same as 625the old and FORCE is nil." 626 (let ((cell (ses-get-cell row col)) 627 formula-error printer-error) 628 (let ((oldval (ses-cell-value cell)) 629 (formula (ses-cell-formula cell)) 630 newval) 631 (if (eq (car-safe formula) 'ses-safe-formula) 632 (ses-set-cell row col 'formula (ses-safe-formula (cadr formula)))) 633 (condition-case sig 634 (setq newval (eval formula)) 635 (error 636 (setq formula-error sig 637 newval '*error*))) 638 (if (and (not newval) (eq oldval '*skip*)) 639 ;;Don't lose the *skip* - previous field spans this one 640 (setq newval '*skip*)) 641 (when (or force (not (eq newval oldval))) 642 (add-to-list 'ses--deferred-write (cons row col)) ;In case force=t 643 (ses-set-cell row col 'value newval) 644 (dolist (ref (ses-cell-references cell)) 645 (add-to-list 'ses--deferred-recalc ref)))) 646 (setq printer-error (ses-print-cell row col)) 647 (or formula-error printer-error))) 648 649(defun ses-clear-cell (row col) 650 "Delete formula and printer for cell (ROW,COL)." 651 (ses-set-cell row col 'printer nil) 652 (ses-cell-set-formula row col nil)) 653 654(defun ses-update-cells (list &optional force) 655 "Recalculate cells in LIST, checking for dependency loops. Prints 656progress messages every second. Dependent cells are not recalculated 657if the cell's value is unchanged and FORCE is nil." 658 (let ((ses--deferred-recalc list) 659 (nextlist list) 660 (pos (point)) 661 curlist prevlist rowcol formula) 662 (with-temp-message " " 663 (while (and ses--deferred-recalc (not (equal nextlist prevlist))) 664 ;;In each loop, recalculate cells that refer only to other cells that 665 ;;have already been recalculated or aren't in the recalculation 666 ;;region. Repeat until all cells have been processed or until the 667 ;;set of cells being worked on stops changing. 668 (if prevlist 669 (message "Recalculating... (%d cells left)" 670 (length ses--deferred-recalc))) 671 (setq curlist ses--deferred-recalc 672 ses--deferred-recalc nil 673 prevlist nextlist) 674 (while curlist 675 (setq rowcol (ses-sym-rowcol (car curlist)) 676 formula (ses-cell-formula (car rowcol) (cdr rowcol))) 677 (or (catch 'ref 678 (dolist (ref (ses-formula-references formula)) 679 (when (or (memq ref curlist) 680 (memq ref ses--deferred-recalc)) 681 ;;This cell refers to another that isn't done yet 682 (add-to-list 'ses--deferred-recalc (car curlist)) 683 (throw 'ref t)))) 684 ;;ses-update-cells is called from post-command-hook, so 685 ;;inhibit-quit is implicitly bound to t. 686 (when quit-flag 687 ;;Abort the recalculation. User will probably undo now. 688 (error "Quit")) 689 (ses-calculate-cell (car rowcol) (cdr rowcol) force)) 690 (setq curlist (cdr curlist))) 691 (dolist (ref ses--deferred-recalc) 692 (add-to-list 'nextlist ref)) 693 (setq nextlist (sort (copy-sequence nextlist) 'string<)) 694 (if (equal nextlist prevlist) 695 ;;We'll go around the loop one more time. 696 (add-to-list 'nextlist t))) 697 (when ses--deferred-recalc 698 ;;Just couldn't finish these 699 (dolist (x ses--deferred-recalc) 700 (let ((rowcol (ses-sym-rowcol x))) 701 (ses-set-cell (car rowcol) (cdr rowcol) 'value '*error*) 702 (1value (ses-print-cell (car rowcol) (cdr rowcol))))) 703 (error "Circular references: %s" ses--deferred-recalc)) 704 (message " ")) 705 ;;Can't use save-excursion here: if the cell under point is 706 ;;updated, save-excusion's marker will move past the cell. 707 (goto-char pos))) 708 709 710;;---------------------------------------------------------------------------- 711;; The print area 712;;---------------------------------------------------------------------------- 713 714(defun ses-in-print-area () 715 "Returns t if point is in print area of spreadsheet." 716 (<= (point) ses--data-marker)) 717 718;;We turn off point-motion-hooks and explicitly position the cursor, in case 719;;the intangible properties have gotten screwed up (e.g., when 720;;ses-goto-print is called during a recursive ses-print-cell). 721(defun ses-goto-print (row col) 722 "Move point to print area for cell (ROW,COL)." 723 (let ((inhibit-point-motion-hooks t)) 724 (goto-char (point-min)) 725 (forward-line row) 726 (dotimes (c col) 727 (forward-char (1+ (ses-col-width c)))))) 728 729(defun ses-set-curcell () 730 "Sets `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a 731region, or nil if cursor is not at a cell." 732 (if (or (not mark-active) 733 deactivate-mark 734 (= (region-beginning) (region-end))) 735 ;;Single cell 736 (setq ses--curcell (get-text-property (point) 'intangible)) 737 ;;Range 738 (let ((bcell (get-text-property (region-beginning) 'intangible)) 739 (ecell (get-text-property (1- (region-end)) 'intangible))) 740 (setq ses--curcell (if (and bcell ecell) 741 (cons bcell ecell) 742 nil)))) 743 nil) 744 745(defun ses-check-curcell (&rest args) 746 "Signal an error if ses--curcell is inappropriate. The end marker is 747appropriate if some argument is 'end. A range is appropriate if some 748argument is 'range. A single cell is appropriate unless some argument is 749'needrange." 750 (if (eq ses--curcell t) 751 ;;curcell recalculation was postponed, but user typed ahead 752 (ses-set-curcell)) 753 (cond 754 ((not ses--curcell) 755 (or (memq 'end args) 756 (error "Not at cell"))) 757 ((consp ses--curcell) 758 (or (memq 'range args) 759 (memq 'needrange args) 760 (error "Can't use a range"))) 761 ((memq 'needrange args) 762 (error "Need a range")))) 763 764(defun ses-print-cell (row col) 765 "Format and print the value of cell (ROW,COL) to the print area. 766Use the cell's printer function. If the cell's new print form is too wide, 767it will spill over into the following cell, but will not run off the end of the 768row or overwrite the next non-nil field. Result is nil for normal operation, 769or the error signal if the printer function failed and the cell was formatted 770with \"%s\". If the cell's value is *skip*, nothing is printed because the 771preceding cell has spilled over." 772 (catch 'ses-print-cell 773 (let* ((cell (ses-get-cell row col)) 774 (value (ses-cell-value cell)) 775 (printer (ses-cell-printer cell)) 776 (maxcol (1+ col)) 777 text sig startpos x) 778 ;;Create the string to print 779 (cond 780 ((eq value '*skip*) 781 ;;Don't print anything 782 (throw 'ses-print-cell nil)) 783 ((eq value '*error*) 784 (setq text (make-string (ses-col-width col) ?#))) 785 (t 786 ;;Deferred safety-check on printer 787 (if (eq (car-safe printer) 'ses-safe-printer) 788 (ses-set-cell row col 'printer 789 (setq printer (ses-safe-printer (cadr printer))))) 790 ;;Print the value 791 (setq text (ses-call-printer (or printer 792 (ses-col-printer col) 793 ses--default-printer) 794 value)) 795 (if (consp ses-call-printer-return) 796 ;;Printer returned an error 797 (setq sig ses-call-printer-return)))) 798 ;;Adjust print width to match column width 799 (let ((width (ses-col-width col)) 800 (len (length text))) 801 (cond 802 ((< len width) 803 ;;Fill field to length with spaces 804 (setq len (make-string (- width len) ?\s) 805 text (if (eq ses-call-printer-return t) 806 (concat text len) 807 (concat len text)))) 808 ((> len width) 809 ;;Spill over into following cells, if possible 810 (let ((maxwidth width)) 811 (while (and (> len maxwidth) 812 (< maxcol ses--numcols) 813 (or (not (setq x (ses-cell-value row maxcol))) 814 (eq x '*skip*))) 815 (unless x 816 ;;Set this cell to '*skip* so it won't overwrite our spillover 817 (ses-set-cell row maxcol 'value '*skip*)) 818 (setq maxwidth (+ maxwidth (ses-col-width maxcol) 1) 819 maxcol (1+ maxcol))) 820 (if (<= len maxwidth) 821 ;;Fill to complete width of all the fields spanned 822 (setq text (concat text (make-string (- maxwidth len) ?\s))) 823 ;;Not enough room to end of line or next non-nil field. Truncate 824 ;;if string or decimal; otherwise fill with error indicator 825 (setq sig `(error "Too wide" ,text)) 826 (cond 827 ((stringp value) 828 (setq text (substring text 0 maxwidth))) 829 ((and (numberp value) 830 (string-match "\\.[0-9]+" text) 831 (>= 0 (setq width 832 (- len maxwidth 833 (- (match-end 0) (match-beginning 0)))))) 834 ;; Turn 6.6666666666e+49 into 6.66e+49. Rounding is too hard! 835 (setq text (concat (substring text 836 0 837 (- (match-beginning 0) width)) 838 (substring text (match-end 0))))) 839 (t 840 (setq text (make-string maxwidth ?#))))))))) 841 ;;Substitute question marks for tabs and newlines. Newlines are 842 ;;used as row-separators; tabs could confuse the reimport logic. 843 (setq text (replace-regexp-in-string "[\t\n]" "?" text)) 844 (ses-goto-print row col) 845 (setq startpos (point)) 846 ;;Install the printed result. This is not interruptible. 847 (let ((inhibit-read-only t) 848 (inhibit-quit t)) 849 (delete-char (1+ (length text))) 850 ;;We use concat instead of inserting separate strings in order to 851 ;;reduce the number of cells in the undo list. 852 (setq x (concat text (if (< maxcol ses--numcols) " " "\n"))) 853 ;;We use set-text-properties to prevent a wacky print function 854 ;;from inserting rogue properties, and to ensure that the keymap 855 ;;property is inherited (is it a bug that only unpropertied strings 856 ;;actually inherit from surrounding text?) 857 (set-text-properties 0 (length x) nil x) 858 (insert-and-inherit x) 859 (put-text-property startpos (point) 'intangible 860 (ses-cell-symbol cell)) 861 (when (and (zerop row) (zerop col)) 862 ;;Reconstruct special beginning-of-buffer attributes 863 (put-text-property (point-min) (point) 'keymap 'ses-mode-print-map) 864 (put-text-property (point-min) (point) 'read-only 'ses) 865 (put-text-property (point-min) (1+ (point-min)) 'front-sticky t))) 866 (if (= row (1- ses--header-row)) 867 ;;This line is part of the header - force recalc 868 (ses-reset-header-string)) 869 ;;If this cell (or a preceding one on the line) previously spilled over 870 ;;and has gotten shorter, redraw following cells on line recursively. 871 (when (and (< maxcol ses--numcols) 872 (eq (ses-cell-value row maxcol) '*skip*)) 873 (ses-set-cell row maxcol 'value nil) 874 (ses-print-cell row maxcol)) 875 ;;Return to start of cell 876 (goto-char startpos) 877 sig))) 878 879(defun ses-call-printer (printer &optional value) 880 "Invokes PRINTER (a string or parenthesized string or function-symbol or 881lambda of one argument) on VALUE. Result is the the printed cell as a 882string. The variable `ses-call-printer-return' is set to t if the printer 883used parenthesis to request left-justification, or the error-signal if the 884printer signaled one (and \"%s\" is used as the default printer), else nil." 885 (setq ses-call-printer-return nil) 886 (unless value 887 (setq value "")) 888 (condition-case signal 889 (cond 890 ((stringp printer) 891 (format printer value)) 892 ((stringp (car-safe printer)) 893 (setq ses-call-printer-return t) 894 (format (car printer) value)) 895 (t 896 (setq value (funcall printer value)) 897 (if (stringp value) 898 value 899 (or (stringp (car-safe value)) 900 (error "Printer should return \"string\" or (\"string\")")) 901 (setq ses-call-printer-return t) 902 (car value)))) 903 (error 904 (setq ses-call-printer-return signal) 905 (prin1-to-string value t)))) 906 907(defun ses-adjust-print-width (col change) 908 "Insert CHANGE spaces in front of column COL, or at end of line if 909COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind 910inhibit-quit to t." 911 (let ((inhibit-read-only t) 912 (blank (if (> change 0) (make-string change ?\s))) 913 (at-end (= col ses--numcols))) 914 (ses-set-with-undo 'ses--linewidth (+ ses--linewidth change)) 915 ;;ses-set-with-undo always returns t for strings. 916 (1value (ses-set-with-undo 'ses--blank-line 917 (concat (make-string ses--linewidth ?\s) "\n"))) 918 (dotimes (row ses--numrows) 919 (ses-goto-print row col) 920 (when at-end 921 ;;Insert new columns before newline 922 (let ((inhibit-point-motion-hooks t)) 923 (backward-char 1))) 924 (if blank 925 (insert blank) 926 (delete-char (- change)))))) 927 928(defun ses-print-cell-new-width (row col) 929 "Same as ses-print-cell, except if the cell's value is *skip*, the preceding 930nonskipped cell is reprinted. This function is used when the width of 931cell (ROW,COL) has changed." 932 (if (not (eq (ses-cell-value row col) '*skip*)) 933 (ses-print-cell row col) 934 ;;Cell was skipped over - reprint previous 935 (ses-goto-print row col) 936 (backward-char 1) 937 (let ((rowcol (ses-sym-rowcol (get-text-property (point) 'intangible)))) 938 (ses-print-cell (car rowcol) (cdr rowcol))))) 939 940 941;;---------------------------------------------------------------------------- 942;; The data area 943;;---------------------------------------------------------------------------- 944 945(defun ses-narrowed-p () (/= (- (point-max) (point-min)) (buffer-size))) 946 947(defun ses-widen () 948 "Turn off narrowing, to be reenabled at end of command loop." 949 (if (ses-narrowed-p) 950 (setq ses--deferred-narrow t)) 951 (widen)) 952 953(defun ses-goto-data (def &optional col) 954 "Move point to data area for (DEF,COL). If DEF is a row 955number, COL is the column number for a data cell -- otherwise DEF 956is one of the symbols ses--col-widths, ses--col-printers, 957ses--default-printer, ses--numrows, or ses--numcols." 958 (ses-widen) 959 (let ((inhibit-point-motion-hooks t)) ;In case intangible attrs are wrong 960 (if col 961 ;;It's a cell 962 (progn 963 (goto-char ses--data-marker) 964 (forward-line (+ 1 (* def (1+ ses--numcols)) col))) 965 ;;Convert def-symbol to offset 966 (setq def (plist-get ses-paramlines-plist def)) 967 (or def (signal 'args-out-of-range nil)) 968 (goto-char ses--params-marker) 969 (forward-line def)))) 970 971(defun ses-set-parameter (def value &optional elem) 972 "Set parameter DEF to VALUE (with undo) and write the value to the data area. 973See `ses-goto-data' for meaning of DEF. Newlines in the data are escaped. 974If ELEM is specified, it is the array subscript within DEF to be set to VALUE." 975 (save-excursion 976 ;;We call ses-goto-data early, using the old values of numrows and 977 ;;numcols in case one of them is being changed. 978 (ses-goto-data def) 979 (let ((inhibit-read-only t) 980 (fmt (plist-get '(ses--col-widths "(ses-column-widths %S)" 981 ses--col-printers "(ses-column-printers %S)" 982 ses--default-printer "(ses-default-printer %S)" 983 ses--header-row "(ses-header-row %S)" 984 ses--file-format " %S ;SES file-format" 985 ses--numrows " %S ;numrows" 986 ses--numcols " %S ;numcols") 987 def)) 988 oldval) 989 (if elem 990 (progn 991 (setq oldval (aref (symbol-value def) elem)) 992 (aset (symbol-value def) elem value)) 993 (setq oldval (symbol-value def)) 994 (set def value)) 995 ;;Special undo since it's outside the narrowed buffer 996 (let (buffer-undo-list) 997 (delete-region (point) (line-end-position)) 998 (insert (format fmt (symbol-value def)))) 999 (push `(apply ses-set-parameter ,def ,oldval ,elem) buffer-undo-list)))) 1000 1001 1002(defun ses-write-cells () 1003 "Write cells in `ses--deferred-write' from local variables to data area. 1004Newlines in the data are escaped." 1005 (let* ((inhibit-read-only t) 1006 (print-escape-newlines t) 1007 rowcol row col cell sym formula printer text) 1008 (setq ses-start-time (float-time)) 1009 (with-temp-message " " 1010 (save-excursion 1011 (while ses--deferred-write 1012 (ses-time-check "Writing... (%d cells left)" 1013 '(length ses--deferred-write)) 1014 (setq rowcol (pop ses--deferred-write) 1015 row (car rowcol) 1016 col (cdr rowcol) 1017 cell (ses-get-cell row col) 1018 sym (ses-cell-symbol cell) 1019 formula (ses-cell-formula cell) 1020 printer (ses-cell-printer cell)) 1021 (if (eq (car-safe formula) 'ses-safe-formula) 1022 (setq formula (cadr formula))) 1023 (if (eq (car-safe printer) 'ses-safe-printer) 1024 (setq printer (cadr printer))) 1025 ;;This is noticably faster than (format "%S %S %S %S %S") 1026 (setq text (concat "(ses-cell " 1027 (symbol-name sym) 1028 " " 1029 (prin1-to-string (symbol-value sym)) 1030 " " 1031 (prin1-to-string formula) 1032 " " 1033 (prin1-to-string printer) 1034 " " 1035 (if (atom (ses-cell-references cell)) 1036 "nil" 1037 (concat "(" 1038 (mapconcat 'symbol-name 1039 (ses-cell-references cell) 1040 " ") 1041 ")")) 1042 ")")) 1043 (ses-goto-data row col) 1044 (delete-region (point) (line-end-position)) 1045 (insert text))) 1046 (message " ")))) 1047 1048 1049;;---------------------------------------------------------------------------- 1050;; Formula relocation 1051;;---------------------------------------------------------------------------- 1052 1053(defun ses-formula-references (formula &optional result-so-far) 1054 "Produce a list of symbols for cells that this formula's value 1055refers to. For recursive calls, RESULT-SO-FAR is the list being constructed, 1056or t to get a wrong-type-argument error when the first reference is found." 1057 (if (atom formula) 1058 (if (ses-sym-rowcol formula) 1059 ;;Entire formula is one symbol 1060 (add-to-list 'result-so-far formula) 1061 ) ;;Ignore other atoms 1062 (dolist (cur formula) 1063 (cond 1064 ((ses-sym-rowcol cur) 1065 ;;Save this reference 1066 (add-to-list 'result-so-far cur)) 1067 ((eq (car-safe cur) 'ses-range) 1068 ;;All symbols in range are referenced 1069 (dolist (x (cdr (macroexpand cur))) 1070 (add-to-list 'result-so-far x))) 1071 ((and (consp cur) (not (eq (car cur) 'quote))) 1072 ;;Recursive call for subformulas 1073 (setq result-so-far (ses-formula-references cur result-so-far))) 1074 (t 1075 ;;Ignore other stuff 1076 )))) 1077 result-so-far) 1078 1079(defsubst ses-relocate-symbol (sym rowcol startrow startcol rowincr colincr) 1080 "Relocate one symbol SYM, whichs corresponds to ROWCOL (a cons of ROW and 1081COL). Cells starting at (STARTROW,STARTCOL) are being shifted 1082by (ROWINCR,COLINCR)." 1083 (let ((row (car rowcol)) 1084 (col (cdr rowcol))) 1085 (if (or (< row startrow) (< col startcol)) 1086 sym 1087 (setq row (+ row rowincr) 1088 col (+ col colincr)) 1089 (if (and (>= row startrow) (>= col startcol) 1090 (< row ses--numrows) (< col ses--numcols)) 1091 ;;Relocate this variable 1092 (ses-create-cell-symbol row col) 1093 ;;Delete reference to a deleted cell 1094 nil)))) 1095 1096(defun ses-relocate-formula (formula startrow startcol rowincr colincr) 1097 "Produce a copy of FORMULA where all symbols that refer to cells in row 1098STARTROW or above and col STARTCOL or above are altered by adding ROWINCR 1099and COLINCR. STARTROW and STARTCOL are 0-based. Example: 1100 (ses-relocate-formula '(+ A1 B2 D3) 1 2 1 -1) 1101 => (+ A1 B2 C4) 1102If ROWINCR or COLINCR is negative, references to cells being deleted are 1103removed. Example: 1104 (ses-relocate-formula '(+ A1 B2 D3) 0 1 0 -1) 1105 => (+ A1 C3) 1106Sets `ses-relocate-return' to 'delete if cell-references were removed." 1107 (let (rowcol result) 1108 (if (or (atom formula) (eq (car formula) 'quote)) 1109 (if (setq rowcol (ses-sym-rowcol formula)) 1110 (ses-relocate-symbol formula rowcol 1111 startrow startcol rowincr colincr) 1112 formula) ;Pass through as-is 1113 (dolist (cur formula) 1114 (setq rowcol (ses-sym-rowcol cur)) 1115 (cond 1116 (rowcol 1117 (setq cur (ses-relocate-symbol cur rowcol 1118 startrow startcol rowincr colincr)) 1119 (if cur 1120 (push cur result) 1121 ;;Reference to a deleted cell. Set a flag in ses-relocate-return. 1122 ;;don't change the flag if it's already 'range, since range 1123 ;;implies 'delete. 1124 (unless ses-relocate-return 1125 (setq ses-relocate-return 'delete)))) 1126 ((eq (car-safe cur) 'ses-range) 1127 (setq cur (ses-relocate-range cur startrow startcol rowincr colincr)) 1128 (if cur 1129 (push cur result))) 1130 ((or (atom cur) (eq (car cur) 'quote)) 1131 ;;Constants pass through unchanged 1132 (push cur result)) 1133 (t 1134 ;;Recursively copy and alter subformulas 1135 (push (ses-relocate-formula cur startrow startcol 1136 rowincr colincr) 1137 result)))) 1138 (nreverse result)))) 1139 1140(defun ses-relocate-range (range startrow startcol rowincr colincr) 1141 "Relocate one RANGE, of the form '(ses-range min max). Cells starting 1142at (STARTROW,STARTCOL) are being shifted by (ROWINCR,COLINCR). Result is the 1143new range, or nil if the entire range is deleted. If new rows are being added 1144just beyond the end of a row range, or new columns just beyond a column range, 1145the new rows/columns will be added to the range. Sets `ses-relocate-return' 1146if the range was altered." 1147 (let* ((minorig (cadr range)) 1148 (minrowcol (ses-sym-rowcol minorig)) 1149 (min (ses-relocate-symbol minorig minrowcol 1150 startrow startcol 1151 rowincr colincr)) 1152 (maxorig (nth 2 range)) 1153 (maxrowcol (ses-sym-rowcol maxorig)) 1154 (max (ses-relocate-symbol maxorig maxrowcol 1155 startrow startcol 1156 rowincr colincr)) 1157 field) 1158 (cond 1159 ((and (not min) (not max)) 1160 (setq range nil)) ;;The entire range is deleted 1161 ((zerop colincr) 1162 ;;Inserting or deleting rows 1163 (setq field 'car) 1164 (if (not min) 1165 ;;Chopped off beginning of range 1166 (setq min (ses-create-cell-symbol startrow (cdr minrowcol)) 1167 ses-relocate-return 'range)) 1168 (if (not max) 1169 (if (> rowincr 0) 1170 ;;Trying to insert a nonexistent row 1171 (setq max (ses-create-cell-symbol (1- ses--numrows) 1172 (cdr minrowcol))) 1173 ;;End of range is being deleted 1174 (setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol)) 1175 ses-relocate-return 'range)) 1176 (and (> rowincr 0) 1177 (= (car maxrowcol) (1- startrow)) 1178 (= (cdr minrowcol) (cdr maxrowcol)) 1179 ;;Insert after ending row of vertical range - include it 1180 (setq max (ses-create-cell-symbol (+ startrow rowincr -1) 1181 (cdr maxrowcol)))))) 1182 (t 1183 ;;Inserting or deleting columns 1184 (setq field 'cdr) 1185 (if (not min) 1186 ;;Chopped off beginning of range 1187 (setq min (ses-create-cell-symbol (car minrowcol) startcol) 1188 ses-relocate-return 'range)) 1189 (if (not max) 1190 (if (> colincr 0) 1191 ;;Trying to insert a nonexistent column 1192 (setq max (ses-create-cell-symbol (car maxrowcol) 1193 (1- ses--numcols))) 1194 ;;End of range is being deleted 1195 (setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol)) 1196 ses-relocate-return 'range)) 1197 (and (> colincr 0) 1198 (= (cdr maxrowcol) (1- startcol)) 1199 (= (car minrowcol) (car maxrowcol)) 1200 ;;Insert after ending column of horizontal range - include it 1201 (setq max (ses-create-cell-symbol (car maxrowcol) 1202 (+ startcol colincr -1))))))) 1203 (when range 1204 (if (/= (- (funcall field maxrowcol) 1205 (funcall field minrowcol)) 1206 (- (funcall field (ses-sym-rowcol max)) 1207 (funcall field (ses-sym-rowcol min)))) 1208 ;;This range has changed size 1209 (setq ses-relocate-return 'range)) 1210 (list 'ses-range min max)))) 1211 1212(defun ses-relocate-all (minrow mincol rowincr colincr) 1213 "Alter all cell values, symbols, formulas, and reference-lists to relocate 1214the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR 1215to each symbol." 1216 (let (reform) 1217 (let (mycell newval) 1218 (dotimes-with-progress-reporter 1219 (row ses--numrows) "Relocating formulas..." 1220 (dotimes (col ses--numcols) 1221 (setq ses-relocate-return nil 1222 mycell (ses-get-cell row col) 1223 newval (ses-relocate-formula (ses-cell-formula mycell) 1224 minrow mincol rowincr colincr)) 1225 (ses-set-cell row col 'formula newval) 1226 (if (eq ses-relocate-return 'range) 1227 ;;This cell contains a (ses-range X Y) where a cell has been 1228 ;;inserted or deleted in the middle of the range. 1229 (push (cons row col) reform)) 1230 (if ses-relocate-return 1231 ;;This cell referred to a cell that's been deleted or is no 1232 ;;longer part of the range. We can't fix that now because 1233 ;;reference lists cells have been partially updated. 1234 (add-to-list 'ses--deferred-recalc 1235 (ses-create-cell-symbol row col))) 1236 (setq newval (ses-relocate-formula (ses-cell-references mycell) 1237 minrow mincol rowincr colincr)) 1238 (ses-set-cell row col 'references newval) 1239 (and (>= row minrow) (>= col mincol) 1240 (ses-set-cell row col 'symbol 1241 (ses-create-cell-symbol row col)))))) 1242 ;;Relocate the cell values 1243 (let (oldval myrow mycol xrow xcol) 1244 (cond 1245 ((and (<= rowincr 0) (<= colincr 0)) 1246 ;;Deletion of rows and/or columns 1247 (dotimes-with-progress-reporter 1248 (row (- ses--numrows minrow)) "Relocating variables..." 1249 (setq myrow (+ row minrow)) 1250 (dotimes (col (- ses--numcols mincol)) 1251 (setq mycol (+ col mincol) 1252 xrow (- myrow rowincr) 1253 xcol (- mycol colincr)) 1254 (if (and (< xrow ses--numrows) (< xcol ses--numcols)) 1255 (setq oldval (ses-cell-value xrow xcol)) 1256 ;;Cell is off the end of the array 1257 (setq oldval (symbol-value (ses-create-cell-symbol xrow xcol)))) 1258 (ses-set-cell myrow mycol 'value oldval)))) 1259 ((and (wholenump rowincr) (wholenump colincr)) 1260 ;;Insertion of rows and/or columns. Run the loop backwards. 1261 (let ((disty (1- ses--numrows)) 1262 (distx (1- ses--numcols)) 1263 myrow mycol) 1264 (dotimes-with-progress-reporter 1265 (row (- ses--numrows minrow)) "Relocating variables..." 1266 (setq myrow (- disty row)) 1267 (dotimes (col (- ses--numcols mincol)) 1268 (setq mycol (- distx col) 1269 xrow (- myrow rowincr) 1270 xcol (- mycol colincr)) 1271 (if (or (< xrow minrow) (< xcol mincol)) 1272 ;;Newly-inserted value 1273 (setq oldval nil) 1274 ;;Transfer old value 1275 (setq oldval (ses-cell-value xrow xcol))) 1276 (ses-set-cell myrow mycol 'value oldval))) 1277 t)) ;Make testcover happy by returning non-nil here 1278 (t 1279 (error "ROWINCR and COLINCR must have the same sign")))) 1280 ;;Reconstruct reference lists for cells that contain ses-ranges that 1281 ;;have changed size. 1282 (when reform 1283 (message "Fixing ses-ranges...") 1284 (let (row col) 1285 (setq ses-start-time (float-time)) 1286 (while reform 1287 (ses-time-check "Fixing ses-ranges... (%d left)" '(length reform)) 1288 (setq row (caar reform) 1289 col (cdar reform) 1290 reform (cdr reform)) 1291 (ses-cell-set-formula row col (ses-cell-formula row col)))) 1292 (message nil)))) 1293 1294 1295;;---------------------------------------------------------------------------- 1296;; Undo control 1297;;---------------------------------------------------------------------------- 1298 1299(defun ses-begin-change () 1300 "For undo, remember point before we start changing hidden stuff." 1301 (let ((inhibit-read-only t)) 1302 (insert-and-inherit "X") 1303 (delete-region (1- (point)) (point)))) 1304 1305(defun ses-set-with-undo (sym newval) 1306 "Like set, but undoable. Result is t if value has changed." 1307 ;;We try to avoid adding redundant entries to the undo list, but this is 1308 ;;unavoidable for strings because equal ignores text properties and there's 1309 ;;no easy way to get the whole property list to see if it's different! 1310 (unless (and (boundp sym) 1311 (equal (symbol-value sym) newval) 1312 (not (stringp newval))) 1313 (push (if (boundp sym) 1314 `(apply ses-set-with-undo ,sym ,(symbol-value sym)) 1315 `(apply ses-unset-with-undo ,sym)) 1316 buffer-undo-list) 1317 (set sym newval) 1318 t)) 1319 1320(defun ses-unset-with-undo (sym) 1321 "Set SYM to be unbound. This is undoable." 1322 (when (1value (boundp sym)) ;;Always bound, except after a programming error 1323 (push `(apply ses-set-with-undo ,sym ,(symbol-value sym)) buffer-undo-list) 1324 (makunbound sym))) 1325 1326(defun ses-aset-with-undo (array idx newval) 1327 "Like aset, but undoable. Result is t if element has changed" 1328 (unless (equal (aref array idx) newval) 1329 (push `(apply ses-aset-with-undo ,array ,idx ,(aref array idx)) buffer-undo-list) 1330 (aset array idx newval) 1331 t)) 1332 1333 1334;;---------------------------------------------------------------------------- 1335;; Startup for major mode 1336;;---------------------------------------------------------------------------- 1337 1338(defun ses-load () 1339 "Parse the current buffer and sets up buffer-local variables. Does not 1340execute cell formulas or print functions." 1341 (widen) 1342 ;;Read our global parameters, which should be a 3-element list 1343 (goto-char (point-max)) 1344 (search-backward ";; Local Variables:\n" nil t) 1345 (backward-list 1) 1346 (setq ses--params-marker (point-marker)) 1347 (let ((params (condition-case nil (read (current-buffer)) (error nil)))) 1348 (or (and (= (safe-length params) 3) 1349 (numberp (car params)) 1350 (numberp (cadr params)) 1351 (>= (cadr params) 0) 1352 (numberp (nth 2 params)) 1353 (> (nth 2 params) 0)) 1354 (error "Invalid SES file")) 1355 (setq ses--file-format (car params) 1356 ses--numrows (cadr params) 1357 ses--numcols (nth 2 params)) 1358 (when (= ses--file-format 1) 1359 (let (buffer-undo-list) ;This is not undoable 1360 (ses-goto-data 'ses--header-row) 1361 (insert "(ses-header-row 0)\n") 1362 (ses-set-parameter 'ses--file-format 2) 1363 (message "Upgrading from SES-1 file format"))) 1364 (or (= ses--file-format 2) 1365 (error "This file needs a newer version of the SES library code")) 1366 (ses-create-cell-variable-range 0 (1- ses--numrows) 0 (1- ses--numcols)) 1367 ;;Initialize cell array 1368 (setq ses--cells (make-vector ses--numrows nil)) 1369 (dotimes (row ses--numrows) 1370 (aset ses--cells row (make-vector ses--numcols nil)))) 1371 ;;Skip over print area, which we assume is correct 1372 (goto-char (point-min)) 1373 (forward-line ses--numrows) 1374 (or (looking-at ses-print-data-boundary) 1375 (error "Missing marker between print and data areas")) 1376 (forward-char 1) 1377 (setq ses--data-marker (point-marker)) 1378 (forward-char (1- (length ses-print-data-boundary))) 1379 ;;Initialize printer and symbol lists 1380 (mapc 'ses-printer-record ses-standard-printer-functions) 1381 (setq ses--symbolic-formulas nil) 1382 ;;Load cell definitions 1383 (dotimes (row ses--numrows) 1384 (dotimes (col ses--numcols) 1385 (let* ((x (read (current-buffer))) 1386 (rowcol (ses-sym-rowcol (car-safe (cdr-safe x))))) 1387 (or (and (looking-at "\n") 1388 (eq (car-safe x) 'ses-cell) 1389 (eq row (car rowcol)) 1390 (eq col (cdr rowcol))) 1391 (error "Cell-def error")) 1392 (eval x))) 1393 (or (looking-at "\n\n") 1394 (error "Missing blank line between rows"))) 1395 ;;Load global parameters 1396 (let ((widths (read (current-buffer))) 1397 (n1 (char-after (point))) 1398 (printers (read (current-buffer))) 1399 (n2 (char-after (point))) 1400 (def-printer (read (current-buffer))) 1401 (n3 (char-after (point))) 1402 (head-row (read (current-buffer))) 1403 (n4 (char-after (point)))) 1404 (or (and (eq (car-safe widths) 'ses-column-widths) 1405 (= n1 ?\n) 1406 (eq (car-safe printers) 'ses-column-printers) 1407 (= n2 ?\n) 1408 (eq (car-safe def-printer) 'ses-default-printer) 1409 (= n3 ?\n) 1410 (eq (car-safe head-row) 'ses-header-row) 1411 (= n4 ?\n)) 1412 (error "Invalid SES global parameters")) 1413 (1value (eval widths)) 1414 (1value (eval def-printer)) 1415 (1value (eval printers)) 1416 (1value (eval head-row))) 1417 ;;Should be back at global-params 1418 (forward-char 1) 1419 (or (looking-at (replace-regexp-in-string "1" "[0-9]+" 1420 ses-initial-global-parameters)) 1421 (error "Problem with column-defs or global-params")) 1422 ;;Check for overall newline count in definitions area 1423 (forward-line 3) 1424 (let ((start (point))) 1425 (ses-goto-data 'ses--numrows) 1426 (or (= (point) start) 1427 (error "Extraneous newlines someplace?")))) 1428 1429(defun ses-setup () 1430 "Set up for display of only the printed cell values. 1431 1432Narrows the buffer to show only the print area. Gives it `read-only' and 1433`intangible' properties. Sets up highlighting for current cell." 1434 (interactive) 1435 (let ((end (point-min)) 1436 (inhibit-read-only t) 1437 (was-modified (buffer-modified-p)) 1438 pos sym) 1439 (ses-goto-data 0 0) ;;Include marker between print-area and data-area 1440 (set-text-properties (point) (point-max) nil) ;Delete garbage props 1441 (mapc 'delete-overlay (overlays-in (point-min) (point-max))) 1442 ;;The print area is read-only (except for our special commands) and uses a 1443 ;;special keymap. 1444 (put-text-property (point-min) (1- (point)) 'read-only 'ses) 1445 (put-text-property (point-min) (1- (point)) 'keymap 'ses-mode-print-map) 1446 ;;For the beginning of the buffer, we want the read-only and keymap 1447 ;;attributes to be inherited from the first character 1448 (put-text-property (point-min) (1+ (point-min)) 'front-sticky t) 1449 ;;Create intangible properties, which also indicate which cell the text 1450 ;;came from. 1451 (dotimes-with-progress-reporter (row ses--numrows) "Finding cells..." 1452 (dotimes (col ses--numcols) 1453 (setq pos end 1454 sym (ses-cell-symbol row col)) 1455 ;;Include skipped cells following this one 1456 (while (and (< col (1- ses--numcols)) 1457 (eq (ses-cell-value row (1+ col)) '*skip*)) 1458 (setq end (+ end (ses-col-width col) 1) 1459 col (1+ col))) 1460 (setq end (+ end (ses-col-width col) 1)) 1461 (put-text-property pos end 'intangible sym))) 1462 ;;Adding these properties did not actually alter the text 1463 (unless was-modified 1464 (restore-buffer-modified-p nil) 1465 (buffer-disable-undo) 1466 (buffer-enable-undo))) 1467 ;;Create the underlining overlay. It's impossible for (point) to be 2, 1468 ;;because column A must be at least 1 column wide. 1469 (setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min)))) 1470 (overlay-put ses--curcell-overlay 'face 'underline)) 1471 1472(defun ses-cleanup () 1473 "Cleanup when changing a buffer from SES mode to something else. Delete 1474overlay, remove special text properties." 1475 (widen) 1476 (let ((inhibit-read-only t) 1477 (was-modified (buffer-modified-p))) 1478 ;;Delete read-only, keymap, and intangible properties 1479 (set-text-properties (point-min) (point-max) nil) 1480 ;;Delete overlay 1481 (mapc 'delete-overlay (overlays-in (point-min) (point-max))) 1482 (unless was-modified 1483 (set-buffer-modified-p nil)))) 1484 1485;;;###autoload 1486(defun ses-mode () 1487 "Major mode for Simple Emacs Spreadsheet. 1488See \"ses-example.ses\" (in `data-directory') for more info. 1489 1490Key definitions: 1491\\{ses-mode-map} 1492These key definitions are active only in the print area (the visible part): 1493\\{ses-mode-print-map} 1494These are active only in the minibuffer, when entering or editing a formula: 1495\\{ses-mode-edit-map}" 1496 (interactive) 1497 (unless (and (boundp 'ses--deferred-narrow) 1498 (eq ses--deferred-narrow 'ses-mode)) 1499 (kill-all-local-variables) 1500 (mapc 'make-local-variable ses-localvars) 1501 (setq major-mode 'ses-mode 1502 mode-name "SES" 1503 next-line-add-newlines nil 1504 truncate-lines t 1505 ;;SES deliberately puts lots of trailing whitespace in its buffer 1506 show-trailing-whitespace nil 1507 ;;Cell ranges do not work reasonably without this 1508 transient-mark-mode t) 1509 (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t)) 1510 (1value (add-hook 'before-revert-hook 'ses-cleanup nil t)) 1511 (setq ses--curcell nil 1512 ses--deferred-recalc nil 1513 ses--deferred-write nil 1514 ses--header-hscroll -1 ;Flag for "initial recalc needed" 1515 header-line-format '(:eval (progn 1516 (when (/= (window-hscroll) 1517 ses--header-hscroll) 1518 ;;Reset ses--header-hscroll first, to 1519 ;;avoid recursion problems when 1520 ;;debugging ses-create-header-string 1521 (setq ses--header-hscroll 1522 (window-hscroll)) 1523 (ses-create-header-string)) 1524 ses--header-string))) 1525 (let ((was-empty (zerop (buffer-size))) 1526 (was-modified (buffer-modified-p))) 1527 (save-excursion 1528 (if was-empty 1529 ;;Initialize buffer to contain one cell, for now 1530 (insert ses-initial-file-contents)) 1531 (ses-load) 1532 (ses-setup)) 1533 (when was-empty 1534 (unless (equal ses-initial-default-printer (1value ses--default-printer)) 1535 (1value (ses-read-default-printer ses-initial-default-printer))) 1536 (unless (= ses-initial-column-width (1value (ses-col-width 0))) 1537 (1value (ses-set-column-width 0 ses-initial-column-width))) 1538 (ses-set-curcell) 1539 (if (> (car ses-initial-size) (1value ses--numrows)) 1540 (1value (ses-insert-row (1- (car ses-initial-size))))) 1541 (if (> (cdr ses-initial-size) (1value ses--numcols)) 1542 (1value (ses-insert-column (1- (cdr ses-initial-size))))) 1543 (ses-write-cells) 1544 (restore-buffer-modified-p was-modified) 1545 (buffer-disable-undo) 1546 (buffer-enable-undo) 1547 (goto-char (point-min)))) 1548 (use-local-map ses-mode-map) 1549 ;;Set the deferred narrowing flag (we can't narrow until after 1550 ;;after-find-file completes). If .ses is on the auto-load alist and the 1551 ;;file has "mode: ses", our ses-mode function will be called twice! Use 1552 ;;a special flag to detect this (will be reset by ses-command-hook). 1553 ;;For find-alternate-file, post-command-hook doesn't get run for some 1554 ;;reason, so use an idle timer to make sure. 1555 (setq ses--deferred-narrow 'ses-mode) 1556 (1value (add-hook 'post-command-hook 'ses-command-hook nil t)) 1557 (run-with-idle-timer 0.01 nil 'ses-command-hook) 1558 (run-mode-hooks 'ses-mode-hook))) 1559 1560(put 'ses-mode 'mode-class 'special) 1561 1562(defun ses-command-hook () 1563 "Invoked from `post-command-hook'. If point has moved to a different cell, 1564moves the underlining overlay. Performs any recalculations or cell-data 1565writes that have been deferred. If buffer-narrowing has been deferred, 1566narrows the buffer now." 1567 (condition-case err 1568 (when (eq major-mode 'ses-mode) ;Otherwise, not our buffer anymore 1569 (when ses--deferred-recalc 1570 ;;We reset the deferred list before starting on the recalc -- in case 1571 ;;of error, we don't want to retry the recalc after every keystroke! 1572 (let ((old ses--deferred-recalc)) 1573 (setq ses--deferred-recalc nil) 1574 (ses-update-cells old))) 1575 (when ses--deferred-write 1576 ;;We don't reset the deferred list before starting -- the most 1577 ;;likely error is keyboard-quit, and we do want to keep trying 1578 ;;these writes after a quit. 1579 (ses-write-cells) 1580 (push '(apply ses-widen) buffer-undo-list)) 1581 (when ses--deferred-narrow 1582 ;;We're not allowed to narrow the buffer until after-find-file has 1583 ;;read the local variables at the end of the file. Now it's safe to 1584 ;;do the narrowing. 1585 (narrow-to-region (point-min) ses--data-marker) 1586 (setq ses--deferred-narrow nil)) 1587 ;;Update the modeline 1588 (let ((oldcell ses--curcell)) 1589 (ses-set-curcell) 1590 (unless (eq ses--curcell oldcell) 1591 (cond 1592 ((not ses--curcell) 1593 (setq mode-line-process nil)) 1594 ((atom ses--curcell) 1595 (setq mode-line-process (list " cell " 1596 (symbol-name ses--curcell)))) 1597 (t 1598 (setq mode-line-process (list " range " 1599 (symbol-name (car ses--curcell)) 1600 "-" 1601 (symbol-name (cdr ses--curcell)))))) 1602 (force-mode-line-update))) 1603 ;;Use underline overlay for single-cells only, turn off otherwise 1604 (if (listp ses--curcell) 1605 (move-overlay ses--curcell-overlay 2 2) 1606 (let ((next (next-single-property-change (point) 'intangible))) 1607 (move-overlay ses--curcell-overlay (point) (1- next)))) 1608 (when (not (pos-visible-in-window-p)) 1609 ;;Scrolling will happen later 1610 (run-with-idle-timer 0.01 nil 'ses-command-hook) 1611 (setq ses--curcell t))) 1612 ;;Prevent errors in this post-command-hook from silently erasing the hook! 1613 (error 1614 (unless executing-kbd-macro 1615 (ding)) 1616 (message "%s" (error-message-string err)))) 1617 nil) ;Make coverage-tester happy 1618 1619(defun ses-create-header-string () 1620 "Set up `ses--header-string' as the buffer's header line. 1621Based on the current set of columns and `window-hscroll' position." 1622 (let ((totwidth (- (window-hscroll))) 1623 result width x) 1624 ;;Leave room for the left-side fringe and scrollbar 1625 (push (propertize " " 'display '((space :align-to 0))) result) 1626 (dotimes (col ses--numcols) 1627 (setq width (ses-col-width col) 1628 totwidth (+ totwidth width 1)) 1629 (if (= totwidth 1) 1630 ;;Scrolled so intercolumn space is leftmost 1631 (push " " result)) 1632 (when (> totwidth 1) 1633 (if (> ses--header-row 0) 1634 (save-excursion 1635 (ses-goto-print (1- ses--header-row) col) 1636 (setq x (buffer-substring-no-properties (point) 1637 (+ (point) width))) 1638 ;; Strip trailing space. 1639 (if (string-match "[ \t]+\\'" x) 1640 (setq x (substring x 0 (match-beginning 0)))) 1641 ;; Cut off excess text. 1642 (if (>= (length x) totwidth) 1643 (setq x (substring x 0 (- totwidth -1))))) 1644 (setq x (ses-column-letter col))) 1645 (push (propertize x 'face ses-box-prop) result) 1646 (push (propertize "." 1647 'display `((space :align-to ,(1- totwidth))) 1648 'face ses-box-prop) 1649 result) 1650 ;;Allow the following space to be squished to make room for the 3-D box 1651 ;;Coverage test ignores properties, thinks this is always a space! 1652 (push (1value (propertize " " 'display `((space :align-to ,totwidth)))) 1653 result))) 1654 (if (> ses--header-row 0) 1655 (push (propertize (format " [row %d]" ses--header-row) 1656 'display '((height (- 1)))) 1657 result)) 1658 (setq ses--header-string (apply 'concat (nreverse result))))) 1659 1660 1661;;---------------------------------------------------------------------------- 1662;; Redisplay and recalculation 1663;;---------------------------------------------------------------------------- 1664 1665(defun ses-jump (sym) 1666 "Move point to cell SYM." 1667 (interactive "SJump to cell: ") 1668 (let ((rowcol (ses-sym-rowcol sym))) 1669 (or rowcol (error "Invalid cell name")) 1670 (if (eq (symbol-value sym) '*skip*) 1671 (error "Cell is covered by preceding cell")) 1672 (ses-goto-print (car rowcol) (cdr rowcol)))) 1673 1674(defun ses-jump-safe (cell) 1675 "Like `ses-jump', but no error if invalid cell." 1676 (condition-case nil 1677 (ses-jump cell) 1678 (error))) 1679 1680(defun ses-reprint-all (&optional nonarrow) 1681 "Recreate the display area. Calls all printer functions. Narrows to 1682print area if NONARROW is nil." 1683 (interactive "*P") 1684 (widen) 1685 (unless nonarrow 1686 (setq ses--deferred-narrow t)) 1687 (let ((startcell (get-text-property (point) 'intangible)) 1688 (inhibit-read-only t)) 1689 (ses-begin-change) 1690 (goto-char (point-min)) 1691 (search-forward ses-print-data-boundary) 1692 (backward-char (length ses-print-data-boundary)) 1693 (delete-region (point-min) (point)) 1694 ;;Insert all blank lines before printing anything, so ses-print-cell can 1695 ;;find the data area when inserting or deleting *skip* values for cells 1696 (dotimes (row ses--numrows) 1697 (insert-and-inherit ses--blank-line)) 1698 (dotimes-with-progress-reporter (row ses--numrows) "Reprinting..." 1699 (if (eq (ses-cell-value row 0) '*skip*) 1700 ;;Column deletion left a dangling skip 1701 (ses-set-cell row 0 'value nil)) 1702 (dotimes (col ses--numcols) 1703 (ses-print-cell row col)) 1704 (beginning-of-line 2)) 1705 (ses-jump-safe startcell))) 1706 1707(defun ses-recalculate-cell () 1708 "Recalculate and reprint the current cell or range. 1709 1710For an individual cell, shows the error if the formula or printer 1711signals one, or otherwise shows the cell's complete value. For a range, the 1712cells are recalculated in \"natural\" order, so cells that other cells refer 1713to are recalculated first." 1714 (interactive "*") 1715 (ses-check-curcell 'range) 1716 (ses-begin-change) 1717 (let (sig) 1718 (setq ses-start-time (float-time)) 1719 (if (atom ses--curcell) 1720 (setq sig (ses-sym-rowcol ses--curcell) 1721 sig (ses-calculate-cell (car sig) (cdr sig) t)) 1722 ;;First, recalculate all cells that don't refer to other cells and 1723 ;;produce a list of cells with references. 1724 (ses-dorange ses--curcell 1725 (ses-time-check "Recalculating... %s" '(ses-cell-symbol row col)) 1726 (condition-case nil 1727 (progn 1728 ;;The t causes an error if the cell has references. 1729 ;;If no references, the t will be the result value. 1730 (1value (ses-formula-references (ses-cell-formula row col) t)) 1731 (setq sig (ses-calculate-cell row col t))) 1732 (wrong-type-argument 1733 ;;The formula contains a reference 1734 (add-to-list 'ses--deferred-recalc (ses-cell-symbol row col)))))) 1735 ;;Do the update now, so we can force recalculation 1736 (let ((x ses--deferred-recalc)) 1737 (setq ses--deferred-recalc nil) 1738 (condition-case hold 1739 (ses-update-cells x t) 1740 (error (setq sig hold)))) 1741 (cond 1742 (sig 1743 (message "%s" (error-message-string sig))) 1744 ((consp ses--curcell) 1745 (message " ")) 1746 (t 1747 (princ (symbol-value ses--curcell)))))) 1748 1749(defun ses-recalculate-all () 1750 "Recalculate and reprint all cells." 1751 (interactive "*") 1752 (let ((startcell (get-text-property (point) 'intangible)) 1753 (ses--curcell (cons 'A1 (ses-cell-symbol (1- ses--numrows) 1754 (1- ses--numcols))))) 1755 (ses-recalculate-cell) 1756 (ses-jump-safe startcell))) 1757 1758(defun ses-truncate-cell () 1759 "Reprint current cell, but without spillover into any following blank 1760cells." 1761 (interactive "*") 1762 (ses-check-curcell) 1763 (let* ((rowcol (ses-sym-rowcol ses--curcell)) 1764 (row (car rowcol)) 1765 (col (cdr rowcol))) 1766 (when (and (< col (1- ses--numcols)) ;;Last column can't spill over, anyway 1767 (eq (ses-cell-value row (1+ col)) '*skip*)) 1768 ;;This cell has spill-over. We'll momentarily pretend the following 1769 ;;cell has a `t' in it. 1770 (eval `(let ((,(ses-cell-symbol row (1+ col)) t)) 1771 (ses-print-cell row col))) 1772 ;;Now remove the *skip*. ses-print-cell is always nil here 1773 (ses-set-cell row (1+ col) 'value nil) 1774 (1value (ses-print-cell row (1+ col)))))) 1775 1776(defun ses-reconstruct-all () 1777 "Reconstruct buffer based on cell data stored in Emacs variables." 1778 (interactive "*") 1779 (ses-begin-change) 1780 ;;Reconstruct reference lists. 1781 (let (x yrow ycol) 1782 ;;Delete old reference lists 1783 (dotimes-with-progress-reporter 1784 (row ses--numrows) "Deleting references..." 1785 (dotimes (col ses--numcols) 1786 (ses-set-cell row col 'references nil))) 1787 ;;Create new reference lists 1788 (dotimes-with-progress-reporter 1789 (row ses--numrows) "Computing references..." 1790 (dotimes (col ses--numcols) 1791 (dolist (ref (ses-formula-references (ses-cell-formula row col))) 1792 (setq x (ses-sym-rowcol ref) 1793 yrow (car x) 1794 ycol (cdr x)) 1795 (ses-set-cell yrow ycol 'references 1796 (cons (ses-cell-symbol row col) 1797 (ses-cell-references yrow ycol))))))) 1798 ;;Delete everything and reconstruct basic data area 1799 (ses-widen) 1800 (let ((inhibit-read-only t)) 1801 (goto-char (point-max)) 1802 (if (search-backward ";; Local Variables:\n" nil t) 1803 (delete-region (point-min) (point)) 1804 ;;Buffer is quite screwed up - can't even save the user-specified locals 1805 (delete-region (point-min) (point-max)) 1806 (insert ses-initial-file-trailer) 1807 (goto-char (point-min))) 1808 ;;Create a blank display area 1809 (dotimes (row ses--numrows) 1810 (insert ses--blank-line)) 1811 (insert ses-print-data-boundary) 1812 (backward-char (1- (length ses-print-data-boundary))) 1813 (setq ses--data-marker (point-marker)) 1814 (forward-char (1- (length ses-print-data-boundary))) 1815 ;;Placeholders for cell data 1816 (insert (make-string (* ses--numrows (1+ ses--numcols)) ?\n)) 1817 ;;Placeholders for col-widths, col-printers, default-printer, header-row 1818 (insert "\n\n\n\n") 1819 (insert ses-initial-global-parameters) 1820 (backward-char (1- (length ses-initial-global-parameters))) 1821 (setq ses--params-marker (point-marker)) 1822 (forward-char (1- (length ses-initial-global-parameters)))) 1823 (ses-set-parameter 'ses--col-widths ses--col-widths) 1824 (ses-set-parameter 'ses--col-printers ses--col-printers) 1825 (ses-set-parameter 'ses--default-printer ses--default-printer) 1826 (ses-set-parameter 'ses--header-row ses--header-row) 1827 (ses-set-parameter 'ses--numrows ses--numrows) 1828 (ses-set-parameter 'ses--numcols ses--numcols) 1829 ;;Keep our old narrowing 1830 (ses-setup) 1831 (ses-recalculate-all) 1832 (goto-char (point-min))) 1833 1834 1835;;---------------------------------------------------------------------------- 1836;; Input of cell formulas 1837;;---------------------------------------------------------------------------- 1838 1839(defun ses-edit-cell (row col newval) 1840 "Display current cell contents in minibuffer, for editing. Returns nil if 1841cell formula was unsafe and user declined confirmation." 1842 (interactive 1843 (progn 1844 (barf-if-buffer-read-only) 1845 (ses-check-curcell) 1846 (let* ((rowcol (ses-sym-rowcol ses--curcell)) 1847 (row (car rowcol)) 1848 (col (cdr rowcol)) 1849 (formula (ses-cell-formula row col)) 1850 initial) 1851 (if (eq (car-safe formula) 'ses-safe-formula) 1852 (setq formula (cadr formula))) 1853 (if (eq (car-safe formula) 'quote) 1854 (setq initial (format "'%S" (cadr formula))) 1855 (setq initial (prin1-to-string formula))) 1856 (if (stringp formula) 1857 ;;Position cursor inside close-quote 1858 (setq initial (cons initial (length initial)))) 1859 (list row col 1860 (read-from-minibuffer (format "Cell %s: " ses--curcell) 1861 initial 1862 ses-mode-edit-map 1863 t ;Convert to Lisp object 1864 'ses-read-cell-history))))) 1865 (when (ses-warn-unsafe newval 'unsafep) 1866 (ses-begin-change) 1867 (ses-cell-set-formula row col newval) 1868 t)) 1869 1870(defun ses-read-cell (row col newval) 1871 "Self-insert for initial character of cell function." 1872 (interactive 1873 (let* ((initial (this-command-keys)) 1874 (rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell))) 1875 (curval (ses-cell-formula (car rowcol) (cdr rowcol)))) 1876 (barf-if-buffer-read-only) 1877 (list (car rowcol) 1878 (cdr rowcol) 1879 (read-from-minibuffer 1880 (format "Cell %s: " ses--curcell) 1881 (cons (if (equal initial "\"") "\"\"" 1882 (if (equal initial "(") "()" initial)) 2) 1883 ses-mode-edit-map 1884 t ;Convert to Lisp object 1885 'ses-read-cell-history 1886 (prin1-to-string (if (eq (car-safe curval) 'ses-safe-formula) 1887 (cadr curval) 1888 curval)))))) 1889 (when (ses-edit-cell row col newval) 1890 (ses-command-hook) ;Update cell widths before movement 1891 (dolist (x ses-after-entry-functions) 1892 (funcall x 1)))) 1893 1894(defun ses-read-symbol (row col symb) 1895 "Self-insert for a symbol as a cell formula. The set of all symbols that 1896have been used as formulas in this spreadsheet is available for completions." 1897 (interactive 1898 (let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell))) 1899 newval) 1900 (barf-if-buffer-read-only) 1901 (setq newval (completing-read (format "Cell %s ': " ses--curcell) 1902 ses--symbolic-formulas)) 1903 (list (car rowcol) 1904 (cdr rowcol) 1905 (if (string= newval "") 1906 nil ;Don't create zero-length symbols! 1907 (list 'quote (intern newval)))))) 1908 (when (ses-edit-cell row col symb) 1909 (ses-command-hook) ;Update cell widths before movement 1910 (dolist (x ses-after-entry-functions) 1911 (funcall x 1)))) 1912 1913(defun ses-clear-cell-forward (count) 1914 "Delete formula and printer for current cell and then move to next cell. 1915With prefix, deletes several cells." 1916 (interactive "*p") 1917 (if (< count 0) 1918 (1value (ses-clear-cell-backward (- count))) 1919 (ses-check-curcell) 1920 (ses-begin-change) 1921 (dotimes (x count) 1922 (ses-set-curcell) 1923 (let ((rowcol (ses-sym-rowcol ses--curcell))) 1924 (or rowcol (signal 'end-of-buffer nil)) 1925 (ses-clear-cell (car rowcol) (cdr rowcol))) 1926 (forward-char 1)))) 1927 1928(defun ses-clear-cell-backward (count) 1929 "Move to previous cell and then delete it. With prefix, deletes several 1930cells." 1931 (interactive "*p") 1932 (if (< count 0) 1933 (1value (ses-clear-cell-forward (- count))) 1934 (ses-check-curcell 'end) 1935 (ses-begin-change) 1936 (dotimes (x count) 1937 (backward-char 1) ;Will signal 'beginning-of-buffer if appropriate 1938 (ses-set-curcell) 1939 (let ((rowcol (ses-sym-rowcol ses--curcell))) 1940 (ses-clear-cell (car rowcol) (cdr rowcol)))))) 1941 1942 1943;;---------------------------------------------------------------------------- 1944;; Input of cell-printer functions 1945;;---------------------------------------------------------------------------- 1946 1947(defun ses-read-printer (prompt default) 1948 "Common code for `ses-read-cell-printer', `ses-read-column-printer', and `ses-read-default-printer'. 1949PROMPT should end with \": \". Result is t if operation was cancelled." 1950 (barf-if-buffer-read-only) 1951 (if (eq default t) 1952 (setq default "") 1953 (setq prompt (format "%s [currently %S]: " 1954 (substring prompt 0 -2) 1955 default))) 1956 (let ((new (read-from-minibuffer prompt 1957 nil ;Initial contents 1958 ses-mode-edit-map 1959 t ;Evaluate the result 1960 'ses-read-printer-history 1961 (prin1-to-string default)))) 1962 (if (equal new default) 1963 ;;User changed mind, decided not to change printer 1964 (setq new t) 1965 (ses-printer-validate new) 1966 (or (not new) 1967 (stringp new) 1968 (stringp (car-safe new)) 1969 (ses-warn-unsafe new 'unsafep-function) 1970 (setq new t))) 1971 new)) 1972 1973(defun ses-read-cell-printer (newval) 1974 "Set the printer function for the current cell or range. 1975 1976A printer function is either a string (a format control-string with one 1977%-sequence -- result from format will be right-justified), or a list of one 1978string (result from format will be left-justified), or a lambda-expression of 1979one argument, or a symbol that names a function of one argument. In the 1980latter two cases, the function's result should be either a string (will be 1981right-justified) or a list of one string (will be left-justified)." 1982 (interactive 1983 (let ((default t) 1984 x) 1985 (ses-check-curcell 'range) 1986 ;;Default is none if not all cells in range have same printer 1987 (catch 'ses-read-cell-printer 1988 (ses-dorange ses--curcell 1989 (setq x (ses-cell-printer row col)) 1990 (if (eq (car-safe x) 'ses-safe-printer) 1991 (setq x (cadr x))) 1992 (if (eq default t) 1993 (setq default x) 1994 (unless (equal default x) 1995 ;;Range contains differing printer functions 1996 (setq default t) 1997 (throw 'ses-read-cell-printer t))))) 1998 (list (ses-read-printer (format "Cell %S printer: " ses--curcell) 1999 default)))) 2000 (unless (eq newval t) 2001 (ses-begin-change) 2002 (ses-dorange ses--curcell 2003 (ses-set-cell row col 'printer newval) 2004 (ses-print-cell row col)))) 2005 2006(defun ses-read-column-printer (col newval) 2007 "Set the printer function for the current column. See 2008`ses-read-cell-printer' for input forms." 2009 (interactive 2010 (let ((col (cdr (ses-sym-rowcol ses--curcell)))) 2011 (ses-check-curcell) 2012 (list col (ses-read-printer (format "Column %s printer: " 2013 (ses-column-letter col)) 2014 (ses-col-printer col))))) 2015 2016 (unless (eq newval t) 2017 (ses-begin-change) 2018 (ses-set-parameter 'ses--col-printers newval col) 2019 (save-excursion 2020 (dotimes (row ses--numrows) 2021 (ses-print-cell row col))))) 2022 2023(defun ses-read-default-printer (newval) 2024 "Set the default printer function for cells that have no other. See 2025`ses-read-cell-printer' for input forms." 2026 (interactive 2027 (list (ses-read-printer "Default printer: " ses--default-printer))) 2028 (unless (eq newval t) 2029 (ses-begin-change) 2030 (ses-set-parameter 'ses--default-printer newval) 2031 (ses-reprint-all t))) 2032 2033 2034;;---------------------------------------------------------------------------- 2035;; Spreadsheet size adjustments 2036;;---------------------------------------------------------------------------- 2037 2038(defun ses-insert-row (count) 2039 "Insert a new row before the current one. With prefix, insert COUNT rows 2040before current one." 2041 (interactive "*p") 2042 (ses-check-curcell 'end) 2043 (or (> count 0) (signal 'args-out-of-range nil)) 2044 (ses-begin-change) 2045 (let ((inhibit-quit t) 2046 (inhibit-read-only t) 2047 (row (or (car (ses-sym-rowcol ses--curcell)) ses--numrows)) 2048 newrow) 2049 ;;Create a new set of cell-variables 2050 (ses-create-cell-variable-range ses--numrows (+ ses--numrows count -1) 2051 0 (1- ses--numcols)) 2052 (ses-set-parameter 'ses--numrows (+ ses--numrows count)) 2053 ;;Insert each row 2054 (ses-goto-print row 0) 2055 (dotimes-with-progress-reporter (x count) "Inserting row..." 2056 ;;Create a row of empty cells. The `symbol' fields will be set by 2057 ;;the call to ses-relocate-all. 2058 (setq newrow (make-vector ses--numcols nil)) 2059 (dotimes (col ses--numcols) 2060 (aset newrow col (ses-make-cell))) 2061 (setq ses--cells (ses-vector-insert ses--cells row newrow)) 2062 (push `(apply ses-vector-delete ses--cells ,row 1) buffer-undo-list) 2063 (insert ses--blank-line)) 2064 ;;Insert empty lines in cell data area (will be replaced by 2065 ;;ses-relocate-all) 2066 (ses-goto-data row 0) 2067 (insert (make-string (* (1+ ses--numcols) count) ?\n)) 2068 (ses-relocate-all row 0 count 0) 2069 ;;If any cell printers insert constant text, insert that text 2070 ;;into the line. 2071 (let ((cols (mapconcat #'ses-call-printer ses--col-printers nil)) 2072 (global (ses-call-printer ses--default-printer))) 2073 (if (or (> (length cols) 0) (> (length global) 0)) 2074 (dotimes (x count) 2075 (dotimes (col ses--numcols) 2076 ;;These cells are always nil, only constant formatting printed 2077 (1value (ses-print-cell (+ x row) col)))))) 2078 (when (> ses--header-row row) 2079 ;;Inserting before header 2080 (ses-set-parameter 'ses--header-row (+ ses--header-row count)) 2081 (ses-reset-header-string))) 2082 ;;Reconstruct text attributes 2083 (ses-setup) 2084 ;;Prepare for undo 2085 (push '(apply ses-widen) buffer-undo-list) 2086 ;;Return to current cell 2087 (if ses--curcell 2088 (ses-jump-safe ses--curcell) 2089 (ses-goto-print (1- ses--numrows) 0))) 2090 2091(defun ses-delete-row (count) 2092 "Delete the current row. With prefix, Deletes COUNT rows starting from the 2093current one." 2094 (interactive "*p") 2095 (ses-check-curcell) 2096 (or (> count 0) (signal 'args-out-of-range nil)) 2097 (let ((inhibit-quit t) 2098 (inhibit-read-only t) 2099 (row (car (ses-sym-rowcol ses--curcell)))) 2100 (setq count (min count (- ses--numrows row))) 2101 (ses-begin-change) 2102 (ses-set-parameter 'ses--numrows (- ses--numrows count)) 2103 ;;Delete lines from print area 2104 (ses-goto-print row 0) 2105 (ses-delete-line count) 2106 ;;Delete lines from cell data area 2107 (ses-goto-data row 0) 2108 (ses-delete-line (* count (1+ ses--numcols))) 2109 ;;Relocate variables and formulas 2110 (ses-set-with-undo 'ses--cells (ses-vector-delete ses--cells row count)) 2111 (ses-relocate-all row 0 (- count) 0) 2112 (ses-destroy-cell-variable-range ses--numrows (+ ses--numrows count -1) 2113 0 (1- ses--numcols)) 2114 (when (> ses--header-row row) 2115 (if (<= ses--header-row (+ row count)) 2116 ;;Deleting the header row 2117 (ses-set-parameter 'ses--header-row 0) 2118 (ses-set-parameter 'ses--header-row (- ses--header-row count))) 2119 (ses-reset-header-string))) 2120 ;;Reconstruct attributes 2121 (ses-setup) 2122 ;;Prepare for undo 2123 (push '(apply ses-widen) buffer-undo-list) 2124 (ses-jump-safe ses--curcell)) 2125 2126(defun ses-insert-column (count &optional col width printer) 2127 "Insert a new column before COL (default is the current one). 2128With prefix, insert COUNT columns before current one. 2129If COL is specified, the new column(s) get the specified WIDTH and PRINTER 2130\(otherwise they're taken from the current column)." 2131 (interactive "*p") 2132 (ses-check-curcell) 2133 (or (> count 0) (signal 'args-out-of-range nil)) 2134 (or col 2135 (setq col (cdr (ses-sym-rowcol ses--curcell)) 2136 width (ses-col-width col) 2137 printer (ses-col-printer col))) 2138 (ses-begin-change) 2139 (let ((inhibit-quit t) 2140 (inhibit-read-only t) 2141 (widths ses--col-widths) 2142 (printers ses--col-printers) 2143 has-skip) 2144 ;;Create a new set of cell-variables 2145 (ses-create-cell-variable-range 0 (1- ses--numrows) 2146 ses--numcols (+ ses--numcols count -1)) 2147 ;;Insert each column. 2148 (dotimes-with-progress-reporter (x count) "Inserting column..." 2149 ;;Create a column of empty cells. The `symbol' fields will be set by 2150 ;;the call to ses-relocate-all. 2151 (ses-adjust-print-width col (1+ width)) 2152 (ses-set-parameter 'ses--numcols (1+ ses--numcols)) 2153 (dotimes (row ses--numrows) 2154 (and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*) 2155 ;;Inserting in the middle of a spill-over 2156 (setq has-skip t)) 2157 (ses-aset-with-undo ses--cells row 2158 (ses-vector-insert (aref ses--cells row) 2159 col (ses-make-cell))) 2160 ;;Insert empty lines in cell data area (will be replaced by 2161 ;;ses-relocate-all) 2162 (ses-goto-data row col) 2163 (insert ?\n)) 2164 ;;Insert column width and printer 2165 (setq widths (ses-vector-insert widths col width) 2166 printers (ses-vector-insert printers col printer))) 2167 (ses-set-parameter 'ses--col-widths widths) 2168 (ses-set-parameter 'ses--col-printers printers) 2169 (ses-reset-header-string) 2170 (ses-relocate-all 0 col 0 count) 2171 (if has-skip 2172 (ses-reprint-all t) 2173 (when (or (> (length (ses-call-printer printer)) 0) 2174 (> (length (ses-call-printer ses--default-printer)) 0)) 2175 ;;Either column printer or global printer inserts some constant text 2176 ;;Reprint the new columns to insert that text. 2177 (dotimes (x ses--numrows) 2178 (dotimes (y count) 2179 ;Always nil here - this is a blank column 2180 (1value (ses-print-cell-new-width x (+ y col)))))) 2181 (ses-setup))) 2182 (ses-jump-safe ses--curcell)) 2183 2184(defun ses-delete-column (count) 2185 "Delete the current column. With prefix, Deletes COUNT columns starting 2186from the current one." 2187 (interactive "*p") 2188 (ses-check-curcell) 2189 (or (> count 0) (signal 'args-out-of-range nil)) 2190 (let ((inhibit-quit t) 2191 (inhibit-read-only t) 2192 (rowcol (ses-sym-rowcol ses--curcell)) 2193 (width 0) 2194 col origrow has-skip) 2195 (setq origrow (car rowcol) 2196 col (cdr rowcol) 2197 count (min count (- ses--numcols col))) 2198 (if (= count ses--numcols) 2199 (error "Can't delete all columns!")) 2200 ;;Determine width of column(s) being deleted 2201 (dotimes (x count) 2202 (setq width (+ width (ses-col-width (+ col x)) 1))) 2203 (ses-begin-change) 2204 (ses-set-parameter 'ses--numcols (- ses--numcols count)) 2205 (ses-adjust-print-width col (- width)) 2206 (dotimes-with-progress-reporter (row ses--numrows) "Deleting column..." 2207 ;;Delete lines from cell data area 2208 (ses-goto-data row col) 2209 (ses-delete-line count) 2210 ;;Delete cells. Check if deletion area begins or ends with a skip. 2211 (if (or (eq (ses-cell-value row col) '*skip*) 2212 (and (< col ses--numcols) 2213 (eq (ses-cell-value row (+ col count)) '*skip*))) 2214 (setq has-skip t)) 2215 (ses-aset-with-undo ses--cells row 2216 (ses-vector-delete (aref ses--cells row) col count))) 2217 ;;Update globals 2218 (ses-set-parameter 'ses--col-widths 2219 (ses-vector-delete ses--col-widths col count)) 2220 (ses-set-parameter 'ses--col-printers 2221 (ses-vector-delete ses--col-printers col count)) 2222 (ses-reset-header-string) 2223 ;;Relocate variables and formulas 2224 (ses-relocate-all 0 col 0 (- count)) 2225 (ses-destroy-cell-variable-range 0 (1- ses--numrows) 2226 ses--numcols (+ ses--numcols count -1)) 2227 (if has-skip 2228 (ses-reprint-all t) 2229 (ses-setup)) 2230 (if (>= col ses--numcols) 2231 (setq col (1- col))) 2232 (ses-goto-print origrow col))) 2233 2234(defun ses-forward-or-insert (&optional count) 2235 "Move to next cell in row, or inserts a new cell if already in last one, or 2236inserts a new row if at bottom of print area. Repeat COUNT times." 2237 (interactive "p") 2238 (ses-check-curcell 'end) 2239 (setq deactivate-mark t) ;Doesn't combine well with ranges 2240 (dotimes (x count) 2241 (ses-set-curcell) 2242 (if (not ses--curcell) 2243 (progn ;At bottom of print area 2244 (barf-if-buffer-read-only) 2245 (ses-insert-row 1)) 2246 (let ((col (cdr (ses-sym-rowcol ses--curcell)))) 2247 (when (/= 32 2248 (char-before (next-single-property-change (point) 2249 'intangible))) 2250 ;;We're already in last nonskipped cell on line. Need to create a 2251 ;;new column. 2252 (barf-if-buffer-read-only) 2253 (ses-insert-column (- count x) 2254 ses--numcols 2255 (ses-col-width col) 2256 (ses-col-printer col))))) 2257 (forward-char))) 2258 2259(defun ses-append-row-jump-first-column () 2260 "Insert a new row after current one and jumps to its first column." 2261 (interactive "*") 2262 (ses-check-curcell) 2263 (ses-begin-change) 2264 (beginning-of-line 2) 2265 (ses-set-curcell) 2266 (ses-insert-row 1)) 2267 2268(defun ses-set-column-width (col newwidth) 2269 "Set the width of the current column." 2270 (interactive 2271 (let ((col (cdr (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell))))) 2272 (barf-if-buffer-read-only) 2273 (list col 2274 (if current-prefix-arg 2275 (prefix-numeric-value current-prefix-arg) 2276 (read-from-minibuffer (format "Column %s width [currently %d]: " 2277 (ses-column-letter col) 2278 (ses-col-width col)) 2279 nil ;No initial contents 2280 nil ;No override keymap 2281 t ;Convert to Lisp object 2282 nil ;No history 2283 (number-to-string 2284 (ses-col-width col))))))) ;Default value 2285 (if (< newwidth 1) 2286 (error "Invalid column width")) 2287 (ses-begin-change) 2288 (ses-reset-header-string) 2289 (save-excursion 2290 (let ((inhibit-quit t)) 2291 (ses-adjust-print-width col (- newwidth (ses-col-width col))) 2292 (ses-set-parameter 'ses--col-widths newwidth col)) 2293 (dotimes (row ses--numrows) 2294 (ses-print-cell-new-width row col)))) 2295 2296 2297;;---------------------------------------------------------------------------- 2298;; Cut and paste, import and export 2299;;---------------------------------------------------------------------------- 2300 2301(defadvice copy-region-as-kill (around ses-copy-region-as-kill 2302 activate preactivate) 2303 "It doesn't make sense to copy read-only or intangible attributes into the 2304kill ring. It probably doesn't make sense to copy keymap properties. 2305We'll assume copying front-sticky properties doesn't make sense, either. 2306 2307This advice also includes some SES-specific code because otherwise it's too 2308hard to override how mouse-1 works." 2309 (when (> beg end) 2310 (let ((temp beg)) 2311 (setq beg end 2312 end temp))) 2313 (if (not (and (eq major-mode 'ses-mode) 2314 (eq (get-text-property beg 'read-only) 'ses) 2315 (eq (get-text-property (1- end) 'read-only) 'ses))) 2316 ad-do-it ;Normal copy-region-as-kill 2317 (kill-new (ses-copy-region beg end)) 2318 (if transient-mark-mode 2319 (setq deactivate-mark t)) 2320 nil)) 2321 2322(defun ses-copy-region (beg end) 2323 "Treat the region as rectangular. Convert the intangible attributes to 2324SES attributes recording the contents of the cell as of the time of copying." 2325 (let* ((inhibit-point-motion-hooks t) 2326 (x (mapconcat 'ses-copy-region-helper 2327 (extract-rectangle beg (1- end)) "\n"))) 2328 (remove-text-properties 0 (length x) 2329 '(read-only t 2330 intangible t 2331 keymap t 2332 front-sticky t) 2333 x) 2334 x)) 2335 2336(defun ses-copy-region-helper (line) 2337 "Converts one line (of a rectangle being extracted from a spreadsheet) to 2338external form by attaching to each print cell a 'ses attribute that records 2339the corresponding data cell." 2340 (or (> (length line) 1) 2341 (error "Empty range")) 2342 (let ((inhibit-read-only t) 2343 (pos 0) 2344 mycell next sym rowcol) 2345 (while pos 2346 (setq sym (get-text-property pos 'intangible line) 2347 next (next-single-property-change pos 'intangible line) 2348 rowcol (ses-sym-rowcol sym) 2349 mycell (ses-get-cell (car rowcol) (cdr rowcol))) 2350 (put-text-property pos (or next (length line)) 2351 'ses 2352 (list (ses-cell-symbol mycell) 2353 (ses-cell-formula mycell) 2354 (ses-cell-printer mycell)) 2355 line) 2356 (setq pos next))) 2357 line) 2358 2359(defun ses-kill-override (beg end) 2360 "Generic override for any commands that kill text. We clear the killed 2361cells instead of deleting them." 2362 (interactive "r") 2363 (ses-check-curcell 'needrange) 2364 ;;For some reason, the text-read-only error is not caught by 2365 ;;`delete-region', so we have to use subterfuge. 2366 (let ((buffer-read-only t)) 2367 (1value (condition-case x 2368 (noreturn (funcall (lookup-key (current-global-map) 2369 (this-command-keys)) 2370 beg end)) 2371 (buffer-read-only nil)))) ;The expected error 2372 ;;Because the buffer was marked read-only, the kill command turned itself 2373 ;;into a copy. Now we clear the cells or signal the error. First we 2374 ;;check whether the buffer really is read-only. 2375 (barf-if-buffer-read-only) 2376 (ses-begin-change) 2377 (ses-dorange ses--curcell 2378 (ses-clear-cell row col)) 2379 (ses-jump (car ses--curcell))) 2380 2381(defadvice yank (around ses-yank activate preactivate) 2382 "In SES mode, the yanked text is inserted as cells. 2383 2384If the text contains 'ses attributes (meaning it went to the kill-ring from a 2385SES buffer), the formulas and print functions are restored for the cells. If 2386the text contains tabs, this is an insertion of tab-separated formulas. 2387Otherwise the text is inserted as the formula for the current cell. 2388 2389When inserting cells, the formulas are usually relocated to keep the same 2390relative references to neighboring cells. This is best if the formulas 2391generally refer to other cells within the yanked text. You can use the C-u 2392prefix to specify insertion without relocation, which is best when the 2393formulas refer to cells outsite the yanked text. 2394 2395When inserting formulas, the text is treated as a string constant if it doesn't 2396make sense as a sexp or would otherwise be considered a symbol. Use 'sym to 2397explicitly insert a symbol, or use the C-u prefix to treat all unmarked words 2398as symbols." 2399 (if (not (and (eq major-mode 'ses-mode) 2400 (eq (get-text-property (point) 'keymap) 'ses-mode-print-map))) 2401 ad-do-it ;Normal non-SES yank 2402 (ses-check-curcell 'end) 2403 (push-mark (point)) 2404 (let ((text (current-kill (cond 2405 ((listp arg) 0) 2406 ((eq arg '-) -1) 2407 (t (1- arg)))))) 2408 (or (ses-yank-cells text arg) 2409 (ses-yank-tsf text arg) 2410 (ses-yank-one (ses-yank-resize 1 1) 2411 text 2412 0 2413 (if (memq (aref text (1- (length text))) '(?\t ?\n)) 2414 ;;Just one cell - delete final tab or newline 2415 (1- (length text))) 2416 arg))) 2417 (if (consp arg) 2418 (exchange-point-and-mark)))) 2419 2420(defun ses-yank-pop (arg) 2421 "Replace just-yanked stretch of killed text with a different stretch. 2422This command is allowed only immediately after a `yank' or a `yank-pop', when 2423the region contains a stretch of reinserted previously-killed text. We 2424replace it with a different stretch of killed text. 2425 Unlike standard `yank-pop', this function uses `undo' to delete the 2426previous insertion." 2427 (interactive "*p") 2428 (or (eq last-command 'yank) 2429 ;;Use noreturn here just to avoid a "poor-coverage" warning in its 2430 ;;macro definition. 2431 (noreturn (error "Previous command was not a yank"))) 2432 (undo) 2433 (ses-set-curcell) 2434 (yank (1+ (or arg 1))) 2435 (setq this-command 'yank)) 2436 2437(defun ses-yank-cells (text arg) 2438 "If the TEXT has a proper set of 'ses attributes, inserts the text as 2439cells, else return nil. The cells are reprinted--the supplied text is 2440ignored because the column widths, default printer, etc. at yank time might 2441be different from those at kill-time. ARG is a list to indicate that 2442formulas are to be inserted without relocation." 2443 (let ((first (get-text-property 0 'ses text)) 2444 (last (get-text-property (1- (length text)) 'ses text))) 2445 (when (and first last) ;;Otherwise not proper set of attributes 2446 (setq first (ses-sym-rowcol (car first)) 2447 last (ses-sym-rowcol (car last))) 2448 (let* ((needrows (- (car last) (car first) -1)) 2449 (needcols (- (cdr last) (cdr first) -1)) 2450 (rowcol (ses-yank-resize needrows needcols)) 2451 (rowincr (- (car rowcol) (car first))) 2452 (colincr (- (cdr rowcol) (cdr first))) 2453 (pos 0) 2454 myrow mycol x) 2455 (dotimes-with-progress-reporter (row needrows) "Yanking..." 2456 (setq myrow (+ row (car rowcol))) 2457 (dotimes (col needcols) 2458 (setq mycol (+ col (cdr rowcol)) 2459 last (get-text-property pos 'ses text) 2460 pos (next-single-property-change pos 'ses text) 2461 x (ses-sym-rowcol (car last))) 2462 (if (not last) 2463 ;;Newline - all remaining cells on row are skipped 2464 (setq x (cons (- myrow rowincr) (+ needcols colincr -1)) 2465 last (list nil nil nil) 2466 pos (1- pos))) 2467 (if (/= (car x) (- myrow rowincr)) 2468 (error "Cell row error")) 2469 (if (< (- mycol colincr) (cdr x)) 2470 ;;Some columns were skipped 2471 (let ((oldcol mycol)) 2472 (while (< (- mycol colincr) (cdr x)) 2473 (ses-clear-cell myrow mycol) 2474 (setq col (1+ col) 2475 mycol (1+ mycol))) 2476 (ses-print-cell myrow (1- oldcol)))) ;;This inserts *skip* 2477 (when (car last) ;Skip this for *skip* cells 2478 (setq x (nth 2 last)) 2479 (unless (equal x (ses-cell-printer myrow mycol)) 2480 (or (not x) 2481 (stringp x) 2482 (eq (car-safe x) 'ses-safe-printer) 2483 (setq x `(ses-safe-printer ,x))) 2484 (ses-set-cell myrow mycol 'printer x)) 2485 (setq x (cadr last)) 2486 (if (atom arg) 2487 (setq x (ses-relocate-formula x 0 0 rowincr colincr))) 2488 (or (atom x) 2489 (eq (car-safe x) 'ses-safe-formula) 2490 (setq x `(ses-safe-formula ,x))) 2491 (ses-cell-set-formula myrow mycol x))) 2492 (when pos 2493 (if (get-text-property pos 'ses text) 2494 (error "Missing newline between rows")) 2495 (setq pos (next-single-property-change pos 'ses text)))) 2496 t)))) 2497 2498(defun ses-yank-one (rowcol text from to arg) 2499 "Insert the substring [FROM,TO] of TEXT as the formula for cell ROWCOL (a 2500cons of ROW and COL). Treat plain symbols as strings unless ARG is a list." 2501 (let ((val (condition-case nil 2502 (read-from-string text from to) 2503 (error (cons nil from))))) 2504 (cond 2505 ((< (cdr val) (or to (length text))) 2506 ;;Invalid sexp - leave it as a string 2507 (setq val (substring text from to))) 2508 ((and (car val) (symbolp (car val))) 2509 (if (consp arg) 2510 (setq val (list 'quote (car val))) ;Keep symbol 2511 (setq val (substring text from to)))) ;Treat symbol as text 2512 (t 2513 (setq val (car val)))) 2514 (let ((row (car rowcol)) 2515 (col (cdr rowcol))) 2516 (or (atom val) 2517 (setq val `(ses-safe-formula ,val))) 2518 (ses-cell-set-formula row col val)))) 2519 2520(defun ses-yank-tsf (text arg) 2521 "If TEXT contains tabs and/or newlines, treats the tabs as 2522column-separators and the newlines as row-separators and inserts the text as 2523cell formulas--else return nil. Treat plain symbols as strings unless ARG 2524is a list. Ignore a final newline." 2525 (if (or (not (string-match "[\t\n]" text)) 2526 (= (match-end 0) (length text))) 2527 ;;Not TSF format 2528 nil 2529 (if (/= (aref text (1- (length text))) ?\n) 2530 (setq text (concat text "\n"))) 2531 (let ((pos -1) 2532 (spots (list -1)) 2533 (cols 0) 2534 (needrows 0) 2535 needcols rowcol) 2536 ;;Find all the tabs and newlines 2537 (while (setq pos (string-match "[\t\n]" text (1+ pos))) 2538 (push pos spots) 2539 (setq cols (1+ cols)) 2540 (when (eq (aref text pos) ?\n) 2541 (if (not needcols) 2542 (setq needcols cols) 2543 (or (= needcols cols) 2544 (error "Inconsistent row lengths"))) 2545 (setq cols 0 2546 needrows (1+ needrows)))) 2547 ;;Insert the formulas 2548 (setq rowcol (ses-yank-resize needrows needcols)) 2549 (dotimes (row needrows) 2550 (dotimes (col needcols) 2551 (ses-yank-one (cons (+ (car rowcol) needrows (- row) -1) 2552 (+ (cdr rowcol) needcols (- col) -1)) 2553 text (1+ (cadr spots)) (car spots) arg) 2554 (setq spots (cdr spots)))) 2555 (ses-goto-print (+ (car rowcol) needrows -1) 2556 (+ (cdr rowcol) needcols -1)) 2557 t))) 2558 2559(defun ses-yank-resize (needrows needcols) 2560 "If this yank will require inserting rows and/or columns, asks for 2561confirmation and then inserts them. Result is (row,col) for top left of yank 2562spot, or error signal if user requests cancel." 2563 (ses-begin-change) 2564 (let ((rowcol (if ses--curcell 2565 (ses-sym-rowcol ses--curcell) 2566 (cons ses--numrows 0))) 2567 rowbool colbool) 2568 (setq needrows (- (+ (car rowcol) needrows) ses--numrows) 2569 needcols (- (+ (cdr rowcol) needcols) ses--numcols) 2570 rowbool (> needrows 0) 2571 colbool (> needcols 0)) 2572 (when (or rowbool colbool) 2573 ;;Need to insert. Get confirm 2574 (or (y-or-n-p (format "Yank will insert %s%s%s. Continue? " 2575 (if rowbool (format "%d rows" needrows) "") 2576 (if (and rowbool colbool) " and " "") 2577 (if colbool (format "%d columns" needcols) ""))) 2578 (error "Cancelled")) 2579 (when rowbool 2580 (let (ses--curcell) 2581 (save-excursion 2582 (ses-goto-print ses--numrows 0) 2583 (ses-insert-row needrows)))) 2584 (when colbool 2585 (ses-insert-column needcols 2586 ses--numcols 2587 (ses-col-width (1- ses--numcols)) 2588 (ses-col-printer (1- ses--numcols))))) 2589 rowcol)) 2590 2591(defun ses-export-tsv (beg end) 2592 "Export values from the current range, with tabs between columns and 2593newlines between rows. Result is placed in kill ring." 2594 (interactive "r") 2595 (ses-export-tab nil)) 2596 2597(defun ses-export-tsf (beg end) 2598 "Export formulas from the current range, with tabs between columns and 2599newlines between rows. Result is placed in kill ring." 2600 (interactive "r") 2601 (ses-export-tab t)) 2602 2603(defun ses-export-tab (want-formulas) 2604 "Export the current range with tabs between columns and newlines between 2605rows. Result is placed in kill ring. The export is values unless 2606WANT-FORMULAS is non-nil. Newlines and tabs in the export text are escaped." 2607 (ses-check-curcell 'needrange) 2608 (let ((print-escape-newlines t) 2609 result item) 2610 (ses-dorange ses--curcell 2611 (setq item (if want-formulas 2612 (ses-cell-formula row col) 2613 (ses-cell-value row col))) 2614 (if (eq (car-safe item) 'ses-safe-formula) 2615 ;;Hide our deferred safety-check marker 2616 (setq item (cadr item))) 2617 (if (or (not item) (eq item '*skip*)) 2618 (setq item "")) 2619 (when (eq (car-safe item) 'quote) 2620 (push "'" result) 2621 (setq item (cadr item))) 2622 (setq item (prin1-to-string item t)) 2623 (setq item (replace-regexp-in-string "\t" "\\\\t" item)) 2624 (push item result) 2625 (cond 2626 ((< col maxcol) 2627 (push "\t" result)) 2628 ((< row maxrow) 2629 (push "\n" result)))) 2630 (setq result (apply 'concat (nreverse result))) 2631 (kill-new result))) 2632 2633 2634;;---------------------------------------------------------------------------- 2635;; Other user commands 2636;;---------------------------------------------------------------------------- 2637 2638(defun ses-unset-header-row () 2639 "Select the default header row." 2640 (interactive) 2641 (ses-set-header-row 0)) 2642 2643(defun ses-set-header-row (row) 2644 "Set the ROW to display in the header-line. 2645With a numerical prefix arg, use that row. 2646With no prefix arg, use the current row. 2647With a \\[universal-argument] prefix arg, prompt the user. 2648The top row is row 1. Selecting row 0 displays the default header row." 2649 (interactive 2650 (list (if (numberp current-prefix-arg) current-prefix-arg 2651 (let ((currow (1+ (car (ses-sym-rowcol ses--curcell))))) 2652 (if current-prefix-arg 2653 (read-number "Header row: " currow) 2654 currow))))) 2655 (if (or (< row 0) (> row ses--numrows)) 2656 (error "Invalid header-row")) 2657 (ses-begin-change) 2658 (let ((oldval ses--header-row)) 2659 (let (buffer-undo-list) 2660 (ses-set-parameter 'ses--header-row row)) 2661 (push `(apply ses-set-header-row ,oldval) buffer-undo-list)) 2662 (ses-reset-header-string)) 2663 2664(defun ses-mark-row () 2665 "Marks the entirety of current row as a range." 2666 (interactive) 2667 (ses-check-curcell 'range) 2668 (let ((row (car (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell))))) 2669 (push-mark (point)) 2670 (ses-goto-print (1+ row) 0) 2671 (push-mark (point) nil t) 2672 (ses-goto-print row 0))) 2673 2674(defun ses-mark-column () 2675 "Marks the entirety of current column as a range." 2676 (interactive) 2677 (ses-check-curcell 'range) 2678 (let ((col (cdr (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell)))) 2679 (row 0)) 2680 (push-mark (point)) 2681 (ses-goto-print (1- ses--numrows) col) 2682 (forward-char 1) 2683 (push-mark (point) nil t) 2684 (while (eq '*skip* (ses-cell-value row col)) 2685 ;;Skip over initial cells in column that can't be selected 2686 (setq row (1+ row))) 2687 (ses-goto-print row col))) 2688 2689(defun ses-end-of-line () 2690 "Move point to last cell on line." 2691 (interactive) 2692 (ses-check-curcell 'end 'range) 2693 (when ses--curcell ;Otherwise we're at the bottom row, which is empty anyway 2694 (let ((col (1- ses--numcols)) 2695 row rowcol) 2696 (if (symbolp ses--curcell) 2697 ;;Single cell 2698 (setq row (car (ses-sym-rowcol ses--curcell))) 2699 ;;Range - use whichever end of the range the point is at 2700 (setq rowcol (ses-sym-rowcol (if (< (point) (mark)) 2701 (car ses--curcell) 2702 (cdr ses--curcell)))) 2703 ;;If range already includes the last cell in a row, point is actually 2704 ;;in the following row 2705 (if (<= (cdr rowcol) (1- col)) 2706 (setq row (car rowcol)) 2707 (setq row (1+ (car rowcol))) 2708 (if (= row ses--numrows) 2709 ;;Already at end - can't go anywhere 2710 (setq col 0)))) 2711 (when (< row ses--numrows) ;Otherwise it's a range that includes last cell 2712 (while (eq (ses-cell-value row col) '*skip*) 2713 ;;Back to beginning of multi-column cell 2714 (setq col (1- col))) 2715 (ses-goto-print row col))))) 2716 2717(defun ses-renarrow-buffer () 2718 "Narrow the buffer so only the print area is visible. Use after \\[widen]." 2719 (interactive) 2720 (setq ses--deferred-narrow t)) 2721 2722(defun ses-sort-column (sorter &optional reverse) 2723 "Sorts the range by a specified column. With prefix, sorts in 2724REVERSE order." 2725 (interactive "*sSort column: \nP") 2726 (ses-check-curcell 'needrange) 2727 (let ((min (ses-sym-rowcol (car ses--curcell))) 2728 (max (ses-sym-rowcol (cdr ses--curcell)))) 2729 (let ((minrow (car min)) 2730 (mincol (cdr min)) 2731 (maxrow (car max)) 2732 (maxcol (cdr max)) 2733 keys extracts end) 2734 (setq sorter (cdr (ses-sym-rowcol (intern (concat sorter "1"))))) 2735 (or (and sorter (>= sorter mincol) (<= sorter maxcol)) 2736 (error "Invalid sort column")) 2737 ;;Get key columns and sort them 2738 (dotimes (x (- maxrow minrow -1)) 2739 (ses-goto-print (+ minrow x) sorter) 2740 (setq end (next-single-property-change (point) 'intangible)) 2741 (push (cons (buffer-substring-no-properties (point) end) 2742 (+ minrow x)) 2743 keys)) 2744 (setq keys (sort keys #'(lambda (x y) (string< (car x) (car y))))) 2745 ;;Extract the lines in reverse sorted order 2746 (or reverse 2747 (setq keys (nreverse keys))) 2748 (dolist (x keys) 2749 (ses-goto-print (cdr x) (1+ maxcol)) 2750 (setq end (point)) 2751 (ses-goto-print (cdr x) mincol) 2752 (push (ses-copy-region (point) end) extracts)) 2753 (deactivate-mark) 2754 ;;Paste the lines sequentially 2755 (dotimes (x (- maxrow minrow -1)) 2756 (ses-goto-print (+ minrow x) mincol) 2757 (ses-set-curcell) 2758 (ses-yank-cells (pop extracts) nil))))) 2759 2760(defun ses-sort-column-click (event reverse) 2761 "Mouse version of `ses-sort-column'." 2762 (interactive "*e\nP") 2763 (setq event (event-end event)) 2764 (select-window (posn-window event)) 2765 (setq event (car (posn-col-row event))) ;Click column 2766 (let ((col 0)) 2767 (while (and (< col ses--numcols) (> event (ses-col-width col))) 2768 (setq event (- event (ses-col-width col) 1) 2769 col (1+ col))) 2770 (if (>= col ses--numcols) 2771 (ding) 2772 (ses-sort-column (ses-column-letter col) reverse)))) 2773 2774(defun ses-insert-range () 2775 "Inserts into minibuffer the list of cells currently highlighted in the 2776spreadsheet." 2777 (interactive "*") 2778 (let (x) 2779 (with-current-buffer (window-buffer minibuffer-scroll-window) 2780 (ses-command-hook) ;For ses-coverage 2781 (ses-check-curcell 'needrange) 2782 (setq x (cdr (macroexpand `(ses-range ,(car ses--curcell) 2783 ,(cdr ses--curcell)))))) 2784 (insert (substring (prin1-to-string (nreverse x)) 1 -1)))) 2785 2786(defun ses-insert-ses-range () 2787 "Inserts \"(ses-range x y)\" in the minibuffer to represent the currently 2788highlighted range in the spreadsheet." 2789 (interactive "*") 2790 (let (x) 2791 (with-current-buffer (window-buffer minibuffer-scroll-window) 2792 (ses-command-hook) ;For ses-coverage 2793 (ses-check-curcell 'needrange) 2794 (setq x (format "(ses-range %S %S)" 2795 (car ses--curcell) 2796 (cdr ses--curcell)))) 2797 (insert x))) 2798 2799(defun ses-insert-range-click (event) 2800 "Mouse version of `ses-insert-range'." 2801 (interactive "*e") 2802 (mouse-set-point event) 2803 (ses-insert-range)) 2804 2805(defun ses-insert-ses-range-click (event) 2806 "Mouse version of `ses-insert-ses-range'." 2807 (interactive "*e") 2808 (mouse-set-point event) 2809 (ses-insert-ses-range)) 2810 2811 2812;;---------------------------------------------------------------------------- 2813;; Checking formulas for safety 2814;;---------------------------------------------------------------------------- 2815 2816(defun ses-safe-printer (printer) 2817 "Returns PRINTER if safe, or the substitute printer `ses-unsafe' otherwise." 2818 (if (or (stringp printer) 2819 (stringp (car-safe printer)) 2820 (not printer) 2821 (ses-warn-unsafe printer 'unsafep-function)) 2822 printer 2823 'ses-unsafe)) 2824 2825(defun ses-safe-formula (formula) 2826 "Returns FORMULA if safe, or the substitute formula *unsafe* otherwise." 2827 (if (ses-warn-unsafe formula 'unsafep) 2828 formula 2829 `(ses-unsafe ',formula))) 2830 2831(defun ses-warn-unsafe (formula checker) 2832 "Applies CHECKER to FORMULA. If result is non-nil, asks user for 2833confirmation about FORMULA, which might be unsafe. Returns t if formula 2834is safe or user allows execution anyway. Always returns t if 2835`safe-functions' is t." 2836 (if (eq safe-functions t) 2837 t 2838 (setq checker (funcall checker formula)) 2839 (if (not checker) 2840 t 2841 (y-or-n-p (format "Formula %S\nmight be unsafe %S. Process it? " 2842 formula checker))))) 2843 2844 2845;;---------------------------------------------------------------------------- 2846;; Standard formulas 2847;;---------------------------------------------------------------------------- 2848 2849(defmacro ses-range (from to) 2850 "Expands to a list of cell-symbols for the range. The range automatically 2851expands to include any new row or column inserted into its middle. The SES 2852library code specifically looks for the symbol `ses-range', so don't create an 2853alias for this macro!" 2854 (let (result) 2855 (ses-dorange (cons from to) 2856 (push (ses-cell-symbol row col) result)) 2857 (cons 'list result))) 2858 2859(defun ses-delete-blanks (&rest args) 2860 "Return ARGS reversed, with the blank elements (nil and *skip*) removed." 2861 (let (result) 2862 (dolist (cur args) 2863 (unless (memq cur '(nil *skip*)) 2864 (push cur result))) 2865 result)) 2866 2867(defun ses+ (&rest args) 2868 "Compute the sum of the arguments, ignoring blanks." 2869 (apply '+ (apply 'ses-delete-blanks args))) 2870 2871(defun ses-average (list) 2872 "Computes the sum of the numbers in LIST, divided by their length. Blanks 2873are ignored. Result is always floating-point, even if all args are integers." 2874 (setq list (apply 'ses-delete-blanks list)) 2875 (/ (float (apply '+ list)) (length list))) 2876 2877(defmacro ses-select (fromrange test torange) 2878 "Select cells in FROMRANGE that are `equal' to TEST. For each match, return 2879the corresponding cell from TORANGE. The ranges are macroexpanded but not 2880evaluated so they should be either (ses-range BEG END) or (list ...). The 2881TEST is evaluated." 2882 (setq fromrange (cdr (macroexpand fromrange)) 2883 torange (cdr (macroexpand torange)) 2884 test (eval test)) 2885 (or (= (length fromrange) (length torange)) 2886 (error "ses-select: Ranges not same length")) 2887 (let (result) 2888 (dolist (x fromrange) 2889 (if (equal test (symbol-value x)) 2890 (push (car torange) result)) 2891 (setq torange (cdr torange))) 2892 (cons 'list result))) 2893 2894;;All standard formulas are safe 2895(dolist (x '(ses-cell-value ses-range ses-delete-blanks ses+ ses-average 2896 ses-select)) 2897 (put x 'side-effect-free t)) 2898 2899 2900;;---------------------------------------------------------------------------- 2901;; Standard print functions 2902;;---------------------------------------------------------------------------- 2903 2904;;These functions use the variables 'row' and 'col' that are 2905;;dynamically bound by ses-print-cell. We define these varables at 2906;;compile-time to make the compiler happy. 2907(eval-when-compile 2908 (dolist (x '(row col)) 2909 (make-local-variable x) 2910 (set x nil))) 2911 2912(defun ses-center (value &optional span fill) 2913 "Print VALUE, centered within column. FILL is the fill character for 2914centering (default = space). SPAN indicates how many additional rightward 2915columns to include in width (default = 0)." 2916 (let ((printer (or (ses-col-printer col) ses--default-printer)) 2917 (width (ses-col-width col)) 2918 half) 2919 (or fill (setq fill ?\s)) 2920 (or span (setq span 0)) 2921 (setq value (ses-call-printer printer value)) 2922 (dotimes (x span) 2923 (setq width (+ width 1 (ses-col-width (+ col span (- x)))))) 2924 (setq width (- width (length value))) 2925 (if (<= width 0) 2926 value ;Too large for field, anyway 2927 (setq half (make-string (/ width 2) fill)) 2928 (concat half value half 2929 (if (> (% width 2) 0) (char-to-string fill)))))) 2930 2931(defun ses-center-span (value &optional fill) 2932 "Print VALUE, centered within the span that starts in the current column 2933and continues until the next nonblank column. FILL specifies the fill 2934character (default = space)." 2935 (let ((end (1+ col))) 2936 (while (and (< end ses--numcols) 2937 (memq (ses-cell-value row end) '(nil *skip*))) 2938 (setq end (1+ end))) 2939 (ses-center value (- end col 1) fill))) 2940 2941(defun ses-dashfill (value &optional span) 2942 "Print VALUE centered using dashes. SPAN indicates how many rightward 2943columns to include in width (default = 0)." 2944 (ses-center value span ?-)) 2945 2946(defun ses-dashfill-span (value) 2947 "Print VALUE, centered using dashes within the span that starts in the 2948current column and continues until the next nonblank column." 2949 (ses-center-span value ?-)) 2950 2951(defun ses-tildefill-span (value) 2952 "Print VALUE, centered using tildes within the span that starts in the 2953current column and continues until the next nonblank column." 2954 (ses-center-span value ?~)) 2955 2956(defun ses-unsafe (value) 2957 "Substitute for an unsafe formula or printer" 2958 (error "Unsafe formula or printer")) 2959 2960;;All standard printers are safe, including ses-unsafe! 2961(dolist (x (cons 'ses-unsafe ses-standard-printer-functions)) 2962 (put x 'side-effect-free t)) 2963 2964(provide 'ses) 2965 2966;; arch-tag: 88c1ccf0-4293-4824-8c5d-0757b52217f3 2967;;; ses.el ends here 2968