1 ;;; ses.el -- Simple Emacs Spreadsheet -*- coding: utf-8 -*-
3 ;; Copyright (C) 2002-2014 Free Software Foundation, Inc.
5 ;; Author: Jonathan Yavner <jyavner@member.fsf.org>
6 ;; Maintainer: Vincent Belaïche <vincentb1@users.sourceforge.net>
7 ;; Keywords: spreadsheet Dijkstra
9 ;; This file is part of GNU Emacs.
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 3 of the License, or
14 ;; (at your option) any later version.
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; * split (catch 'cycle ...) call back into one or more functions
29 ;; * Use $ or … for truncated fields
30 ;; * Add command to make a range of columns be temporarily invisible.
31 ;; * Allow paste of one cell to a range of cells -- copy formula to each.
32 ;; * Do something about control characters & octal codes in cell print
33 ;; areas. Use string-width?
34 ;; * Input validation functions. How specified?
35 ;; * Faces (colors & styles) in print cells.
36 ;; * Move a column by dragging its letter in the header line.
37 ;; * Left-margin column for row number.
38 ;; * Move a row by dragging its number in the left-margin.
42 ;; Cycles used to be detected by stationarity of ses--deferred-recalc. This was
43 ;; working fine in most cases, however failed in some cases of several path
46 ;; The current algorithm is based on Dijkstra's algorithm. The cycle length is
47 ;; stored in some cell property. In order not to reset in all cells such
48 ;; property at each update, the cycle length is stored in this property along
49 ;; with some update attempt id that is incremented at each update. The current
50 ;; update id is ses--Dijkstra-attempt-nb. In case there is a cycle the cycle
51 ;; length diverge to infinite so it will exceed ses--Dijkstra-weight-bound at
52 ;; some point of time that allows detection. Otherwise it converges to the
53 ;; longest path length in the update tree.
59 (eval-when-compile (require 'cl-lib
))
62 ;;----------------------------------------------------------------------------
63 ;; User-customizable variables
64 ;;----------------------------------------------------------------------------
67 "Simple Emacs Spreadsheet."
73 (defcustom ses-initial-size
'(1 .
1)
74 "Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)."
76 :type
'(cons (integer :tag
"numrows") (integer :tag
"numcols")))
78 (defcustom ses-initial-column-width
7
79 "Initial width of columns in a new spreadsheet."
81 :type
'(integer :match
(lambda (widget value
) (> value
0))))
83 (defcustom ses-initial-default-printer
"%.7g"
84 "Initial default printer for a new spreadsheet."
87 (list :tag
"Parenthesized string" string
)
90 (defcustom ses-after-entry-functions
'(forward-char)
91 "Things to do after entering a value into a cell.
92 An abnormal hook that usually runs a cursor-movement function.
93 Each function is called with ARG=1."
96 :options
'(forward-char backward-char next-line previous-line
))
98 (defcustom ses-mode-hook nil
99 "Hook functions to be run upon entering SES mode."
104 ;;----------------------------------------------------------------------------
105 ;; Global variables and constants
106 ;;----------------------------------------------------------------------------
108 (defvar ses-read-cell-history nil
109 "List of formulas that have been typed in.")
111 (defvar ses-read-printer-history nil
112 "List of printer functions that have been typed in.")
114 (easy-menu-define ses-header-line-menu nil
115 "Context menu when mouse-3 is used on the header-line in an SES buffer."
117 ["Set current row" ses-set-header-row t
]
118 ["Unset row" ses-unset-header-row
(> ses--header-row
0)]))
120 (defconst ses-mode-map
121 (let ((keys `("\C-c\M-\C-l" ses-reconstruct-all
122 "\C-c\C-l" ses-recalculate-all
123 "\C-c\C-n" ses-renarrow-buffer
124 "\C-c\C-c" ses-recalculate-cell
125 "\C-c\M-\C-s" ses-sort-column
126 "\C-c\M-\C-h" ses-set-header-row
127 "\C-c\C-t" ses-truncate-cell
129 "\C-c\C-p" ses-read-default-printer
130 "\M-\C-l" ses-reprint-all
131 [?\S-\C-l
] ses-reprint-all
132 [header-line down-mouse-3
] ,ses-header-line-menu
133 [header-line mouse-2
] ses-sort-column-click
))
134 (newmap (make-sparse-keymap)))
136 (define-key (1value newmap
) (car keys
) (cadr keys
))
137 (setq keys
(cddr keys
)))
139 "Local keymap for Simple Emacs Spreadsheet.")
141 (easy-menu-define ses-menu ses-mode-map
142 "Menu bar menu for SES."
144 ["Insert row" ses-insert-row
(ses-in-print-area)]
145 ["Delete row" ses-delete-row
(ses-in-print-area)]
146 ["Insert column" ses-insert-column
(ses-in-print-area)]
147 ["Delete column" ses-delete-column
(ses-in-print-area)]
148 ["Set column printer" ses-read-column-printer t
]
149 ["Set column width" ses-set-column-width t
]
150 ["Set default printer" ses-read-default-printer t
]
151 ["Jump to cell" ses-jump t
]
152 ["Set cell printer" ses-read-cell-printer t
]
153 ["Recalculate cell" ses-recalculate-cell t
]
154 ["Truncate cell display" ses-truncate-cell t
]
155 ["Export values" ses-export-tsv t
]
156 ["Export formulas" ses-export-tsf t
]))
158 (defconst ses-mode-edit-map
159 (let ((keys '("\C-c\C-r" ses-insert-range
160 "\C-c\C-s" ses-insert-ses-range
161 [S-mouse-3
] ses-insert-range-click
162 [C-S-mouse-3
] ses-insert-ses-range-click
163 "\M-\C-i" lisp-complete-symbol
))
164 (newmap (make-sparse-keymap)))
165 (set-keymap-parent newmap minibuffer-local-map
)
167 (define-key newmap
(pop keys
) (pop keys
)))
169 "Local keymap for SES minibuffer cell-editing.")
171 ;Local keymap for SES print area
172 (defalias 'ses-mode-print-map
173 (let ((keys '([backtab] backward-char
174 [tab] ses-forward-or-insert
175 "\C-i" ses-forward-or-insert ; Needed for ses-coverage.el?
176 "\M-o" ses-insert-column
177 "\C-o" ses-insert-row
179 "\M-k" ses-delete-column
181 "\C-k" ses-delete-row
182 "\C-j" ses-append-row-jump-first-column
184 "\M-H" ses-mark-column
185 "\C-d" ses-clear-cell-forward
186 "\C-?" ses-clear-cell-backward
191 "c" ses-recalculate-cell
193 "p" ses-read-cell-printer
194 "t" ses-truncate-cell
195 "w" ses-set-column-width
196 "x" ses-export-keymap
197 "\M-p" ses-read-column-printer))
198 (repl '(;;We'll replace these wherever they appear in the keymap
199 clipboard-kill-region ses-kill-override
200 end-of-line ses-end-of-line
201 kill-line ses-delete-row
202 kill-region ses-kill-override
203 open-line ses-insert-row))
204 (numeric "0123456789.-")
205 (newmap (make-keymap)))
206 ;;Get rid of printables
207 (suppress-keymap newmap t)
208 ;;These keys insert themselves as the beginning of a numeric value
209 (dotimes (x (length numeric))
210 (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell))
211 ;;Override these global functions wherever they're bound
213 (substitute-key-definition (car repl) (cadr repl) newmap
214 (current-global-map))
215 (setq repl (cddr repl)))
216 ;;Apparently substitute-key-definition doesn't catch this?
217 (define-key newmap [(menu-bar) edit cut] 'ses-kill-override)
218 ;;Define our other local keys
220 (define-key newmap (car keys) (cadr keys))
221 (setq keys (cddr keys)))
224 ;;Helptext for ses-mode wants keymap as variable, not function
225 (defconst ses-mode-print-map (symbol-function 'ses-mode-print-map))
227 ;;Key map used for 'x' key.
228 (defalias 'ses-export-keymap
229 (let ((map (make-sparse-keymap "SES export")))
230 (define-key map "T" (cons " tab-formulas" 'ses-export-tsf))
231 (define-key map "t" (cons " tab-values" 'ses-export-tsv))
234 (defconst ses-print-data-boundary "\n\014\n"
235 "Marker string denoting the boundary between print area and data area.")
237 (defconst ses-initial-global-parameters
238 "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n"
239 "Initial contents for the three-element list at the bottom of the data area.")
241 (defconst ses-initial-global-parameters-re
242 "\n( ;Global parameters (these are read first)\n [23] ;SES file-format\n [0-9]+ ;numrows\n [0-9]+ ;numcols\n\\( [0-9]+ ;numlocprn\n\\)?)\n\n"
243 "Match Global parameters for .")
245 (defconst ses-initial-file-trailer
246 ";; Local Variables:\n;; mode: ses\n;; End:\n"
247 "Initial contents for the file-trailer area at the bottom of the file.")
249 (defconst ses-initial-file-contents
250 (concat " \n" ; One blank cell in print area.
251 ses-print-data-boundary
252 "(ses-cell A1 nil nil nil nil)\n" ; One blank cell in data area.
253 "\n" ; End-of-row terminator for the one row in data area.
254 "(ses-column-widths [7])\n"
255 "(ses-column-printers [nil])\n"
256 "(ses-default-printer \"%.7g\")\n"
257 "(ses-header-row 0)\n"
258 ses-initial-global-parameters
259 ses-initial-file-trailer)
260 "The initial contents of an empty spreadsheet.")
262 (defconst ses-box-prop '(:box (:line-width 2 :style released-button))
263 "Display properties to create a raised box for cells in the header line.")
265 (defconst ses-standard-printer-functions
266 '(ses-center ses-center-span ses-dashfill ses-dashfill-span
268 "List of print functions to be included in initial history of printer
269 functions. None of these standard-printer functions is suitable for use as a
270 column printer or a global-default printer because they invoke the column or
271 default printer and then modify its output.")
274 ;;----------------------------------------------------------------------------
275 ;; Local variables and constants
276 ;;----------------------------------------------------------------------------
278 (eval-and-compile ; silence compiler
279 (defconst ses-localvars
280 '(ses--blank-line ses--cells ses--col-printers
281 ses--col-widths ses--curcell ses--curcell-overlay
283 (ses--local-printer-hashmap . :hashmap)
284 ;; the list is there to remember the order of local printers like there
285 ;; are written to the SES filen which service the hashmap does not
287 ses--local-printer-list
288 (ses--numlocprn . 0); count of local printers
289 ses--deferred-narrow ses--deferred-recalc
290 ses--deferred-write ses--file-format
291 ses--named-cell-hashmap
292 (ses--header-hscroll . -1) ; Flag for "initial recalc needed"
293 ses--header-row ses--header-string ses--linewidth
294 ses--numcols ses--numrows ses--symbolic-formulas
295 ses--data-marker ses--params-marker (ses--Dijkstra-attempt-nb . 0)
296 ses--Dijkstra-weight-bound
297 ;; This list is useful to speed-up clean-up of symbols when
298 ;; an area containing renamed cell is deleted.
299 ses--renamed-cell-symb-list
300 ;; Global variables that we override
301 mode-line-process next-line-add-newlines transient-mark-mode)
302 "Buffer-local variables used by SES.")
304 (defun ses-set-localvars ()
305 "Set buffer-local and initialize some SES variables."
306 (dolist (x ses-localvars)
309 (set (make-local-variable x) nil))
313 (set (make-local-variable (car x)) (cdr x)))
314 ((eq (cdr x) :hashmap)
315 (set (make-local-variable (car x))
317 (let ((xv (symbol-value (car x))))
318 (if (hash-table-p xv)
320 (warn "Unexpected value of symbol %S, should be a hash table" x)
321 (make-hash-table :test 'eq)))
322 (make-hash-table :test 'eq))))
323 (t (error "Unexpected initializer `%S' in list `ses-localvars' for entry %S"
324 (cdr x) (car x)) ) ))
325 (t (error "Unexpected elements `%S' in list `ses-localvars'" x))))))
327 (eval-when-compile ; silence compiler
330 ;;; This variable is documented as being permitted in file-locals:
331 (put 'ses--symbolic-formulas 'safe-local-variable 'consp)
333 (defconst ses-paramlines-plist
334 '(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3
335 ses--header-row -2 ses--file-format 1 ses--numrows 2
336 ses--numcols 3 ses--numlocprn 4)
337 "Offsets from 'Global parameters' line to various parameter lines in the
338 data area of a spreadsheet.")
340 (defconst ses-paramfmt-plist
341 '(ses--col-widths "(ses-column-widths %S)"
342 ses--col-printers "(ses-column-printers %S)"
343 ses--default-printer "(ses-default-printer %S)"
344 ses--header-row "(ses-header-row %S)"
345 ses--file-format " %S ;SES file-format"
346 ses--numrows " %S ;numrows"
347 ses--numcols " %S ;numcols"
348 ses--numlocprn " %S ;numlocprn")
349 "Formats of 'Global parameters' various parameters in the data
350 area of a spreadsheet.")
353 ;; "Side-effect variables". They are set in one function, altered in
354 ;; another as a side effect, then read back by the first, as a way of
355 ;; passing back more than one value. These declarations are just to make
356 ;; the compiler happy, and to conform to standard Emacs-Lisp practice (I
357 ;; think the make-local-variable trick above is cleaner).
360 (defvar ses-relocate-return nil
361 "Set by `ses-relocate-formula' and `ses-relocate-range', read by
362 `ses-relocate-all'. Set to 'delete if a cell-reference was deleted from a
363 formula--so the formula needs recalculation. Set to 'range if the size of a
364 `ses-range' was changed--so both the formula's value and list of dependents
365 need to be recalculated.")
367 (defvar ses-call-printer-return nil
368 "Set to t if last cell printer invoked by `ses-call-printer' requested
369 left-justification of the result. Set to error-signal if `ses-call-printer'
370 encountered an error during printing. Otherwise nil.")
372 (defvar ses-start-time nil
373 "Time when current operation started. Used by `ses-time-check' to decide
374 when to emit a progress message.")
377 ;;----------------------------------------------------------------------------
379 ;;----------------------------------------------------------------------------
381 (defmacro ses-get-cell (row col)
382 "Return the cell structure that stores information about cell (ROW,COL)."
383 `(aref (aref ses--cells ,row) ,col))
385 ;; We might want to use defstruct here, but cells are explicitly used as
386 ;; arrays in ses-set-cell, so we'd need to fix this first. --Stef
387 (defsubst ses-make-cell (&optional symbol formula printer references
389 (vector symbol formula printer references property-list))
391 (defsubst ses-make-local-printer-info (def &optional compiled-def number)
393 (or compiled-def (ses-local-printer-compile def))
394 (or number ses--numlocprn)
396 (push v ses--local-printer-list)
397 (aset v 3 ses--local-printer-list)
400 (defmacro ses-locprn-get-compiled (locprn)
403 (defmacro ses-locprn-compiled-aset (locprn compiled)
404 `(aset ,locprn 1 ,compiled))
406 (defmacro ses-locprn-get-def (locprn)
409 (defmacro ses-locprn-def-aset (locprn def)
410 `(aset ,locprn 0 ,def))
412 (defmacro ses-locprn-get-number (locprn)
415 (defmacro ses-cell-symbol (row &optional col)
416 "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value. (0,0) => A1."
417 `(aref ,(if col `(ses-get-cell ,row ,col) row) 0))
418 (put 'ses-cell-symbol 'safe-function t)
420 (defmacro ses-cell-formula (row &optional col)
421 "From a CELL or a pair (ROW,COL), get the function that computes its value."
422 `(aref ,(if col `(ses-get-cell ,row ,col) row) 1))
424 (defmacro ses-cell-formula-aset (cell formula)
425 "From a CELL set the function that computes its value."
426 `(aset ,cell 1 ,formula))
428 (defmacro ses-cell-printer (row &optional col)
429 "From a CELL or a pair (ROW,COL), get the function that prints its value."
430 `(aref ,(if col `(ses-get-cell ,row ,col) row) 2))
432 (defmacro ses-cell-printer-aset (cell printer)
433 "From a CELL set the printer that prints its value."
434 `(aset ,cell 2 ,printer))
436 (defmacro ses-cell-references (row &optional col)
437 "From a CELL or a pair (ROW,COL), get the list of symbols for cells whose
438 functions refer to its value."
439 `(aref ,(if col `(ses-get-cell ,row ,col) row) 3))
441 (defmacro ses-cell-references-aset (cell references)
442 "From a CELL set the list REFERENCES of symbols for cells the
443 function of which refer to its value."
444 `(aset ,cell 3 ,references))
446 (defun ses-cell-p (cell)
447 "Return non `nil' is CELL is a cell of current buffer."
450 (eq cell (let ((rowcol (ses-sym-rowcol (ses-cell-symbol cell))))
452 (ses-get-cell (car rowcol) (cdr rowcol)))))))
454 (defun ses-cell-property-get-fun (property-name cell)
455 ;; To speed up property fetching, each time a property is found it is placed
456 ;; in the first position. This way, after the first get, the full property
457 ;; list needs to be scanned only when the property does not exist for that
459 (let* ((plist (aref cell 4))
460 (ret (plist-member plist property-name)))
462 ;; Property was found.
463 (let ((val (cadr ret)))
465 ;; Property found is already in the first position, so just return
468 ;; Property is not in the first position, the following will move it
469 ;; there before returning its value.
470 (let ((next (cddr ret)))
473 (setcdr ret (cdr next))
474 (setcar ret (car next)))
475 (setcdr (last plist 1) nil)))
477 `(,property-name ,val ,@plist))
480 (defmacro ses-cell-property-get (property-name row &optional col)
481 "Get property named PROPERTY-NAME from a CELL or a pair (ROW,COL).
483 When COL is omitted, CELL=ROW is a cell object. When COL is
484 present ROW and COL are the integer coordinates of the cell of
487 `(ses-cell-property-get-fun
489 ,(if col `(ses-get-cell ,row ,col) row)))
491 (defun ses-cell-property-delq-fun (property-name cell)
492 (let ((ret (plist-get (aref cell 4) property-name)))
494 (setcdr ret (cddr ret)))))
496 (defun ses-cell-property-set-fun (property-name property-val cell)
497 (let* ((plist (aref cell 4))
498 (ret (plist-member plist property-name)))
500 (setcar (cdr ret) property-val)
501 (aset cell 4 `(,property-name ,property-val ,@plist)))))
503 (defmacro ses-cell-property-set (property-name property-value row &optional col)
504 "From a CELL or a pair (ROW,COL), set the property value of
505 the corresponding cell with name PROPERTY-NAME to PROPERTY-VALUE."
507 `(ses-cell-property-set-fun ,property-name ,property-value
508 ,(if col `(ses-get-cell ,row ,col) row))
509 `(ses-cell-property-delq-fun ,property-name
510 ,(if col `(ses-get-cell ,row ,col) row))))
512 (defun ses-cell-property-pop-fun (property-name cell)
513 (let* ((plist (aref cell 4))
514 (ret (plist-member plist property-name)))
517 (let ((next (cddr ret)))
520 (setcdr ret (cdr next))
521 (setcar ret (car next)))
524 (setcdr (last plist 2) nil))))))))
527 (defmacro ses-cell-property-pop (property-name row &optional col)
528 "From a CELL or a pair (ROW,COL), get and remove the property value of
529 the corresponding cell with name PROPERTY-NAME."
530 `(ses-cell-property-pop-fun ,property-name
531 ,(if col `(ses-get-cell ,row ,col) row)))
533 (defun ses-cell-property-get-handle-fun (property-name cell)
534 (let* ((plist (aref cell 4))
535 (ret (plist-member plist property-name)))
539 (let ((val (cadr ret))
543 (setcdr ret (cdr next))
544 (setcar ret (car next)))
545 (setcdr (last plist 2) nil))
546 (setq ret (cons val plist))
547 (aset cell 4 (cons property-name ret))
549 (setq ret (cons nil plist))
550 (aset cell 4 (cons property-name ret))
553 (defmacro ses-cell-property-get-handle (property-name row &optional col)
554 "From a CELL or a pair (ROW,COL), get a cons cell whose car is
555 the property value of the corresponding cell property with name
557 `(ses-cell-property-get-handle-fun ,property-name
558 ,(if col `(ses-get-cell ,row ,col) row)))
561 (defalias 'ses-cell-property-handle-car 'car)
562 (defalias 'ses-cell-property-handle-setcar 'setcar)
564 (defmacro ses-cell-value (row &optional col)
565 "From a CELL or a pair (ROW,COL), get the current value for that cell."
566 `(symbol-value (ses-cell-symbol ,row ,col)))
568 (defmacro ses-col-width (col)
569 "Return the width for column COL."
570 `(aref ses--col-widths ,col))
572 (defmacro ses-col-printer (col)
573 "Return the default printer for column COL."
574 `(aref ses--col-printers ,col))
576 (defmacro ses-sym-rowcol (sym)
577 "From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0). Result
578 is nil if SYM is not a symbol that names a cell."
579 `(let ((rc (and (symbolp ,sym) (get ,sym 'ses-cell))))
580 (if (eq rc :ses-named)
581 (gethash ,sym ses--named-cell-hashmap)
584 (defun ses-is-cell-sym-p (sym)
585 "Check whether SYM point at a cell of this spread sheet."
586 (let ((rowcol (get sym 'ses-cell)))
588 (if (eq rowcol :ses-named)
589 (and ses--named-cell-hashmap (gethash sym ses--named-cell-hashmap))
590 (and (< (car rowcol) ses--numrows)
591 (< (cdr rowcol) ses--numcols)
592 (eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym))))))
594 (defmacro ses-cell (sym value formula printer references)
595 "Load a cell SYM from the spreadsheet file. Does not recompute VALUE from
596 FORMULA, does not reprint using PRINTER, does not check REFERENCES. This is a
597 macro to prevent propagate-on-load viruses. Safety-checking for FORMULA and
598 PRINTER are deferred until first use."
599 (let ((rowcol (ses-sym-rowcol sym)))
600 (ses-formula-record formula)
601 (ses-printer-record printer)
603 (eq safe-functions t)
604 (setq formula `(ses-safe-formula ,formula)))
607 (eq safe-functions t)
608 (setq printer `(ses-safe-printer ,printer)))
609 (aset (aref ses--cells (car rowcol))
611 (ses-make-cell sym formula printer references)))
615 (defun ses-local-printer-compile (printer)
616 "Convert local printer function into faster printer
619 ((functionp printer) printer)
621 `(lambda (x) (format ,printer x)))
622 (t (error "Invalid printer %S" printer))))
624 (defmacro ses-local-printer (printer-name printer-def)
625 "Define a local printer with name PRINTER-NAME and definition
626 PRINTER-DEF. Return the printer info."
628 (and (symbolp printer-name)
629 (ses-printer-validate printer-def))
630 (error "Invalid local printer definition"))
631 (and (gethash printer-name ses--local-printer-hashmap)
632 (error "Duplicate printer definition %S" printer-name))
633 (add-to-list 'ses-read-printer-history (symbol-name printer-name))
634 (puthash printer-name
635 (ses-make-local-printer-info (ses-safe-printer printer-def))
636 ses--local-printer-hashmap))
638 (defmacro ses-column-widths (widths)
639 "Load the vector of column widths from the spreadsheet file. This is a
640 macro to prevent propagate-on-load viruses."
641 (or (and (vectorp widths) (= (length widths) ses--numcols))
642 (error "Bad column-width vector"))
643 ;;To save time later, we also calculate the total width of each line in the
644 ;;print area (excluding the terminating newline)
645 (setq ses--col-widths widths
646 ses--linewidth (apply '+ -1 (mapcar '1+ widths))
647 ses--blank-line (concat (make-string ses--linewidth ?\s) "\n"))
650 (defmacro ses-column-printers (printers)
651 "Load the vector of column printers from the spreadsheet file and checks
652 them for safety. This is a macro to prevent propagate-on-load viruses."
653 (or (and (vectorp printers) (= (length printers) ses--numcols))
654 (error "Bad column-printers vector"))
655 (dotimes (x ses--numcols)
656 (aset printers x (ses-safe-printer (aref printers x))))
657 (setq ses--col-printers printers)
658 (mapc 'ses-printer-record printers)
661 (defmacro ses-default-printer (def)
662 "Load the global default printer from the spreadsheet file and checks it
663 for safety. This is a macro to prevent propagate-on-load viruses."
664 (setq ses--default-printer (ses-safe-printer def))
665 (ses-printer-record def)
668 (defmacro ses-header-row (row)
669 "Load the header row from the spreadsheet file and checks it
670 for safety. This is a macro to prevent propagate-on-load viruses."
671 (or (and (wholenump row) (or (zerop ses--numrows) (< row ses--numrows)))
672 (error "Bad header-row"))
673 (setq ses--header-row row)
676 (defmacro ses-dorange (curcell &rest body)
677 "Execute BODY repeatedly, with the variables `row' and `col' set to each
678 cell in the range specified by CURCELL. The range is available in the
679 variables `minrow', `maxrow', `mincol', and `maxcol'."
680 (declare (indent defun) (debug (form body)))
681 (let ((cur (make-symbol "cur"))
682 (min (make-symbol "min"))
683 (max (make-symbol "max"))
684 (r (make-symbol "r"))
685 (c (make-symbol "c")))
686 `(let* ((,cur ,curcell)
687 (,min (ses-sym-rowcol (if (consp ,cur) (car ,cur) ,cur)))
688 (,max (ses-sym-rowcol (if (consp ,cur) (cdr ,cur) ,cur))))
689 (let ((minrow (car ,min))
694 (if (or (> minrow maxrow) (> mincol maxcol))
695 (error "Empty range"))
696 (dotimes (,r (- maxrow minrow -1))
697 (setq row (+ ,r minrow))
698 (dotimes (,c (- maxcol mincol -1))
699 (setq col (+ ,c mincol))
702 ;;Support for coverage testing.
703 (defmacro 1value (form)
704 "For code-coverage testing, indicate that FORM is expected to always have
707 (defmacro noreturn (form)
708 "For code-coverage testing, indicate that FORM will always signal an error."
712 ;;----------------------------------------------------------------------------
714 ;;----------------------------------------------------------------------------
716 (defun ses-vector-insert (array idx new)
717 "Create a new vector which is one larger than ARRAY and has NEW inserted
719 (let* ((len (length array))
720 (result (make-vector (1+ len) new)))
723 (if (< x idx) x (1+ x))
727 ;;Allow ARRAY to be a symbol for use in buffer-undo-list
728 (defun ses-vector-delete (array idx count)
729 "Create a new vector which is a copy of ARRAY with COUNT objects removed
730 starting at element IDX. ARRAY is either a vector or a symbol whose value
731 is a vector--if a symbol, the new vector is assigned as the symbol's value."
732 (let* ((a (if (arrayp array) array (symbol-value array)))
733 (len (- (length a) count))
734 (result (make-vector len nil)))
736 (aset result x (aref a (if (< x idx) x (+ x count)))))
741 (defun ses-delete-line (count)
742 "Like `kill-line', but no kill ring."
745 (delete-region pos (point))))
747 (defun ses-printer-validate (printer)
748 "Signal an error if PRINTER is not a valid SES cell printer."
751 ;; printer is a local printer
752 (and (symbolp printer) (gethash printer ses--local-printer-hashmap))
754 (and (stringp (car-safe printer)) (not (cdr printer)))
755 (error "Invalid printer function"))
758 (defun ses-printer-record (printer)
759 "Add PRINTER to `ses-read-printer-history' if not already there, after first
760 checking that it is a valid printer function."
761 (ses-printer-validate printer)
762 ;;To speed things up, we avoid calling prin1 for the very common "nil" case.
764 (add-to-list 'ses-read-printer-history (prin1-to-string printer))))
766 (defun ses-formula-record (formula)
767 "If FORMULA is of the form 'symbol, add it to the list of symbolic formulas
768 for this spreadsheet."
769 (when (and (eq (car-safe formula) 'quote)
770 (symbolp (cadr formula)))
771 (add-to-list 'ses--symbolic-formulas
772 (list (symbol-name (cadr formula))))))
774 (defun ses-column-letter (col)
775 "Return the alphabetic name of column number COL.
776 0-25 become A-Z; 26-701 become AA-ZZ, and so on."
777 (let ((units (char-to-string (+ ?A (% col 26)))))
780 (concat (ses-column-letter (1- (/ col 26))) units))))
782 (defun ses-create-cell-symbol (row col)
783 "Produce a symbol that names the cell (ROW,COL). (0,0) => 'A1."
784 (intern (concat (ses-column-letter col) (number-to-string (1+ row)))))
786 (defun ses-decode-cell-symbol (str)
787 "Decode a symbol \"A1\" => (0,0). Returns `nil' if STR is not a
788 canonical cell name. Does not save match data."
789 (let (case-fold-search)
790 (and (string-match "\\`\\([A-Z]+\\)\\([0-9]+\\)\\'" str)
791 (let* ((col-str (match-string-no-properties 1 str))
794 (col-idx (1- (length col-str)))
795 (row (1- (string-to-number (match-string-no-properties 2 str)))))
800 (setq col (+ col (* (- (aref col-str col-idx) ?A) col-base))
801 col-base (* col-base 26)
802 col-idx (1- col-idx))
804 (setq col (+ col col-base)))))
807 (defun ses-create-cell-variable-range (minrow maxrow mincol maxcol)
808 "Create buffer-local variables for cells. This is undoable."
809 (push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
812 (dotimes (row (1+ (- maxrow minrow)))
813 (dotimes (col (1+ (- maxcol mincol)))
814 (setq xrow (+ row minrow)
816 sym (ses-create-cell-symbol xrow xcol))
817 (put sym 'ses-cell (cons xrow xcol))
818 (make-local-variable sym)))))
820 (defun ses-create-cell-variable (sym row col)
821 "Create a buffer-local variable `SYM' for cell at position (ROW, COL).
823 SYM is the symbol for that variable, ROW and COL are integers for
824 row and column of the cell, with numbering starting from 0.
826 Return nil in case of failure."
827 (unless (local-variable-p sym)
828 (make-local-variable sym)
829 (if (let (case-fold-search) (string-match-p "\\`[A-Z]+[0-9]+\\'" (symbol-name sym)))
830 (put sym 'ses-cell (cons row col))
831 (put sym 'ses-cell :ses-named)
832 (setq ses--named-cell-hashmap (or ses--named-cell-hashmap (make-hash-table :test 'eq)))
833 (puthash sym (cons row col) ses--named-cell-hashmap))))
835 ;; We do not delete the ses-cell properties for the cell-variables, in
836 ;; case a formula that refers to this cell is in the kill-ring and is
837 ;; later pasted back in.
838 (defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol)
839 "Destroy buffer-local variables for cells. This is undoable."
841 (dotimes (row (1+ (- maxrow minrow)))
842 (dotimes (col (1+ (- maxcol mincol)))
843 (let ((xrow (+ row minrow)) (xcol (+ col mincol)))
844 (setq sym (if (and (< xrow ses--numrows) (< xcol ses--numcols))
845 (ses-cell-symbol xrow xcol)
846 (ses-create-cell-symbol xrow xcol))))
848 (push `(apply ses-set-with-undo ,sym ,(symbol-value sym))
850 (kill-local-variable sym))))
851 (push `(apply ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
854 (defun ses-reset-header-string ()
855 "Flag the header string for update. Upon undo, the header string will be
857 (push '(apply ses-reset-header-string) buffer-undo-list)
858 (setq ses--header-hscroll -1))
860 ;;Split this code off into a function to avoid coverage-testing difficulties
861 (defun ses-time-check (format arg)
862 "If `ses-start-time' is more than a second ago, call `message' with FORMAT
863 and (eval ARG) and reset `ses-start-time' to the current time."
864 (when (> (- (float-time) ses-start-time) 1.0)
865 (message format (eval arg))
866 (setq ses-start-time (float-time)))
870 ;;----------------------------------------------------------------------------
872 ;;----------------------------------------------------------------------------
874 (defun ses-set-cell (row col field val)
875 "Install VAL as the contents for field FIELD (named by a quoted symbol) of
876 cell (ROW,COL). This is undoable. The cell's data will be updated through
877 `post-command-hook'."
878 (let ((cell (ses-get-cell row col))
879 (elt (plist-get '(value t symbol 0 formula 1 printer 2 references 3)
882 (or elt (signal 'args-out-of-range nil))
883 (setq change (if (eq elt t)
884 (ses-set-with-undo (ses-cell-symbol cell) val)
885 (ses-aset-with-undo cell elt val)))
887 (add-to-list 'ses--deferred-write (cons row col))))
888 nil) ; Make coverage-tester happy.
890 (defun ses-cell-set-formula (row col formula)
891 "Store a new formula for (ROW . COL) and enqueue the cell for
892 recalculation via `post-command-hook'. Updates the reference lists for the
893 cells that this cell refers to. Does not update cell value or reprint the
894 cell. To avoid inconsistencies, this function is not interruptible, which
895 means Emacs will crash if FORMULA contains a circular list."
896 (let* ((cell (ses-get-cell row col))
897 (old (ses-cell-formula cell)))
898 (let ((sym (ses-cell-symbol cell))
899 (oldref (ses-formula-references old))
900 (newref (ses-formula-references formula))
903 (add-to-list 'ses--deferred-recalc sym)
904 ;;Delete old references from this cell. Skip the ones that are also
907 (unless (memq ref newref)
908 (setq x (ses-sym-rowcol ref)
911 (ses-set-cell xrow xcol 'references
912 (delq sym (ses-cell-references xrow xcol)))))
913 ;;Add new ones. Skip ones left over from old list
915 (setq x (ses-sym-rowcol ref)
918 x (ses-cell-references xrow xcol))
920 (ses-set-cell xrow xcol 'references (cons sym x))))
921 (ses-formula-record formula)
922 (ses-set-cell row col 'formula formula))))
925 (defun ses-repair-cell-reference-all ()
926 "Repair cell reference and warn if there was some reference corruption."
929 ;; Step 1, reset :ses-repair-reference cell property in the whole sheet.
930 (dotimes (row ses--numrows)
931 (dotimes (col ses--numcols)
932 (let ((references (ses-cell-property-pop :ses-repair-reference
936 (ses-cell-symbol row col)
938 references) errors)))))
940 ;; Step 2, build new.
941 (dotimes (row ses--numrows)
942 (dotimes (col ses--numcols)
943 (let* ((cell (ses-get-cell row col))
944 (sym (ses-cell-symbol cell))
945 (formula (ses-cell-formula cell))
946 (new-ref (ses-formula-references formula)))
947 (dolist (ref new-ref)
948 (let* ((rowcol (ses-sym-rowcol ref))
949 (h (ses-cell-property-get-handle :ses-repair-reference
950 (car rowcol) (cdr rowcol))))
951 (unless (memq ref (ses-cell-property-handle-car h))
952 (ses-cell-property-handle-setcar
955 (ses-cell-property-handle-car h)))))))))
957 ;; Step 3, overwrite with check.
958 (dotimes (row ses--numrows)
959 (dotimes (col ses--numcols)
960 (let* ((cell (ses-get-cell row col))
961 (irrelevant (ses-cell-references cell))
962 (new-ref (ses-cell-property-pop :ses-repair-reference cell))
964 (dolist (ref new-ref)
965 (if (memq ref irrelevant)
966 (setq irrelevant (delq ref irrelevant))
968 (ses-set-cell row col 'references new-ref)
969 (when (or missing irrelevant)
970 (push `( ,(ses-cell-symbol cell)
971 ,@(and missing (list :missing missing))
972 ,@(and irrelevant (list :irrelevant irrelevant)))
975 (warn "----------------------------------------------------------------
976 Some references were corrupted.
978 The following is a list where each element ELT is such
979 that (car ELT) is the reference of cell CELL with corruption,
980 and (cdr ELT) is a property list where
982 * property `:corrupt-property' means that
983 property `:ses-repair-reference' of cell CELL was initially non
986 * property `:missing' is a list of missing references
988 * property `:irrelevant' is a list of non needed references
991 (message "No reference corruption found"))))
993 (defun ses-calculate-cell (row col force)
994 "Calculate and print the value for cell (ROW,COL) using the cell's formula
995 function and print functions, if any. Result is nil for normal operation, or
996 the error signal if the formula or print function failed. The old value is
997 left unchanged if it was *skip* and the new value is nil.
998 Any cells that depend on this cell are queued for update after the end of
999 processing for the current keystroke, unless the new value is the same as
1000 the old and FORCE is nil."
1001 (let ((cell (ses-get-cell row col))
1002 cycle-error formula-error printer-error)
1003 (let ((oldval (ses-cell-value cell))
1004 (formula (ses-cell-formula cell))
1006 this-cell-Dijkstra-attempt-h
1007 this-cell-Dijkstra-attempt
1008 this-cell-Dijkstra-attempt+1
1009 ref-cell-Dijkstra-attempt-h
1010 ref-cell-Dijkstra-attempt
1012 (when (eq (car-safe formula) 'ses-safe-formula)
1013 (setq formula (ses-safe-formula (cadr formula)))
1014 (ses-set-cell row col 'formula formula))
1016 (setq newval (eval formula))
1018 ;; Variable `sig' can't be nil.
1019 (nconc sig (list (ses-cell-symbol cell)))
1020 (setq formula-error sig
1022 (if (and (not newval) (eq oldval '*skip*))
1023 ;; Don't lose the *skip* --- previous field spans this one.
1024 (setq newval '*skip*))
1026 (when (or force (not (eq newval oldval)))
1027 (add-to-list 'ses--deferred-write (cons row col)) ; In case force=t.
1028 (setq this-cell-Dijkstra-attempt-h
1029 (ses-cell-property-get-handle :ses-Dijkstra-attempt cell);
1030 this-cell-Dijkstra-attempt
1031 (ses-cell-property-handle-car this-cell-Dijkstra-attempt-h))
1032 (if (null this-cell-Dijkstra-attempt)
1033 (ses-cell-property-handle-setcar
1034 this-cell-Dijkstra-attempt-h
1035 (setq this-cell-Dijkstra-attempt
1036 (cons ses--Dijkstra-attempt-nb 0)))
1037 (unless (= ses--Dijkstra-attempt-nb
1038 (car this-cell-Dijkstra-attempt))
1039 (setcar this-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb)
1040 (setcdr this-cell-Dijkstra-attempt 0)))
1041 (setq this-cell-Dijkstra-attempt+1
1042 (1+ (cdr this-cell-Dijkstra-attempt)))
1043 (ses-set-cell row col 'value newval)
1044 (dolist (ref (ses-cell-references cell))
1045 (add-to-list 'ses--deferred-recalc ref)
1046 (setq ref-rowcol (ses-sym-rowcol ref)
1047 ref-cell-Dijkstra-attempt-h
1048 (ses-cell-property-get-handle
1049 :ses-Dijkstra-attempt
1050 (car ref-rowcol) (cdr ref-rowcol))
1051 ref-cell-Dijkstra-attempt
1052 (ses-cell-property-handle-car ref-cell-Dijkstra-attempt-h))
1054 (if (null ref-cell-Dijkstra-attempt)
1055 (ses-cell-property-handle-setcar
1056 ref-cell-Dijkstra-attempt-h
1057 (setq ref-cell-Dijkstra-attempt
1058 (cons ses--Dijkstra-attempt-nb
1059 this-cell-Dijkstra-attempt+1)))
1060 (if (= (car ref-cell-Dijkstra-attempt) ses--Dijkstra-attempt-nb)
1061 (setcdr ref-cell-Dijkstra-attempt
1062 (max (cdr ref-cell-Dijkstra-attempt)
1063 this-cell-Dijkstra-attempt+1))
1064 (setcar ref-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb)
1065 (setcdr ref-cell-Dijkstra-attempt
1066 this-cell-Dijkstra-attempt+1)))
1068 (when (> this-cell-Dijkstra-attempt+1 ses--Dijkstra-weight-bound)
1069 ;; Update print of this cell.
1070 (throw 'cycle (setq formula-error
1071 `(error ,(format "Found cycle on cells %S"
1072 (ses-cell-symbol cell)))
1073 cycle-error formula-error)))))))
1074 (setq printer-error (ses-print-cell row col))
1077 (error (error-message-string cycle-error)))
1078 formula-error printer-error)))
1080 (defun ses-clear-cell (row col)
1081 "Delete formula and printer for cell (ROW,COL)."
1082 (ses-set-cell row col 'printer nil)
1083 (ses-cell-set-formula row col nil))
1085 (defcustom ses-self-reference-early-detection nil
1086 "True if cycle detection is early for cells that refer to themselves."
1091 (defun ses-update-cells (list &optional force)
1092 "Recalculate cells in LIST, checking for dependency loops. Prints
1093 progress messages every second. Dependent cells are not recalculated
1094 if the cell's value is unchanged and FORCE is nil."
1095 (let ((ses--deferred-recalc list)
1098 curlist prevlist this-sym this-rowcol formula)
1099 (with-temp-message " "
1100 (while ses--deferred-recalc
1101 ;; In each loop, recalculate cells that refer only to other cells that
1102 ;; have already been recalculated or aren't in the recalculation region.
1103 ;; Repeat until all cells have been processed or until the set of cells
1104 ;; being worked on stops changing.
1106 (message "Recalculating... (%d cells left)"
1107 (length ses--deferred-recalc)))
1108 (setq curlist ses--deferred-recalc
1109 ses--deferred-recalc nil
1112 ;; this-sym has to be popped from curlist *BEFORE* the check, and not
1113 ;; after because of the case of cells referring to themselves.
1114 (setq this-sym (pop curlist)
1115 this-rowcol (ses-sym-rowcol this-sym)
1116 formula (ses-cell-formula (car this-rowcol)
1119 (dolist (ref (ses-formula-references formula))
1120 (if (and ses-self-reference-early-detection (eq ref this-sym))
1121 (error "Cycle found: cell %S is self-referring" this-sym)
1122 (when (or (memq ref curlist)
1123 (memq ref ses--deferred-recalc))
1124 ;; This cell refers to another that isn't done yet
1125 (add-to-list 'ses--deferred-recalc this-sym)
1127 ;; ses-update-cells is called from post-command-hook, so
1128 ;; inhibit-quit is implicitly bound to t.
1130 ;; Abort the recalculation. User will probably undo now.
1132 (ses-calculate-cell (car this-rowcol) (cdr this-rowcol) force)))
1133 (dolist (ref ses--deferred-recalc)
1134 (add-to-list 'nextlist ref)))
1135 (when ses--deferred-recalc
1136 ;; Just couldn't finish these.
1137 (dolist (x ses--deferred-recalc)
1138 (let ((this-rowcol (ses-sym-rowcol x)))
1139 (ses-set-cell (car this-rowcol) (cdr this-rowcol) 'value '*error*)
1140 (1value (ses-print-cell (car this-rowcol) (cdr this-rowcol)))))
1141 (error "Circular references: %s" ses--deferred-recalc))
1143 ;; Can't use save-excursion here: if the cell under point is updated,
1144 ;; save-excursion's marker will move past the cell.
1148 ;;----------------------------------------------------------------------------
1150 ;;----------------------------------------------------------------------------
1152 (defun ses-in-print-area ()
1153 "Return t if point is in print area of spreadsheet."
1154 (<= (point) ses--data-marker))
1156 ;; We turn off point-motion-hooks and explicitly position the cursor, in case
1157 ;; the intangible properties have gotten screwed up (e.g., when ses-goto-print
1158 ;; is called during a recursive ses-print-cell).
1159 (defun ses-goto-print (row col)
1160 "Move point to print area for cell (ROW,COL)."
1161 (let ((inhibit-point-motion-hooks t)
1163 (goto-char (point-min))
1165 ;; Calculate column position.
1167 (setq n (+ n (ses-col-width c) 1)))
1168 ;; Move to the position.
1169 (and (> n (move-to-column n))
1171 ;; Move point to the bol of next line (for TAB at the last cell).
1174 (defun ses-set-curcell ()
1175 "Set `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a
1176 region, or nil if cursor is not at a cell."
1177 (if (or (not mark-active)
1179 (= (region-beginning) (region-end)))
1181 (setq ses--curcell (get-text-property (point) 'intangible))
1183 (let ((bcell (get-text-property (region-beginning) 'intangible))
1184 (ecell (get-text-property (1- (region-end)) 'intangible)))
1185 (when (= (region-end) ses--data-marker)
1186 ;; Correct for overflow.
1187 (setq ecell (get-text-property (- (region-end) 2) 'intangible)))
1188 (setq ses--curcell (if (and bcell ecell)
1193 (defun ses-check-curcell (&rest args)
1194 "Signal an error if `ses--curcell' is inappropriate.
1195 The end marker is appropriate if some argument is 'end.
1196 A range is appropriate if some argument is 'range.
1197 A single cell is appropriate unless some argument is 'needrange."
1198 (if (eq ses--curcell t)
1199 ;; curcell recalculation was postponed, but user typed ahead.
1203 (or (memq 'end args)
1204 (error "Not at cell")))
1205 ((consp ses--curcell)
1206 (or (memq 'range args)
1207 (memq 'needrange args)
1208 (error "Can't use a range")))
1209 ((memq 'needrange args)
1210 (error "Need a range"))))
1212 (defun ses-print-cell (row col)
1213 "Format and print the value of cell (ROW,COL) to the print area.
1214 Use the cell's printer function. If the cell's new print form is too wide,
1215 it will spill over into the following cell, but will not run off the end of the
1216 row or overwrite the next non-nil field. Result is nil for normal operation,
1217 or the error signal if the printer function failed and the cell was formatted
1218 with \"%s\". If the cell's value is *skip*, nothing is printed because the
1219 preceding cell has spilled over."
1220 (catch 'ses-print-cell
1221 (let* ((cell (ses-get-cell row col))
1222 (value (ses-cell-value cell))
1223 (printer (ses-cell-printer cell))
1225 text sig startpos x)
1226 ;; Create the string to print.
1229 ;; Don't print anything.
1230 (throw 'ses-print-cell nil))
1231 ((eq value '*error*)
1232 (setq text (make-string (ses-col-width col) ?#)))
1234 ;; Deferred safety-check on printer.
1235 (if (eq (car-safe printer) 'ses-safe-printer)
1236 (ses-set-cell row col 'printer
1237 (setq printer (ses-safe-printer (cadr printer)))))
1239 (setq text (ses-call-printer (or printer
1240 (ses-col-printer col)
1241 ses--default-printer)
1243 (if (consp ses-call-printer-return)
1244 ;; Printer returned an error.
1245 (setq sig ses-call-printer-return))))
1246 ;; Adjust print width to match column width.
1247 (let ((width (ses-col-width col))
1248 (len (string-width text)))
1251 ;; Fill field to length with spaces.
1252 (setq len (make-string (- width len) ?\s)
1253 text (if (eq ses-call-printer-return t)
1255 (concat len text))))
1257 ;; Spill over into following cells, if possible.
1258 (let ((maxwidth width))
1259 (while (and (> len maxwidth)
1260 (< maxcol ses--numcols)
1261 (or (not (setq x (ses-cell-value row maxcol)))
1264 ;; Set this cell to '*skip* so it won't overwrite our spillover.
1265 (ses-set-cell row maxcol 'value '*skip*))
1266 (setq maxwidth (+ maxwidth (ses-col-width maxcol) 1)
1267 maxcol (1+ maxcol)))
1268 (if (<= len maxwidth)
1269 ;; Fill to complete width of all the fields spanned.
1270 (setq text (concat text (make-string (- maxwidth len) ?\s)))
1271 ;; Not enough room to end of line or next non-nil field. Truncate
1272 ;; if string or decimal; otherwise fill with error indicator.
1273 (setq sig `(error "Too wide" ,text))
1276 (setq text (truncate-string-to-width text maxwidth 0 ?\s)))
1277 ((and (numberp value)
1278 (string-match "\\.[0-9]+" text)
1281 (- (match-end 0) (match-beginning 0))))))
1282 ;; Turn 6.6666666666e+49 into 6.66e+49. Rounding is too hard!
1283 (setq text (concat (substring text
1285 (- (match-beginning 0) width))
1286 (substring text (match-end 0)))))
1288 (setq text (make-string maxwidth ?#)))))))))
1289 ;; Substitute question marks for tabs and newlines. Newlines are used as
1290 ;; row-separators; tabs could confuse the reimport logic.
1291 (setq text (replace-regexp-in-string "[\t\n]" "?" text))
1292 (ses-goto-print row col)
1293 (setq startpos (point))
1294 ;; Install the printed result. This is not interruptible.
1295 (let ((inhibit-read-only t)
1297 (let ((inhibit-point-motion-hooks t))
1298 (delete-region (point) (progn
1299 (move-to-column (+ (current-column)
1300 (string-width text)))
1302 ;; We use concat instead of inserting separate strings in order to
1303 ;; reduce the number of cells in the undo list.
1304 (setq x (concat text (if (< maxcol ses--numcols) " " "\n")))
1305 ;; We use set-text-properties to prevent a wacky print function from
1306 ;; inserting rogue properties, and to ensure that the keymap property is
1307 ;; inherited (is it a bug that only unpropertized strings actually
1308 ;; inherit from surrounding text?)
1309 (set-text-properties 0 (length x) nil x)
1310 (insert-and-inherit x)
1311 (put-text-property startpos (point) 'intangible
1312 (ses-cell-symbol cell))
1313 (when (and (zerop row) (zerop col))
1314 ;; Reconstruct special beginning-of-buffer attributes.
1315 (put-text-property (point-min) (point) 'keymap 'ses-mode-print-map)
1316 (put-text-property (point-min) (point) 'read-only 'ses)
1317 (put-text-property (point-min) (1+ (point-min)) 'front-sticky t)))
1318 (if (= row (1- ses--header-row))
1319 ;; This line is part of the header --- force recalc.
1320 (ses-reset-header-string))
1321 ;; If this cell (or a preceding one on the line) previously spilled over
1322 ;; and has gotten shorter, redraw following cells on line recursively.
1323 (when (and (< maxcol ses--numcols)
1324 (eq (ses-cell-value row maxcol) '*skip*))
1325 (ses-set-cell row maxcol 'value nil)
1326 (ses-print-cell row maxcol))
1327 ;; Return to start of cell.
1328 (goto-char startpos)
1331 (defun ses-call-printer (printer &optional value)
1332 "Invoke PRINTER (a string or parenthesized string or function-symbol or
1333 lambda of one argument) on VALUE. Result is the printed cell as a string.
1334 The variable `ses-call-printer-return' is set to t if the printer used
1335 parenthesis to request left-justification, or the error-signal if the
1336 printer signaled one (and \"%s\" is used as the default printer), else nil."
1337 (setq ses-call-printer-return nil)
1338 (condition-case signal
1342 (format printer value)
1344 ((stringp (car-safe printer))
1345 (setq ses-call-printer-return t)
1347 (format (car printer) value)
1350 (setq value (funcall
1351 (or (and (symbolp printer)
1352 (let ((locprn (gethash printer ses--local-printer-hashmap)))
1354 (ses-locprn-get-compiled locprn))))
1359 (or (stringp (car-safe value))
1360 (error "Printer should return \"string\" or (\"string\")"))
1361 (setq ses-call-printer-return t)
1364 (setq ses-call-printer-return signal)
1365 (prin1-to-string value t))))
1367 (defun ses-adjust-print-width (col change)
1368 "Insert CHANGE spaces in front of column COL, or at end of line if
1369 COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind
1370 `inhibit-quit' to t."
1371 (let ((inhibit-read-only t)
1372 (blank (if (> change 0) (make-string change ?\s)))
1373 (at-end (= col ses--numcols)))
1374 (ses-set-with-undo 'ses--linewidth (+ ses--linewidth change))
1375 ;; ses-set-with-undo always returns t for strings.
1376 (1value (ses-set-with-undo 'ses--blank-line
1377 (concat (make-string ses--linewidth ?\s) "\n")))
1378 (dotimes (row ses--numrows)
1379 (ses-goto-print row col)
1381 ;; Insert new columns before newline.
1382 (let ((inhibit-point-motion-hooks t))
1386 (delete-char (- change))))))
1388 (defun ses-print-cell-new-width (row col)
1389 "Same as `ses-print-cell', except if the cell's value is *skip*,
1390 the preceding nonskipped cell is reprinted. This function is used
1391 when the width of cell (ROW,COL) has changed."
1392 (if (not (eq (ses-cell-value row col) '*skip*))
1393 (ses-print-cell row col)
1394 ;;Cell was skipped over - reprint previous
1395 (ses-goto-print row col)
1397 (let ((rowcol (ses-sym-rowcol (get-text-property (point) 'intangible))))
1398 (ses-print-cell (car rowcol) (cdr rowcol)))))
1401 ;;----------------------------------------------------------------------------
1403 ;;----------------------------------------------------------------------------
1406 "Turn off narrowing, to be reenabled at end of command loop."
1407 (if (buffer-narrowed-p)
1408 (setq ses--deferred-narrow t))
1411 (defun ses-goto-data (def &optional col)
1412 "Move point to data area for (DEF,COL). If DEF is a row
1413 number, COL is the column number for a data cell -- otherwise DEF
1414 is one of the symbols ses--col-widths, ses--col-printers,
1415 ses--default-printer, ses--numrows, or ses--numcols."
1417 (let ((inhibit-point-motion-hooks t)) ; In case intangible attrs are wrong.
1421 (goto-char ses--data-marker)
1422 (forward-line (+ 1 (* def (1+ ses--numcols)) col)))
1423 ;; Convert def-symbol to offset.
1424 (setq def (plist-get ses-paramlines-plist def))
1425 (or def (signal 'args-out-of-range nil))
1426 (goto-char ses--params-marker)
1427 (forward-line def))))
1429 (defun ses-file-format-extend-paramter-list (new-file-format)
1430 "Extend the global parameters list when file format is updated
1431 from 2 to 3. This happens when local printer function are added
1432 to a sheet that was created with SES version 2. This is not
1433 undoable. Return nil when there was no change, and non nil otherwise."
1436 ((and (= ses--file-format 2) (= 3 new-file-format))
1437 (ses-set-parameter 'ses--file-format 3 )
1439 (goto-char ses--params-marker)
1440 (forward-line (plist-get ses-paramlines-plist 'ses--numlocprn ))
1441 (insert (format (plist-get ses-paramfmt-plist 'ses--numlocprn) ses--numlocprn)
1445 (defun ses-set-parameter (def value &optional elem)
1446 "Set parameter DEF to VALUE (with undo) and write the value to the data area.
1447 See `ses-goto-data' for meaning of DEF. Newlines in the data are escaped.
1448 If ELEM is specified, it is the array subscript within DEF to be set to VALUE."
1450 ;; We call ses-goto-data early, using the old values of numrows and numcols
1451 ;; in case one of them is being changed.
1453 (let ((inhibit-read-only t)
1454 (fmt (plist-get ses-paramfmt-plist
1459 (setq oldval (aref (symbol-value def) elem))
1460 (aset (symbol-value def) elem value))
1461 (setq oldval (symbol-value def))
1463 ;; Special undo since it's outside the narrowed buffer.
1464 (let (buffer-undo-list)
1465 (delete-region (point) (line-end-position))
1466 (insert (format fmt (symbol-value def))))
1467 (push `(apply ses-set-parameter ,def ,oldval ,elem) buffer-undo-list))))
1470 (defun ses-write-cells ()
1471 "Write cells in `ses--deferred-write' from local variables to data area.
1472 Newlines in the data are escaped."
1473 (let* ((inhibit-read-only t)
1474 (print-escape-newlines t)
1475 rowcol row col cell sym formula printer text)
1476 (setq ses-start-time (float-time))
1477 (with-temp-message " "
1479 (while ses--deferred-write
1480 (ses-time-check "Writing... (%d cells left)"
1481 '(length ses--deferred-write))
1482 (setq rowcol (pop ses--deferred-write)
1485 cell (ses-get-cell row col)
1486 sym (ses-cell-symbol cell)
1487 formula (ses-cell-formula cell)
1488 printer (ses-cell-printer cell))
1489 (if (eq (car-safe formula) 'ses-safe-formula)
1490 (setq formula (cadr formula)))
1491 (if (eq (car-safe printer) 'ses-safe-printer)
1492 (setq printer (cadr printer)))
1493 ;; This is noticeably faster than (format "%S %S %S %S %S")
1494 (setq text (concat "(ses-cell "
1497 (prin1-to-string (symbol-value sym))
1499 (prin1-to-string formula)
1501 (prin1-to-string printer)
1503 (if (atom (ses-cell-references cell))
1506 (mapconcat 'symbol-name
1507 (ses-cell-references cell)
1511 (ses-goto-data row col)
1512 (delete-region (point) (line-end-position))
1517 ;;----------------------------------------------------------------------------
1518 ;; Formula relocation
1519 ;;----------------------------------------------------------------------------
1521 (defun ses-formula-references (formula &optional result-so-far)
1522 "Produce a list of symbols for cells that this FORMULA's value
1523 refers to. For recursive calls, RESULT-SO-FAR is the list being
1524 constructed, or t to get a wrong-type-argument error when the
1525 first reference is found."
1526 (if (ses-sym-rowcol formula)
1527 ;;Entire formula is one symbol
1528 (add-to-list 'result-so-far formula)
1531 ((eq (car formula) 'ses-range)
1533 (cdr (funcall 'macroexpand
1534 (list 'ses-range (nth 1 formula)
1536 (add-to-list 'result-so-far cur)))
1537 ((null (eq (car formula) 'quote))
1538 ;;Recursive call for subformulas
1539 (dolist (cur formula)
1540 (setq result-so-far (ses-formula-references cur result-so-far))))
1542 ;;Ignore other stuff
1544 ;; other type of atom are ignored
1548 (defsubst ses-relocate-symbol (sym rowcol startrow startcol rowincr colincr)
1549 "Relocate one symbol SYM, which corresponds to ROWCOL (a cons of ROW and
1550 COL). Cells starting at (STARTROW,STARTCOL) are being shifted
1551 by (ROWINCR,COLINCR)."
1552 (let ((row (car rowcol))
1554 (if (or (< row startrow) (< col startcol))
1556 (setq row (+ row rowincr)
1557 col (+ col colincr))
1558 (if (and (>= row startrow) (>= col startcol)
1559 (< row ses--numrows) (< col ses--numcols))
1560 ;;Relocate this variable
1561 (ses-create-cell-symbol row col)
1562 ;;Delete reference to a deleted cell
1565 (defun ses-relocate-formula (formula startrow startcol rowincr colincr)
1566 "Produce a copy of FORMULA where all symbols that refer to cells in row
1567 STARTROW or above, and col STARTCOL or above, are altered by adding ROWINCR
1568 and COLINCR. STARTROW and STARTCOL are 0-based. Example:
1569 (ses-relocate-formula '(+ A1 B2 D3) 1 2 1 -1)
1571 If ROWINCR or COLINCR is negative, references to cells being deleted are
1573 (ses-relocate-formula '(+ A1 B2 D3) 0 1 0 -1)
1575 Sets `ses-relocate-return' to 'delete if cell-references were removed."
1576 (let (rowcol result)
1577 (if (or (atom formula) (eq (car formula) 'quote))
1578 (if (and (setq rowcol (ses-sym-rowcol formula))
1579 (string-match-p "\\`[A-Z]+[0-9]+\\'" (symbol-name formula)))
1580 (ses-relocate-symbol formula rowcol
1581 startrow startcol rowincr colincr)
1582 formula) ; Pass through as-is.
1583 (dolist (cur formula)
1584 (setq rowcol (ses-sym-rowcol cur))
1587 (setq cur (ses-relocate-symbol cur rowcol
1588 startrow startcol rowincr colincr))
1591 ;; Reference to a deleted cell. Set a flag in ses-relocate-return.
1592 ;; don't change the flag if it's already 'range, since range implies
1594 (unless ses-relocate-return
1595 (setq ses-relocate-return 'delete))))
1596 ((eq (car-safe cur) 'ses-range)
1597 (setq cur (ses-relocate-range cur startrow startcol rowincr colincr))
1600 ((or (atom cur) (eq (car cur) 'quote))
1601 ;; Constants pass through unchanged.
1604 ;; Recursively copy and alter subformulas.
1605 (push (ses-relocate-formula cur startrow startcol
1608 (nreverse result))))
1610 (defun ses-relocate-range (range startrow startcol rowincr colincr)
1611 "Relocate one RANGE, of the form '(ses-range min max). Cells starting
1612 at (STARTROW,STARTCOL) are being shifted by (ROWINCR,COLINCR). Result is the
1613 new range, or nil if the entire range is deleted. If new rows are being added
1614 just beyond the end of a row range, or new columns just beyond a column range,
1615 the new rows/columns will be added to the range. Sets `ses-relocate-return'
1616 if the range was altered."
1617 (let* ((minorig (cadr range))
1618 (minrowcol (ses-sym-rowcol minorig))
1619 (min (ses-relocate-symbol minorig minrowcol
1622 (maxorig (nth 2 range))
1623 (maxrowcol (ses-sym-rowcol maxorig))
1624 (max (ses-relocate-symbol maxorig maxrowcol
1629 ((and (not min) (not max))
1630 (setq range nil)) ; The entire range is deleted.
1632 ;; Inserting or deleting rows.
1635 ;; Chopped off beginning of range.
1636 (setq min (ses-create-cell-symbol startrow (cdr minrowcol))
1637 ses-relocate-return 'range))
1640 ;; Trying to insert a nonexistent row.
1641 (setq max (ses-create-cell-symbol (1- ses--numrows)
1643 ;; End of range is being deleted.
1644 (setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol))
1645 ses-relocate-return 'range))
1647 (= (car maxrowcol) (1- startrow))
1648 (= (cdr minrowcol) (cdr maxrowcol))
1649 ;; Insert after ending row of vertical range --- include it.
1650 (setq max (ses-create-cell-symbol (+ startrow rowincr -1)
1651 (cdr maxrowcol))))))
1653 ;; Inserting or deleting columns.
1656 ;; Chopped off beginning of range.
1657 (setq min (ses-create-cell-symbol (car minrowcol) startcol)
1658 ses-relocate-return 'range))
1661 ;; Trying to insert a nonexistent column.
1662 (setq max (ses-create-cell-symbol (car maxrowcol)
1664 ;; End of range is being deleted.
1665 (setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol))
1666 ses-relocate-return 'range))
1668 (= (cdr maxrowcol) (1- startcol))
1669 (= (car minrowcol) (car maxrowcol))
1670 ;; Insert after ending column of horizontal range --- include it.
1671 (setq max (ses-create-cell-symbol (car maxrowcol)
1672 (+ startcol colincr -1)))))))
1674 (if (/= (- (funcall field maxrowcol)
1675 (funcall field minrowcol))
1676 (- (funcall field (ses-sym-rowcol max))
1677 (funcall field (ses-sym-rowcol min))))
1678 ;; This range has changed size.
1679 (setq ses-relocate-return 'range))
1680 `(ses-range ,min ,max ,@(cl-cdddr range)))))
1682 (defun ses-relocate-all (minrow mincol rowincr colincr)
1683 "Alter all cell values, symbols, formulas, and reference-lists to relocate
1684 the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR
1687 (let (mycell newval xrow)
1688 (dotimes-with-progress-reporter
1689 (row ses--numrows) "Relocating formulas..."
1690 (dotimes (col ses--numcols)
1691 (setq ses-relocate-return nil
1692 mycell (ses-get-cell row col)
1693 newval (ses-relocate-formula (ses-cell-formula mycell)
1694 minrow mincol rowincr colincr)
1695 xrow (- row rowincr))
1696 (ses-set-cell row col 'formula newval)
1697 (if (eq ses-relocate-return 'range)
1698 ;; This cell contains a (ses-range X Y) where a cell has been
1699 ;; inserted or deleted in the middle of the range.
1700 (push (cons row col) reform))
1701 (if ses-relocate-return
1702 ;; This cell referred to a cell that's been deleted or is no
1703 ;; longer part of the range. We can't fix that now because
1704 ;; reference lists cells have been partially updated.
1705 (add-to-list 'ses--deferred-recalc
1706 (ses-create-cell-symbol row col)))
1707 (setq newval (ses-relocate-formula (ses-cell-references mycell)
1708 minrow mincol rowincr colincr))
1709 (ses-set-cell row col 'references newval)
1710 (and (>= row minrow) (>= col mincol)
1711 (let ((sym (ses-cell-symbol row col))
1712 (xcol (- col colincr)))
1718 (ses-create-cell-symbol xrow xcol))))
1719 ;; This is a renamed cell, do not update the cell
1720 ;; name, but just update the coordinate property.
1721 (put sym 'ses-cell (cons row col))
1722 (ses-set-cell row col 'symbol
1723 (setq sym (ses-create-cell-symbol row col)))
1724 (unless (and (boundp sym) (local-variable-p sym))
1725 (set (make-local-variable sym) nil)
1726 (put sym 'ses-cell (cons row col)))))) )))
1727 ;; Relocate the cell values.
1728 (let (oldval myrow mycol xrow xcol)
1730 ((and (<= rowincr 0) (<= colincr 0))
1731 ;; Deletion of rows and/or columns.
1732 (dotimes-with-progress-reporter
1733 (row (- ses--numrows minrow)) "Relocating variables..."
1734 (setq myrow (+ row minrow))
1735 (dotimes (col (- ses--numcols mincol))
1736 (setq mycol (+ col mincol)
1737 xrow (- myrow rowincr)
1738 xcol (- mycol colincr))
1739 (let ((sym (ses-cell-symbol myrow mycol))
1740 (xsym (ses-create-cell-symbol xrow xcol)))
1741 ;; Make the value relocation only when if the cell is not
1742 ;; a renamed cell. Otherwise this is not needed.
1744 (ses-set-cell myrow mycol 'value
1745 (if (and (< xrow ses--numrows) (< xcol ses--numcols))
1746 (ses-cell-value xrow xcol)
1747 ;;Cell is off the end of the array
1748 (symbol-value xsym))))))))
1750 ((and (wholenump rowincr) (wholenump colincr))
1751 ;; Insertion of rows and/or columns. Run the loop backwards.
1752 (let ((disty (1- ses--numrows))
1753 (distx (1- ses--numcols))
1755 (dotimes-with-progress-reporter
1756 (row (- ses--numrows minrow)) "Relocating variables..."
1757 (setq myrow (- disty row))
1758 (dotimes (col (- ses--numcols mincol))
1759 (setq mycol (- distx col)
1760 xrow (- myrow rowincr)
1761 xcol (- mycol colincr))
1762 (if (or (< xrow minrow) (< xcol mincol))
1763 ;; Newly-inserted value.
1765 ;; Transfer old value.
1766 (setq oldval (ses-cell-value xrow xcol)))
1767 (ses-set-cell myrow mycol 'value oldval)))
1768 t)) ; Make testcover happy by returning non-nil here.
1770 (error "ROWINCR and COLINCR must have the same sign"))))
1771 ;; Reconstruct reference lists for cells that contain ses-ranges that have
1774 (message "Fixing ses-ranges...")
1776 (setq ses-start-time (float-time))
1778 (ses-time-check "Fixing ses-ranges... (%d left)" '(length reform))
1779 (setq row (caar reform)
1781 reform (cdr reform))
1782 (ses-cell-set-formula row col (ses-cell-formula row col))))
1786 ;;----------------------------------------------------------------------------
1788 ;;----------------------------------------------------------------------------
1790 (defun ses-begin-change ()
1791 "For undo, remember point before we start changing hidden stuff."
1792 (let ((inhibit-read-only t))
1793 (insert-and-inherit "X")
1794 (delete-region (1- (point)) (point))))
1796 (defun ses-set-with-undo (sym newval)
1797 "Like set, but undoable. Result is t if value has changed."
1798 ;; We try to avoid adding redundant entries to the undo list, but this is
1799 ;; unavoidable for strings because equal ignores text properties and there's
1800 ;; no easy way to get the whole property list to see if it's different!
1801 (unless (and (boundp sym)
1802 (equal (symbol-value sym) newval)
1803 (not (stringp newval)))
1804 (push (if (boundp sym)
1805 `(apply ses-set-with-undo ,sym ,(symbol-value sym))
1806 `(apply ses-unset-with-undo ,sym))
1811 (defun ses-unset-with-undo (sym)
1812 "Set SYM to be unbound. This is undoable."
1813 (when (1value (boundp sym)) ; Always bound, except after a programming error.
1814 (push `(apply ses-set-with-undo ,sym ,(symbol-value sym)) buffer-undo-list)
1817 (defun ses-aset-with-undo (array idx newval)
1818 "Like `aset', but undoable.
1819 Result is t if element has changed."
1820 (unless (equal (aref array idx) newval)
1821 (push `(apply ses-aset-with-undo ,array ,idx
1822 ,(aref array idx)) buffer-undo-list)
1823 (aset array idx newval)
1827 ;;----------------------------------------------------------------------------
1828 ;; Startup for major mode
1829 ;;----------------------------------------------------------------------------
1832 "Parse the current buffer and set up buffer-local variables.
1833 Does not execute cell formulas or print functions."
1835 ;; Read our global parameters, which should be a 3-element list.
1836 (goto-char (point-max))
1837 (search-backward ";; Local Variables:\n" nil t)
1839 (setq ses--params-marker (point-marker))
1840 (let* ((params (ignore-errors (read (current-buffer))))
1841 (params-len (safe-length params)))
1842 (or (and (>= params-len 3)
1844 (numberp (car params))
1845 (numberp (cadr params))
1846 (>= (cadr params) 0)
1847 (numberp (nth 2 params))
1848 (> (nth 2 params) 0)
1849 (or (<= params-len 3)
1850 (let ((numlocprn (nth 3 params)))
1851 (and (integerp numlocprn) (>= numlocprn 0)))))
1852 (error "Invalid SES file"))
1853 (setq ses--file-format (car params)
1854 ses--numrows (cadr params)
1855 ses--numcols (nth 2 params)
1856 ses--numlocprn (or (nth 3 params) 0))
1857 (when (= ses--file-format 1)
1858 (let (buffer-undo-list) ; This is not undoable.
1859 (ses-goto-data 'ses--header-row)
1860 (insert "(ses-header-row 0)\n")
1861 (ses-set-parameter 'ses--file-format 3)
1862 (message "Upgrading from SES-1 file format")))
1863 (or (> ses--file-format 3)
1864 (error "This file needs a newer version of the SES library code"))
1865 ;; Initialize cell array.
1866 (setq ses--cells (make-vector ses--numrows nil))
1867 (dotimes (row ses--numrows)
1868 (aset ses--cells row (make-vector ses--numcols nil)))
1869 ;; initialize local printer map.
1870 (clrhash ses--local-printer-hashmap))
1872 ;; Skip over print area, which we assume is correct.
1873 (goto-char (point-min))
1874 (forward-line ses--numrows)
1875 (or (looking-at-p ses-print-data-boundary)
1876 (error "Missing marker between print and data areas"))
1878 (setq ses--data-marker (point-marker))
1879 (forward-char (1- (length ses-print-data-boundary)))
1880 ;; Initialize printer and symbol lists.
1881 (mapc 'ses-printer-record ses-standard-printer-functions)
1882 (setq ses--symbolic-formulas nil)
1884 ;; Load local printer definitions.
1885 ;; This must be loaded *BEFORE* cells and column printers because the latters
1888 (forward-line (* ses--numrows (1+ ses--numcols)))
1889 (let ((numlocprn ses--numlocprn))
1890 (setq ses--numlocprn 0)
1891 (dotimes (lp numlocprn)
1892 (let ((x (read (current-buffer))))
1893 (or (and (looking-at-p "\n")
1894 (eq (car-safe x) 'ses-local-printer)
1896 (error "local printer-def error"))
1897 (setq ses--numlocprn (1+ ses--numlocprn))))))
1898 ;; Load cell definitions.
1899 (dotimes (row ses--numrows)
1900 (dotimes (col ses--numcols)
1901 (let* ((x (read (current-buffer)))
1902 (sym (car-safe (cdr-safe x))))
1903 (or (and (looking-at-p "\n")
1904 (eq (car-safe x) 'ses-cell)
1905 (ses-create-cell-variable sym row col))
1906 (error "Cell-def error"))
1908 (or (looking-at-p "\n\n")
1909 (error "Missing blank line between rows")))
1910 ;; Skip local printer function declaration --- that were already loaded.
1911 (forward-line (+ 2 ses--numlocprn))
1912 ;; Load global parameters.
1913 (let ((widths (read (current-buffer)))
1914 (n1 (char-after (point)))
1915 (printers (read (current-buffer)))
1916 (n2 (char-after (point)))
1917 (def-printer (read (current-buffer)))
1918 (n3 (char-after (point)))
1919 (head-row (read (current-buffer)))
1920 (n4 (char-after (point))))
1921 (or (and (eq (car-safe widths) 'ses-column-widths)
1923 (eq (car-safe printers) 'ses-column-printers)
1925 (eq (car-safe def-printer) 'ses-default-printer)
1927 (eq (car-safe head-row) 'ses-header-row)
1929 (error "Invalid SES global parameters"))
1930 (1value (eval widths))
1931 (1value (eval def-printer))
1932 (1value (eval printers))
1933 (1value (eval head-row)))
1934 ;; Should be back at global-params.
1936 (or (looking-at-p ses-initial-global-parameters-re)
1937 (error "Problem with column-defs or global-params"))
1938 ;; Check for overall newline count in definitions area.
1940 (let ((start (point)))
1941 (ses-goto-data 'ses--numrows)
1942 (or (= (point) start)
1943 (error "Extraneous newlines someplace?"))))
1946 "Set up for display of only the printed cell values.
1948 Narrows the buffer to show only the print area. Gives it `read-only' and
1949 `intangible' properties. Sets up highlighting for current cell."
1951 (let ((end (point-min))
1952 (inhibit-read-only t)
1953 (inhibit-point-motion-hooks t)
1954 (was-modified (buffer-modified-p))
1956 (ses-goto-data 0 0) ; Include marker between print-area and data-area.
1957 (set-text-properties (point) (point-max) nil) ; Delete garbage props.
1958 (mapc 'delete-overlay (overlays-in (point-min) (point-max)))
1959 ;; The print area is read-only (except for our special commands) and uses a
1961 (put-text-property (point-min) (1- (point)) 'read-only 'ses)
1962 (put-text-property (point-min) (1- (point)) 'keymap 'ses-mode-print-map)
1963 ;; For the beginning of the buffer, we want the read-only and keymap
1964 ;; attributes to be inherited from the first character.
1965 (put-text-property (point-min) (1+ (point-min)) 'front-sticky t)
1966 ;; Create intangible properties, which also indicate which cell the text
1968 (dotimes-with-progress-reporter (row ses--numrows) "Finding cells..."
1969 (dotimes (col ses--numcols)
1971 sym (ses-cell-symbol row col))
1972 ;; Include skipped cells following this one.
1973 (while (and (< col (1- ses--numcols))
1974 (eq (ses-cell-value row (1+ col)) '*skip*))
1975 (setq end (+ end (ses-col-width col) 1)
1977 (setq end (save-excursion
1979 (move-to-column (+ (current-column) (- end pos)
1980 (ses-col-width col)))
1982 (+ end (ses-col-width col) 1)
1985 (put-text-property pos end 'intangible sym)))
1986 ;; Adding these properties did not actually alter the text.
1987 (unless was-modified
1988 (restore-buffer-modified-p nil)
1989 (buffer-disable-undo)
1990 (buffer-enable-undo)))
1991 ;; Create the underlining overlay. It's impossible for (point) to be 2,
1992 ;; because column A must be at least 1 column wide.
1993 (setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min))))
1994 (overlay-put ses--curcell-overlay 'face 'underline))
1996 (defun ses-cleanup ()
1997 "Cleanup when changing a buffer from SES mode to something else.
1998 Delete overlays, remove special text properties."
2000 (let ((inhibit-read-only t)
2001 ;; When reverting, hide the buffer name, otherwise Emacs will ask the
2002 ;; user "the file is modified, do you really want to make modifications
2003 ;; to this buffer", where the "modifications" refer to the irrelevant
2004 ;; set-text-properties below.
2005 (buffer-file-name nil)
2006 (was-modified (buffer-modified-p)))
2007 ;; Delete read-only, keymap, and intangible properties.
2008 (set-text-properties (point-min) (point-max) nil)
2010 (mapc 'delete-overlay (overlays-in (point-min) (point-max)))
2011 (unless was-modified
2012 (restore-buffer-modified-p nil))))
2016 "Major mode for Simple Emacs Spreadsheet.
2018 When you invoke SES in a new buffer, it is divided into cells
2019 that you can enter data into. You can navigate the cells with
2020 the arrow keys and add more cells with the tab key. The contents
2021 of these cells can be numbers, text, or Lisp expressions. (To
2022 enter text, enclose it in double quotes.)
2024 In an expression, you can use cell coordinates to refer to the
2025 contents of another cell. For example, you can sum a range of
2026 cells with `(+ A1 A2 A3)'. There are specialized functions like
2027 `ses+' (addition for ranges with empty cells), `ses-average' (for
2028 performing calculations on cells), and `ses-range' and `ses-select'
2029 \(for extracting ranges of cells).
2031 Each cell also has a print function that controls how it is
2034 Each SES buffer is divided into a print area and a data area.
2035 Normally, you can simply use SES to look at and manipulate the print
2036 area, and let SES manage the data area outside the visible region.
2038 See \"ses-example.ses\" (in `data-directory') for an example
2039 spreadsheet, and the Info node `(ses)Top.'
2041 In the following, note the separate keymaps for cell editing mode
2042 and print mode specifications. Key definitions:
2045 These key definitions are active only in the print area (the visible
2047 \\{ses-mode-print-map}
2048 These are active only in the minibuffer, when entering or editing a
2050 \\{ses-mode-edit-map}"
2052 (unless (and (boundp 'ses--deferred-narrow)
2053 (eq ses--deferred-narrow 'ses-mode))
2054 (kill-all-local-variables)
2056 (setq major-mode 'ses-mode
2058 next-line-add-newlines nil
2060 ;; SES deliberately puts lots of trailing whitespace in its buffer.
2061 show-trailing-whitespace nil
2062 ;; Cell ranges do not work reasonably without this.
2063 transient-mark-mode t
2064 ;; Not to use tab characters for safe (tabs may do bad for column
2066 indent-tabs-mode nil)
2067 (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t))
2068 (1value (add-hook 'before-revert-hook 'ses-cleanup nil t))
2069 (setq header-line-format '(:eval (progn
2070 (when (/= (window-hscroll)
2071 ses--header-hscroll)
2072 ;; Reset ses--header-hscroll first,
2073 ;; to avoid recursion problems when
2074 ;; debugging ses-create-header-string
2075 (setq ses--header-hscroll
2077 (ses-create-header-string))
2078 ses--header-string)))
2079 (let ((was-empty (zerop (buffer-size)))
2080 (was-modified (buffer-modified-p)))
2083 ;; Initialize buffer to contain one cell, for now.
2084 (insert ses-initial-file-contents))
2088 (unless (equal ses-initial-default-printer
2089 (1value ses--default-printer))
2090 (1value (ses-read-default-printer ses-initial-default-printer)))
2091 (unless (= ses-initial-column-width (1value (ses-col-width 0)))
2092 (1value (ses-set-column-width 0 ses-initial-column-width)))
2094 (if (> (car ses-initial-size) (1value ses--numrows))
2095 (1value (ses-insert-row (1- (car ses-initial-size)))))
2096 (if (> (cdr ses-initial-size) (1value ses--numcols))
2097 (1value (ses-insert-column (1- (cdr ses-initial-size)))))
2099 (restore-buffer-modified-p was-modified)
2100 (buffer-disable-undo)
2101 (buffer-enable-undo)
2102 (goto-char (point-min))))
2103 (use-local-map ses-mode-map)
2104 ;; Set the deferred narrowing flag (we can't narrow until after
2105 ;; after-find-file completes). If .ses is on the auto-load alist and the
2106 ;; file has "mode: ses", our ses-mode function will be called twice! Use a
2107 ;; special flag to detect this (will be reset by ses-command-hook). For
2108 ;; find-alternate-file, post-command-hook doesn't get run for some reason,
2109 ;; so use an idle timer to make sure.
2110 (setq ses--deferred-narrow 'ses-mode)
2111 (1value (add-hook 'post-command-hook 'ses-command-hook nil t))
2112 (run-with-idle-timer 0.01 nil 'ses-command-hook)
2113 (run-mode-hooks 'ses-mode-hook)))
2115 (put 'ses-mode 'mode-class 'special)
2117 (defun ses-command-hook ()
2118 "Invoked from `post-command-hook'. If point has moved to a different cell,
2119 moves the underlining overlay. Performs any recalculations or cell-data
2120 writes that have been deferred. If buffer-narrowing has been deferred,
2121 narrows the buffer now."
2123 (when (eq major-mode 'ses-mode) ; Otherwise, not our buffer anymore.
2124 (when ses--deferred-recalc
2125 ;; We reset the deferred list before starting on the recalc --- in
2126 ;; case of error, we don't want to retry the recalc after every
2128 (ses-initialize-Dijkstra-attempt)
2129 (let ((old ses--deferred-recalc))
2130 (setq ses--deferred-recalc nil)
2131 (ses-update-cells old)))
2132 (when ses--deferred-write
2133 ;; We don't reset the deferred list before starting --- the most
2134 ;; likely error is keyboard-quit, and we do want to keep trying these
2135 ;; writes after a quit.
2137 (push '(apply ses-widen) buffer-undo-list))
2138 (when ses--deferred-narrow
2139 ;; We're not allowed to narrow the buffer until after-find-file has
2140 ;; read the local variables at the end of the file. Now it's safe to
2141 ;; do the narrowing.
2142 (narrow-to-region (point-min) ses--data-marker)
2143 (setq ses--deferred-narrow nil))
2144 ;; Update the mode line.
2145 (let ((oldcell ses--curcell))
2147 (unless (eq ses--curcell oldcell)
2150 (setq mode-line-process nil))
2151 ((atom ses--curcell)
2152 (setq mode-line-process (list " cell "
2153 (symbol-name ses--curcell))))
2155 (setq mode-line-process (list " range "
2156 (symbol-name (car ses--curcell))
2158 (symbol-name (cdr ses--curcell))))))
2159 (force-mode-line-update)))
2160 ;; Use underline overlay for single-cells only, turn off otherwise.
2161 (if (listp ses--curcell)
2162 (move-overlay ses--curcell-overlay 2 2)
2163 (let ((next (next-single-property-change (point) 'intangible)))
2164 (move-overlay ses--curcell-overlay (point) (1- next))))
2165 (when (not (pos-visible-in-window-p))
2166 ;; Scrolling will happen later.
2167 (run-with-idle-timer 0.01 nil 'ses-command-hook)
2168 (setq ses--curcell t)))
2169 ;; Prevent errors in this post-command-hook from silently erasing the hook!
2171 (unless executing-kbd-macro
2173 (message "%s" (error-message-string err))))
2174 nil) ; Make coverage-tester happy.
2176 (defun ses-create-header-string ()
2177 "Set up `ses--header-string' as the buffer's header line.
2178 Based on the current set of columns and `window-hscroll' position."
2179 (let ((totwidth (- (window-hscroll)))
2181 ;; Leave room for the left-side fringe and scrollbar.
2182 (push (propertize " " 'display '((space :align-to 0))) result)
2183 (dotimes (col ses--numcols)
2184 (setq width (ses-col-width col)
2185 totwidth (+ totwidth width 1))
2187 ;; Scrolled so intercolumn space is leftmost.
2189 (when (> totwidth 1)
2190 (if (> ses--header-row 0)
2192 (ses-goto-print (1- ses--header-row) col)
2193 (setq x (buffer-substring-no-properties (point)
2195 ;; Strip trailing space.
2196 (if (string-match "[ \t]+\\'" x)
2197 (setq x (substring x 0 (match-beginning 0))))
2198 ;; Cut off excess text.
2199 (if (>= (length x) totwidth)
2200 (setq x (substring x 0 (- totwidth -1)))))
2201 (setq x (ses-column-letter col)))
2202 (push (propertize x 'face ses-box-prop) result)
2203 (push (propertize "."
2204 'display `((space :align-to ,(1- totwidth)))
2207 ;; Allow the following space to be squished to make room for the 3-D box
2208 ;; Coverage test ignores properties, thinks this is always a space!
2209 (push (1value (propertize " " 'display `((space :align-to ,totwidth))))
2211 (if (> ses--header-row 0)
2212 (push (propertize (format " [row %d]" ses--header-row)
2213 'display '((height (- 1))))
2215 (setq ses--header-string (apply 'concat (nreverse result)))))
2218 ;;----------------------------------------------------------------------------
2219 ;; Redisplay and recalculation
2220 ;;----------------------------------------------------------------------------
2222 (defun ses-jump (sym)
2223 "Move point to cell SYM."
2224 (interactive "SJump to cell: ")
2225 (let ((rowcol (ses-sym-rowcol sym)))
2226 (or rowcol (error "Invalid cell name"))
2227 (if (eq (symbol-value sym) '*skip*)
2228 (error "Cell is covered by preceding cell"))
2229 (ses-goto-print (car rowcol) (cdr rowcol))))
2231 (defun ses-jump-safe (cell)
2232 "Like `ses-jump', but no error if invalid cell."
2236 (defun ses-reprint-all (&optional nonarrow)
2237 "Recreate the display area. Calls all printer functions. Narrows to
2238 print area if NONARROW is nil."
2242 (setq ses--deferred-narrow t))
2243 (let ((startcell (get-text-property (point) 'intangible))
2244 (inhibit-read-only t))
2246 (goto-char (point-min))
2247 (search-forward ses-print-data-boundary)
2248 (backward-char (length ses-print-data-boundary))
2249 (delete-region (point-min) (point))
2250 ;; Insert all blank lines before printing anything, so ses-print-cell can
2251 ;; find the data area when inserting or deleting *skip* values for cells.
2252 (dotimes (row ses--numrows)
2253 (insert-and-inherit ses--blank-line))
2254 (dotimes-with-progress-reporter (row ses--numrows) "Reprinting..."
2255 (if (eq (ses-cell-value row 0) '*skip*)
2256 ;; Column deletion left a dangling skip.
2257 (ses-set-cell row 0 'value nil))
2258 (dotimes (col ses--numcols)
2259 (ses-print-cell row col))
2260 (beginning-of-line 2))
2261 (ses-jump-safe startcell)))
2263 (defun ses-initialize-Dijkstra-attempt ()
2264 (setq ses--Dijkstra-attempt-nb (1+ ses--Dijkstra-attempt-nb)
2265 ses--Dijkstra-weight-bound (* ses--numrows ses--numcols)))
2267 (defun ses-recalculate-cell ()
2268 "Recalculate and reprint the current cell or range.
2270 For an individual cell, shows the error if the formula or printer
2271 signals one, or otherwise shows the cell's complete value. For a range, the
2272 cells are recalculated in \"natural\" order, so cells that other cells refer
2273 to are recalculated first."
2275 (ses-check-curcell 'range)
2277 (ses-initialize-Dijkstra-attempt)
2278 (let (sig cur-rowcol)
2279 (setq ses-start-time (float-time))
2280 (if (atom ses--curcell)
2282 (setq cur-rowcol (ses-sym-rowcol ses--curcell)
2284 (ses-cell-property-set :ses-Dijkstra-attempt
2285 (cons ses--Dijkstra-attempt-nb 0)
2286 (car cur-rowcol) (cdr cur-rowcol) )
2287 (ses-calculate-cell (car cur-rowcol) (cdr cur-rowcol) t)))
2288 (nconc sig (list (ses-cell-symbol (car cur-rowcol)
2289 (cdr cur-rowcol)))))
2290 ;; First, recalculate all cells that don't refer to other cells and
2291 ;; produce a list of cells with references.
2292 (ses-dorange ses--curcell
2293 (ses-time-check "Recalculating... %s" '(ses-cell-symbol row col))
2296 ;; The t causes an error if the cell has references. If no
2297 ;; references, the t will be the result value.
2298 (1value (ses-formula-references (ses-cell-formula row col) t))
2299 (ses-cell-property-set :ses-Dijkstra-attempt
2300 (cons ses--Dijkstra-attempt-nb 0)
2302 (when (setq sig (ses-calculate-cell row col t))
2303 (nconc sig (list (ses-cell-symbol row col)))))
2304 (wrong-type-argument
2305 ;; The formula contains a reference.
2306 (add-to-list 'ses--deferred-recalc (ses-cell-symbol row col))))))
2307 ;; Do the update now, so we can force recalculation.
2308 (let ((x ses--deferred-recalc))
2309 (setq ses--deferred-recalc nil)
2310 (condition-case hold
2311 (ses-update-cells x t)
2312 (error (setq sig hold))))
2315 (message "%s" (error-message-string sig)))
2316 ((consp ses--curcell)
2319 (princ (symbol-value ses--curcell))))))
2321 (defun ses-recalculate-all ()
2322 "Recalculate and reprint all cells."
2324 (let ((startcell (get-text-property (point) 'intangible))
2325 (ses--curcell (cons 'A1 (ses-cell-symbol (1- ses--numrows)
2326 (1- ses--numcols)))))
2327 (ses-recalculate-cell)
2328 (ses-jump-safe startcell)))
2330 (defun ses-truncate-cell ()
2331 "Reprint current cell, but without spillover into any following blank cells."
2334 (let* ((rowcol (ses-sym-rowcol ses--curcell))
2337 (when (and (< col (1- ses--numcols)) ;;Last column can't spill over, anyway
2338 (eq (ses-cell-value row (1+ col)) '*skip*))
2339 ;; This cell has spill-over. We'll momentarily pretend the following cell
2341 (eval `(let ((,(ses-cell-symbol row (1+ col)) t))
2342 (ses-print-cell row col)))
2343 ;; Now remove the *skip*. ses-print-cell is always nil here.
2344 (ses-set-cell row (1+ col) 'value nil)
2345 (1value (ses-print-cell row (1+ col))))))
2347 (defun ses-reconstruct-all ()
2348 "Reconstruct buffer based on cell data stored in Emacs variables."
2351 ;;Reconstruct reference lists.
2353 ;;Delete old reference lists
2354 (dotimes-with-progress-reporter
2355 (row ses--numrows) "Deleting references..."
2356 (dotimes (col ses--numcols)
2357 (ses-set-cell row col 'references nil)))
2358 ;;Create new reference lists
2359 (dotimes-with-progress-reporter
2360 (row ses--numrows) "Computing references..."
2361 (dotimes (col ses--numcols)
2362 (dolist (ref (ses-formula-references (ses-cell-formula row col)))
2363 (setq x (ses-sym-rowcol ref)
2366 (ses-set-cell yrow ycol 'references
2367 (cons (ses-cell-symbol row col)
2368 (ses-cell-references yrow ycol)))))))
2369 ;; Delete everything and reconstruct basic data area.
2371 (let ((inhibit-read-only t))
2372 (goto-char (point-max))
2373 (if (search-backward ";; Local Variables:\n" nil t)
2374 (delete-region (point-min) (point))
2375 ;; Buffer is quite screwed up --- can't even save the user-specified
2377 (delete-region (point-min) (point-max))
2378 (insert ses-initial-file-trailer)
2379 (goto-char (point-min)))
2380 ;; Create a blank display area.
2381 (dotimes (row ses--numrows)
2382 (insert ses--blank-line))
2383 (insert ses-print-data-boundary)
2384 (backward-char (1- (length ses-print-data-boundary)))
2385 (setq ses--data-marker (point-marker))
2386 (forward-char (1- (length ses-print-data-boundary)))
2387 ;; Placeholders for cell data.
2388 (insert (make-string (* ses--numrows (1+ ses--numcols)) ?\n))
2389 ;; Placeholders for col-widths, col-printers, default-printer, header-row.
2391 (insert ses-initial-global-parameters)
2392 (backward-char (1- (length ses-initial-global-parameters)))
2393 (setq ses--params-marker (point-marker))
2394 (forward-char (1- (length ses-initial-global-parameters))))
2395 (ses-set-parameter 'ses--col-widths ses--col-widths)
2396 (ses-set-parameter 'ses--col-printers ses--col-printers)
2397 (ses-set-parameter 'ses--default-printer ses--default-printer)
2398 (ses-set-parameter 'ses--header-row ses--header-row)
2399 (ses-set-parameter 'ses--numrows ses--numrows)
2400 (ses-set-parameter 'ses--numcols ses--numcols)
2401 ;;Keep our old narrowing
2403 (ses-recalculate-all)
2404 (goto-char (point-min)))
2407 ;;----------------------------------------------------------------------------
2408 ;; Input of cell formulas
2409 ;;----------------------------------------------------------------------------
2411 (defun ses-edit-cell (row col newval)
2412 "Display current cell contents in minibuffer, for editing. Returns nil if
2413 cell formula was unsafe and user declined confirmation."
2416 (barf-if-buffer-read-only)
2418 (let* ((rowcol (ses-sym-rowcol ses--curcell))
2421 (formula (ses-cell-formula row col))
2423 (if (eq (car-safe formula) 'ses-safe-formula)
2424 (setq formula (cadr formula)))
2425 (if (eq (car-safe formula) 'quote)
2426 (setq initial (format "'%S" (cadr formula)))
2427 (setq initial (prin1-to-string formula)))
2428 (if (stringp formula)
2429 ;; Position cursor inside close-quote.
2430 (setq initial (cons initial (length initial))))
2432 (read-from-minibuffer (format "Cell %s: " ses--curcell)
2435 t ; Convert to Lisp object.
2436 'ses-read-cell-history)))))
2437 (when (ses-warn-unsafe newval 'unsafep)
2439 (ses-cell-set-formula row col newval)
2442 (defun ses-read-cell (row col newval)
2443 "Self-insert for initial character of cell function."
2445 (let* ((initial (this-command-keys))
2446 (rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
2447 (curval (ses-cell-formula (car rowcol) (cdr rowcol))))
2448 (barf-if-buffer-read-only)
2451 (read-from-minibuffer
2452 (format "Cell %s: " ses--curcell)
2453 (cons (if (equal initial "\"") "\"\""
2454 (if (equal initial "(") "()" initial)) 2)
2456 t ; Convert to Lisp object.
2457 'ses-read-cell-history
2458 (prin1-to-string (if (eq (car-safe curval) 'ses-safe-formula)
2461 (when (ses-edit-cell row col newval)
2462 (ses-command-hook) ; Update cell widths before movement.
2463 (dolist (x ses-after-entry-functions)
2466 (defun ses-read-symbol (row col symb)
2467 "Self-insert for a symbol as a cell formula. The set of all symbols that
2468 have been used as formulas in this spreadsheet is available for completions."
2470 (let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
2472 (barf-if-buffer-read-only)
2473 (setq newval (completing-read (format "Cell %s ': " ses--curcell)
2474 ses--symbolic-formulas))
2477 (if (string= newval "")
2478 nil ; Don't create zero-length symbols!
2479 (list 'quote (intern newval))))))
2480 (when (ses-edit-cell row col symb)
2481 (ses-command-hook) ; Update cell widths before movement.
2482 (dolist (x ses-after-entry-functions)
2485 (defun ses-clear-cell-forward (count)
2486 "Delete formula and printer for current cell and then move to next cell.
2487 With prefix, deletes several cells."
2490 (1value (ses-clear-cell-backward (- count)))
2495 (let ((rowcol (ses-sym-rowcol ses--curcell)))
2496 (or rowcol (signal 'end-of-buffer nil))
2497 (ses-clear-cell (car rowcol) (cdr rowcol)))
2500 (defun ses-clear-cell-backward (count)
2501 "Move to previous cell and then delete it. With prefix, deletes several
2505 (1value (ses-clear-cell-forward (- count)))
2506 (ses-check-curcell 'end)
2509 (backward-char 1) ; Will signal 'beginning-of-buffer if appropriate.
2511 (let ((rowcol (ses-sym-rowcol ses--curcell)))
2512 (ses-clear-cell (car rowcol) (cdr rowcol))))))
2515 ;;----------------------------------------------------------------------------
2516 ;; Input of cell-printer functions
2517 ;;----------------------------------------------------------------------------
2519 (defun ses-read-printer (prompt default)
2520 "Common code for functions `ses-read-cell-printer', `ses-read-column-printer',
2521 `ses-read-default-printer' and `ses-define-local-printer'.
2522 PROMPT should end with \": \". Result is t if operation was
2524 (barf-if-buffer-read-only)
2527 (setq prompt (format "%s [currently %S]: "
2528 (substring prompt 0 -2)
2530 (let ((new (read-from-minibuffer prompt
2531 nil ; Initial contents.
2533 t ; Evaluate the result.
2534 'ses-read-printer-history
2535 (prin1-to-string default))))
2536 (if (equal new default)
2537 ;; User changed mind, decided not to change printer.
2539 (ses-printer-validate new)
2542 (stringp (car-safe new))
2543 (and (symbolp new) (gethash new ses--local-printer-hashmap))
2544 (ses-warn-unsafe new 'unsafep-function)
2548 (defun ses-read-cell-printer (newval)
2549 "Set the printer function for the current cell or range.
2551 A printer function is either a string (a format control-string with one
2552 %-sequence -- result from format will be right-justified), or a list of one
2553 string (result from format will be left-justified), or a lambda-expression of
2554 one argument, or a symbol that names a function of one argument. In the
2555 latter two cases, the function's result should be either a string (will be
2556 right-justified) or a list of one string (will be left-justified)."
2560 (ses-check-curcell 'range)
2561 ;;Default is none if not all cells in range have same printer
2562 (catch 'ses-read-cell-printer
2563 (ses-dorange ses--curcell
2564 (setq x (ses-cell-printer row col))
2565 (if (eq (car-safe x) 'ses-safe-printer)
2569 (unless (equal default x)
2570 ;;Range contains differing printer functions
2572 (throw 'ses-read-cell-printer t)))))
2573 (list (ses-read-printer (format "Cell %S printer: " ses--curcell)
2575 (unless (eq newval t)
2577 (ses-dorange ses--curcell
2578 (ses-set-cell row col 'printer newval)
2579 (ses-print-cell row col))))
2581 (defun ses-read-column-printer (col newval)
2582 "Set the printer function for the current column.
2583 See `ses-read-cell-printer' for input forms."
2585 (let ((col (cdr (ses-sym-rowcol ses--curcell))))
2587 (list col (ses-read-printer (format "Column %s printer: "
2588 (ses-column-letter col))
2589 (ses-col-printer col)))))
2591 (unless (eq newval t)
2593 (ses-set-parameter 'ses--col-printers newval col)
2595 (dotimes (row ses--numrows)
2596 (ses-print-cell row col)))))
2598 (defun ses-read-default-printer (newval)
2599 "Set the default printer function for cells that have no other.
2600 See `ses-read-cell-printer' for input forms."
2602 (list (ses-read-printer "Default printer: " ses--default-printer)))
2603 (unless (eq newval t)
2605 (ses-set-parameter 'ses--default-printer newval)
2606 (ses-reprint-all t)))
2609 ;;----------------------------------------------------------------------------
2610 ;; Spreadsheet size adjustments
2611 ;;----------------------------------------------------------------------------
2613 (defun ses-insert-row (count)
2614 "Insert a new row before the current one.
2615 With prefix, insert COUNT rows before current one."
2617 (ses-check-curcell 'end)
2618 (or (> count 0) (signal 'args-out-of-range nil))
2620 (let ((inhibit-quit t)
2621 (inhibit-read-only t)
2622 (row (or (car (ses-sym-rowcol ses--curcell)) ses--numrows))
2624 ;;Create a new set of cell-variables
2625 (ses-create-cell-variable-range ses--numrows (+ ses--numrows count -1)
2626 0 (1- ses--numcols))
2627 (ses-set-parameter 'ses--numrows (+ ses--numrows count))
2629 (ses-goto-print row 0)
2630 (dotimes-with-progress-reporter (x count) "Inserting row..."
2631 ;;Create a row of empty cells. The `symbol' fields will be set by
2632 ;;the call to ses-relocate-all.
2633 (setq newrow (make-vector ses--numcols nil))
2634 (dotimes (col ses--numcols)
2635 (aset newrow col (ses-make-cell)))
2636 (setq ses--cells (ses-vector-insert ses--cells row newrow))
2637 (push `(apply ses-vector-delete ses--cells ,row 1) buffer-undo-list)
2638 (insert ses--blank-line))
2639 ;;Insert empty lines in cell data area (will be replaced by
2641 (ses-goto-data row 0)
2642 (insert (make-string (* (1+ ses--numcols) count) ?\n))
2643 (ses-relocate-all row 0 count 0)
2644 ;;If any cell printers insert constant text, insert that text
2646 (let ((cols (mapconcat #'ses-call-printer ses--col-printers nil))
2647 (global (ses-call-printer ses--default-printer)))
2648 (if (or (> (length cols) 0) (> (length global) 0))
2650 (dotimes (col ses--numcols)
2651 ;;These cells are always nil, only constant formatting printed
2652 (1value (ses-print-cell (+ x row) col))))))
2653 (when (> ses--header-row row)
2654 ;;Inserting before header
2655 (ses-set-parameter 'ses--header-row (+ ses--header-row count))
2656 (ses-reset-header-string)))
2657 ;;Reconstruct text attributes
2660 (push '(apply ses-widen) buffer-undo-list)
2661 ;;Return to current cell
2663 (ses-jump-safe ses--curcell)
2664 (ses-goto-print (1- ses--numrows) 0)))
2666 (defun ses-delete-row (count)
2667 "Delete the current row.
2668 With prefix, deletes COUNT rows starting from the current one."
2671 (or (> count 0) (signal 'args-out-of-range nil))
2672 (let ((inhibit-quit t)
2673 (inhibit-read-only t)
2674 (row (car (ses-sym-rowcol ses--curcell))))
2675 (setq count (min count (- ses--numrows row)))
2677 (ses-set-parameter 'ses--numrows (- ses--numrows count))
2678 ;;Delete lines from print area
2679 (ses-goto-print row 0)
2680 (ses-delete-line count)
2681 ;;Delete lines from cell data area
2682 (ses-goto-data row 0)
2683 (ses-delete-line (* count (1+ ses--numcols)))
2684 ;;Relocate variables and formulas
2685 (ses-set-with-undo 'ses--cells (ses-vector-delete ses--cells row count))
2686 (ses-relocate-all row 0 (- count) 0)
2687 (ses-destroy-cell-variable-range ses--numrows (+ ses--numrows count -1)
2688 0 (1- ses--numcols))
2689 (when (> ses--header-row row)
2690 (if (<= ses--header-row (+ row count))
2691 ;;Deleting the header row
2692 (ses-set-parameter 'ses--header-row 0)
2693 (ses-set-parameter 'ses--header-row (- ses--header-row count)))
2694 (ses-reset-header-string)))
2695 ;;Reconstruct attributes
2698 (push '(apply ses-widen) buffer-undo-list)
2699 (ses-jump-safe ses--curcell))
2701 (defun ses-insert-column (count &optional col width printer)
2702 "Insert a new column before COL (default is the current one).
2703 With prefix, insert COUNT columns before current one.
2704 If COL is specified, the new column(s) get the specified WIDTH and PRINTER
2705 \(otherwise they're taken from the current column)."
2708 (or (> count 0) (signal 'args-out-of-range nil))
2710 (setq col (cdr (ses-sym-rowcol ses--curcell))
2711 width (ses-col-width col)
2712 printer (ses-col-printer col)))
2714 (let ((inhibit-quit t)
2715 (inhibit-read-only t)
2716 (widths ses--col-widths)
2717 (printers ses--col-printers)
2719 ;;Create a new set of cell-variables
2720 (ses-create-cell-variable-range 0 (1- ses--numrows)
2721 ses--numcols (+ ses--numcols count -1))
2722 ;;Insert each column.
2723 (dotimes-with-progress-reporter (x count) "Inserting column..."
2724 ;;Create a column of empty cells. The `symbol' fields will be set by
2725 ;;the call to ses-relocate-all.
2726 (ses-adjust-print-width col (1+ width))
2727 (ses-set-parameter 'ses--numcols (1+ ses--numcols))
2728 (dotimes (row ses--numrows)
2729 (and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*)
2730 ;;Inserting in the middle of a spill-over
2732 (ses-aset-with-undo ses--cells row
2733 (ses-vector-insert (aref ses--cells row)
2734 col (ses-make-cell)))
2735 ;;Insert empty lines in cell data area (will be replaced by
2737 (ses-goto-data row col)
2739 ;; Insert column width and printer.
2740 (setq widths (ses-vector-insert widths col width)
2741 printers (ses-vector-insert printers col printer)))
2742 (ses-set-parameter 'ses--col-widths widths)
2743 (ses-set-parameter 'ses--col-printers printers)
2744 (ses-reset-header-string)
2745 (ses-relocate-all 0 col 0 count)
2748 (when (or (> (length (ses-call-printer printer)) 0)
2749 (> (length (ses-call-printer ses--default-printer)) 0))
2750 ;; Either column printer or global printer inserts some constant text.
2751 ;; Reprint the new columns to insert that text.
2752 (dotimes (x ses--numrows)
2754 ;; Always nil here --- this is a blank column.
2755 (1value (ses-print-cell-new-width x (+ y col))))))
2757 (ses-jump-safe ses--curcell))
2759 (defun ses-delete-column (count)
2760 "Delete the current column.
2761 With prefix, deletes COUNT columns starting from the current one."
2764 (or (> count 0) (signal 'args-out-of-range nil))
2765 (let ((inhibit-quit t)
2766 (inhibit-read-only t)
2767 (rowcol (ses-sym-rowcol ses--curcell))
2769 col origrow has-skip)
2770 (setq origrow (car rowcol)
2772 count (min count (- ses--numcols col)))
2773 (if (= count ses--numcols)
2774 (error "Can't delete all columns!"))
2775 ;;Determine width of column(s) being deleted
2777 (setq width (+ width (ses-col-width (+ col x)) 1)))
2779 (ses-set-parameter 'ses--numcols (- ses--numcols count))
2780 (ses-adjust-print-width col (- width))
2781 (dotimes-with-progress-reporter (row ses--numrows) "Deleting column..."
2782 ;;Delete lines from cell data area
2783 (ses-goto-data row col)
2784 (ses-delete-line count)
2785 ;;Delete cells. Check if deletion area begins or ends with a skip.
2786 (if (or (eq (ses-cell-value row col) '*skip*)
2787 (and (< col ses--numcols)
2788 (eq (ses-cell-value row (+ col count)) '*skip*)))
2790 (ses-aset-with-undo ses--cells row
2791 (ses-vector-delete (aref ses--cells row) col count)))
2793 (ses-set-parameter 'ses--col-widths
2794 (ses-vector-delete ses--col-widths col count))
2795 (ses-set-parameter 'ses--col-printers
2796 (ses-vector-delete ses--col-printers col count))
2797 (ses-reset-header-string)
2798 ;;Relocate variables and formulas
2799 (ses-relocate-all 0 col 0 (- count))
2800 (ses-destroy-cell-variable-range 0 (1- ses--numrows)
2801 ses--numcols (+ ses--numcols count -1))
2805 (if (>= col ses--numcols)
2806 (setq col (1- col)))
2807 (ses-goto-print origrow col)))
2809 (defun ses-forward-or-insert (&optional count)
2810 "Move to next cell in row, or inserts a new cell if already in last one, or
2811 inserts a new row if at bottom of print area. Repeat COUNT times."
2813 (ses-check-curcell 'end)
2814 (setq deactivate-mark t) ; Doesn't combine well with ranges.
2817 (if (not ses--curcell)
2818 (progn ; At bottom of print area.
2819 (barf-if-buffer-read-only)
2821 (let ((col (cdr (ses-sym-rowcol ses--curcell))))
2823 (char-before (next-single-property-change (point)
2825 ;; We're already in last nonskipped cell on line. Need to create a
2827 (barf-if-buffer-read-only)
2828 (ses-insert-column (- count x)
2831 (ses-col-printer col)))))
2834 (defun ses-append-row-jump-first-column ()
2835 "Insert a new row after current one and jump to its first column."
2839 (beginning-of-line 2)
2843 (defun ses-set-column-width (col newwidth)
2844 "Set the width of the current column."
2846 (let ((col (cdr (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))))
2847 (barf-if-buffer-read-only)
2849 (if current-prefix-arg
2850 (prefix-numeric-value current-prefix-arg)
2851 (read-from-minibuffer (format "Column %s width [currently %d]: "
2852 (ses-column-letter col)
2853 (ses-col-width col))
2854 nil ; No initial contents.
2855 nil ; No override keymap.
2856 t ; Convert to Lisp object.
2859 (ses-col-width col))))))) ; Default value.
2861 (error "Invalid column width"))
2863 (ses-reset-header-string)
2865 (let ((inhibit-quit t))
2866 (ses-adjust-print-width col (- newwidth (ses-col-width col)))
2867 (ses-set-parameter 'ses--col-widths newwidth col))
2868 (dotimes (row ses--numrows)
2869 (ses-print-cell-new-width row col))))
2872 ;;----------------------------------------------------------------------------
2873 ;; Cut and paste, import and export
2874 ;;----------------------------------------------------------------------------
2876 (defun ses--advice-copy-region-as-kill (crak-fun beg end &rest args)
2877 ;; FIXME: Why doesn't it make sense to copy read-only or
2878 ;; intangible attributes? They're removed upon yank!
2879 "It doesn't make sense to copy read-only or intangible attributes into the
2880 kill ring. It probably doesn't make sense to copy keymap properties.
2881 We'll assume copying front-sticky properties doesn't make sense, either.
2883 This advice also includes some SES-specific code because otherwise it's too
2884 hard to override how mouse-1 works."
2889 (if (not (and (derived-mode-p 'ses-mode)
2890 (eq (get-text-property beg 'read-only) 'ses)
2891 (eq (get-text-property (1- end) 'read-only) 'ses)))
2892 (apply crak-fun beg end args) ; Normal copy-region-as-kill.
2893 (kill-new (ses-copy-region beg end))
2894 (if transient-mark-mode
2895 (setq deactivate-mark t))
2897 (advice-add 'copy-region-as-kill :around #'ses--advice-copy-region-as-kill)
2899 (defun ses-copy-region (beg end)
2900 "Treat the region as rectangular. Convert the intangible attributes to
2901 SES attributes recording the contents of the cell as of the time of copying."
2902 (when (= end ses--data-marker)
2903 ;;Avoid overflow situation
2904 (setq end (1- ses--data-marker)))
2905 (let* ((inhibit-point-motion-hooks t)
2906 (x (mapconcat 'ses-copy-region-helper
2907 (extract-rectangle beg (1- end)) "\n")))
2908 (remove-text-properties 0 (length x)
2916 (defun ses-copy-region-helper (line)
2917 "Converts one line (of a rectangle being extracted from a spreadsheet) to
2918 external form by attaching to each print cell a 'ses attribute that records
2919 the corresponding data cell."
2920 (or (> (length line) 1)
2921 (error "Empty range"))
2922 (let ((inhibit-read-only t)
2924 mycell next sym rowcol)
2926 (setq sym (get-text-property pos 'intangible line)
2927 next (next-single-property-change pos 'intangible line)
2928 rowcol (ses-sym-rowcol sym)
2929 mycell (ses-get-cell (car rowcol) (cdr rowcol)))
2930 (put-text-property pos (or next (length line))
2932 (list (ses-cell-symbol mycell)
2933 (ses-cell-formula mycell)
2934 (ses-cell-printer mycell))
2939 (defun ses-kill-override (beg end)
2940 "Generic override for any commands that kill text.
2941 We clear the killed cells instead of deleting them."
2943 (ses-check-curcell 'needrange)
2944 ;; For some reason, the text-read-only error is not caught by `delete-region',
2945 ;; so we have to use subterfuge.
2946 (let ((buffer-read-only t))
2947 (1value (condition-case nil
2948 (noreturn (funcall (lookup-key (current-global-map)
2949 (this-command-keys))
2951 (buffer-read-only nil)))) ; The expected error.
2952 ;; Because the buffer was marked read-only, the kill command turned itself
2953 ;; into a copy. Now we clear the cells or signal the error. First we check
2954 ;; whether the buffer really is read-only.
2955 (barf-if-buffer-read-only)
2957 (ses-dorange ses--curcell
2958 (ses-clear-cell row col))
2959 (ses-jump (car ses--curcell)))
2961 (defun ses--advice-yank (yank-fun &optional arg &rest args)
2962 "In SES mode, the yanked text is inserted as cells.
2964 If the text contains 'ses attributes (meaning it went to the kill-ring from a
2965 SES buffer), the formulas and print functions are restored for the cells. If
2966 the text contains tabs, this is an insertion of tab-separated formulas.
2967 Otherwise the text is inserted as the formula for the current cell.
2969 When inserting cells, the formulas are usually relocated to keep the same
2970 relative references to neighboring cells. This is best if the formulas
2971 generally refer to other cells within the yanked text. You can use the C-u
2972 prefix to specify insertion without relocation, which is best when the
2973 formulas refer to cells outside the yanked text.
2975 When inserting formulas, the text is treated as a string constant if it doesn't
2976 make sense as a sexp or would otherwise be considered a symbol. Use 'sym to
2977 explicitly insert a symbol, or use the C-u prefix to treat all unmarked words
2979 (if (not (and (derived-mode-p 'ses-mode)
2980 (eq (get-text-property (point) 'keymap) 'ses-mode-print-map)))
2981 (apply yank-fun arg args) ; Normal non-SES yank.
2982 (ses-check-curcell 'end)
2984 (let ((text (current-kill (cond
2988 (or (ses-yank-cells text arg)
2989 (ses-yank-tsf text arg)
2990 (ses-yank-one (ses-yank-resize 1 1)
2993 (if (memq (aref text (1- (length text))) '(?\t ?\n))
2994 ;; Just one cell --- delete final tab or newline.
2998 (exchange-point-and-mark))))
2999 (advice-add 'yank :around #'ses--advice-yank)
3001 (defun ses-yank-pop (arg)
3002 "Replace just-yanked stretch of killed text with a different stretch.
3003 This command is allowed only immediately after a `yank' or a `yank-pop',
3004 when the region contains a stretch of reinserted previously-killed text.
3005 We replace it with a different stretch of killed text.
3006 Unlike standard `yank-pop', this function uses `undo' to delete the
3007 previous insertion."
3009 (or (eq last-command 'yank)
3010 ;;Use noreturn here just to avoid a "poor-coverage" warning in its
3012 (noreturn (error "Previous command was not a yank")))
3015 (yank (1+ (or arg 1)))
3016 (setq this-command 'yank))
3018 (defun ses-yank-cells (text arg)
3019 "If the TEXT has a proper set of 'ses attributes, insert the text as
3020 cells, else return nil. The cells are reprinted--the supplied text is
3021 ignored because the column widths, default printer, etc. at yank time might
3022 be different from those at kill-time. ARG is a list to indicate that
3023 formulas are to be inserted without relocation."
3024 (let ((first (get-text-property 0 'ses text))
3025 (last (get-text-property (1- (length text)) 'ses text)))
3026 (when (and first last) ;;Otherwise not proper set of attributes
3027 (setq first (ses-sym-rowcol (car first))
3028 last (ses-sym-rowcol (car last)))
3029 (let* ((needrows (- (car last) (car first) -1))
3030 (needcols (- (cdr last) (cdr first) -1))
3031 (rowcol (ses-yank-resize needrows needcols))
3032 (rowincr (- (car rowcol) (car first)))
3033 (colincr (- (cdr rowcol) (cdr first)))
3036 (dotimes-with-progress-reporter (row needrows) "Yanking..."
3037 (setq myrow (+ row (car rowcol)))
3038 (dotimes (col needcols)
3039 (setq mycol (+ col (cdr rowcol))
3040 last (get-text-property pos 'ses text)
3041 pos (next-single-property-change pos 'ses text)
3042 x (ses-sym-rowcol (car last)))
3044 ;; Newline --- all remaining cells on row are skipped.
3045 (setq x (cons (- myrow rowincr) (+ needcols colincr -1))
3046 last (list nil nil nil)
3048 (if (/= (car x) (- myrow rowincr))
3049 (error "Cell row error"))
3050 (if (< (- mycol colincr) (cdr x))
3051 ;; Some columns were skipped.
3052 (let ((oldcol mycol))
3053 (while (< (- mycol colincr) (cdr x))
3054 (ses-clear-cell myrow mycol)
3057 (ses-print-cell myrow (1- oldcol)))) ;; This inserts *skip*.
3058 (when (car last) ; Skip this for *skip* cells.
3059 (setq x (nth 2 last))
3060 (unless (equal x (ses-cell-printer myrow mycol))
3063 (eq (car-safe x) 'ses-safe-printer)
3064 (setq x `(ses-safe-printer ,x)))
3065 (ses-set-cell myrow mycol 'printer x))
3066 (setq x (cadr last))
3068 (setq x (ses-relocate-formula x 0 0 rowincr colincr)))
3070 (eq (car-safe x) 'ses-safe-formula)
3071 (setq x `(ses-safe-formula ,x)))
3072 (ses-cell-set-formula myrow mycol x)))
3074 (if (get-text-property pos 'ses text)
3075 (error "Missing newline between rows"))
3076 (setq pos (next-single-property-change pos 'ses text))))
3079 (defun ses-yank-one (rowcol text from to arg)
3080 "Insert the substring [FROM,TO] of TEXT as the formula for cell ROWCOL (a
3081 cons of ROW and COL). Treat plain symbols as strings unless ARG is a list."
3082 (let ((val (condition-case nil
3083 (read-from-string text from to)
3084 (error (cons nil from)))))
3086 ((< (cdr val) (or to (length text)))
3087 ;; Invalid sexp --- leave it as a string.
3088 (setq val (substring text from to)))
3089 ((and (car val) (symbolp (car val)))
3091 (setq val (list 'quote (car val))) ; Keep symbol.
3092 (setq val (substring text from to)))) ; Treat symbol as text.
3094 (setq val (car val))))
3095 (let ((row (car rowcol))
3098 (setq val `(ses-safe-formula ,val)))
3099 (ses-cell-set-formula row col val))))
3101 (defun ses-yank-tsf (text arg)
3102 "If TEXT contains tabs and/or newlines, treat the tabs as
3103 column-separators and the newlines as row-separators and insert the text as
3104 cell formulas--else return nil. Treat plain symbols as strings unless ARG
3105 is a list. Ignore a final newline."
3106 (if (or (not (string-match "[\t\n]" text))
3107 (= (match-end 0) (length text)))
3110 (if (/= (aref text (1- (length text))) ?\n)
3111 (setq text (concat text "\n")))
3117 ;;Find all the tabs and newlines
3118 (while (setq pos (string-match "[\t\n]" text (1+ pos)))
3120 (setq cols (1+ cols))
3121 (when (eq (aref text pos) ?\n)
3123 (setq needcols cols)
3124 (or (= needcols cols)
3125 (error "Inconsistent row lengths")))
3127 needrows (1+ needrows))))
3128 ;;Insert the formulas
3129 (setq rowcol (ses-yank-resize needrows needcols))
3130 (dotimes (row needrows)
3131 (dotimes (col needcols)
3132 (ses-yank-one (cons (+ (car rowcol) needrows (- row) -1)
3133 (+ (cdr rowcol) needcols (- col) -1))
3134 text (1+ (cadr spots)) (car spots) arg)
3135 (setq spots (cdr spots))))
3136 (ses-goto-print (+ (car rowcol) needrows -1)
3137 (+ (cdr rowcol) needcols -1))
3140 (defun ses-yank-resize (needrows needcols)
3141 "If this yank will require inserting rows and/or columns, ask for
3142 confirmation and then insert them. Result is (row,col) for top left of yank
3143 spot, or error signal if user requests cancel."
3145 (let ((rowcol (if ses--curcell
3146 (ses-sym-rowcol ses--curcell)
3147 (cons ses--numrows 0)))
3149 (setq needrows (- (+ (car rowcol) needrows) ses--numrows)
3150 needcols (- (+ (cdr rowcol) needcols) ses--numcols)
3151 rowbool (> needrows 0)
3152 colbool (> needcols 0))
3153 (when (or rowbool colbool)
3154 ;;Need to insert. Get confirm
3155 (or (y-or-n-p (format "Yank will insert %s%s%s. Continue? "
3156 (if rowbool (format "%d rows" needrows) "")
3157 (if (and rowbool colbool) " and " "")
3158 (if colbool (format "%d columns" needcols) "")))
3159 (error "Cancelled"))
3163 (ses-goto-print ses--numrows 0)
3164 (ses-insert-row needrows))))
3166 (ses-insert-column needcols
3168 (ses-col-width (1- ses--numcols))
3169 (ses-col-printer (1- ses--numcols)))))
3172 (defun ses-export-tsv (_beg _end)
3173 "Export values from the current range, with tabs between columns and
3174 newlines between rows. Result is placed in kill ring."
3176 (ses-export-tab nil))
3178 (defun ses-export-tsf (_beg _end)
3179 "Export formulas from the current range, with tabs between columns and
3180 newlines between rows. Result is placed in kill ring."
3184 (defun ses-export-tab (want-formulas)
3185 "Export the current range with tabs between columns and newlines between rows.
3186 Result is placed in kill ring. The export is values unless WANT-FORMULAS
3187 is non-nil. Newlines and tabs in the export text are escaped."
3188 (ses-check-curcell 'needrange)
3189 (let ((print-escape-newlines t)
3191 (ses-dorange ses--curcell
3192 (setq item (if want-formulas
3193 (ses-cell-formula row col)
3194 (ses-cell-value row col)))
3195 (if (eq (car-safe item) 'ses-safe-formula)
3196 ;;Hide our deferred safety-check marker
3197 (setq item (cadr item)))
3198 (if (or (not item) (eq item '*skip*))
3200 (when (eq (car-safe item) 'quote)
3202 (setq item (cadr item)))
3203 (setq item (prin1-to-string item t))
3204 (setq item (replace-regexp-in-string "\t" "\\\\t" item))
3210 (push "\n" result))))
3211 (setq result (apply 'concat (nreverse result)))
3215 ;;----------------------------------------------------------------------------
3216 ;; Other user commands
3217 ;;----------------------------------------------------------------------------
3219 (defun ses-unset-header-row ()
3220 "Select the default header row."
3222 (ses-set-header-row 0))
3224 (defun ses-set-header-row (row)
3225 "Set the ROW to display in the header-line.
3226 With a numerical prefix arg, use that row.
3227 With no prefix arg, use the current row.
3228 With a \\[universal-argument] prefix arg, prompt the user.
3229 The top row is row 1. Selecting row 0 displays the default header row."
3231 (list (if (numberp current-prefix-arg) current-prefix-arg
3232 (let ((currow (1+ (car (ses-sym-rowcol ses--curcell)))))
3233 (if current-prefix-arg
3234 (read-number "Header row: " currow)
3236 (if (or (< row 0) (> row ses--numrows))
3237 (error "Invalid header-row"))
3239 (let ((oldval ses--header-row))
3240 (let (buffer-undo-list)
3241 (ses-set-parameter 'ses--header-row row))
3242 (push `(apply ses-set-header-row ,oldval) buffer-undo-list))
3243 (ses-reset-header-string))
3245 (defun ses-mark-row ()
3246 "Mark the entirety of current row as a range."
3248 (ses-check-curcell 'range)
3249 (let ((row (car (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell)))))
3251 (ses-goto-print (1+ row) 0)
3252 (push-mark (point) nil t)
3253 (ses-goto-print row 0)))
3255 (defun ses-mark-column ()
3256 "Mark the entirety of current column as a range."
3258 (ses-check-curcell 'range)
3259 (let ((col (cdr (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell))))
3262 (ses-goto-print (1- ses--numrows) col)
3264 (push-mark (point) nil t)
3265 (while (eq '*skip* (ses-cell-value row col))
3266 ;;Skip over initial cells in column that can't be selected
3267 (setq row (1+ row)))
3268 (ses-goto-print row col)))
3270 (defun ses-end-of-line ()
3271 "Move point to last cell on line."
3273 (ses-check-curcell 'end 'range)
3274 (when ses--curcell ; Otherwise we're at the bottom row, which is empty
3276 (let ((col (1- ses--numcols))
3278 (if (symbolp ses--curcell)
3280 (setq row (car (ses-sym-rowcol ses--curcell)))
3281 ;; Range --- use whichever end of the range the point is at.
3282 (setq rowcol (ses-sym-rowcol (if (< (point) (mark))
3284 (cdr ses--curcell))))
3285 ;; If range already includes the last cell in a row, point is actually
3286 ;; in the following row.
3287 (if (<= (cdr rowcol) (1- col))
3288 (setq row (car rowcol))
3289 (setq row (1+ (car rowcol)))
3290 (if (= row ses--numrows)
3291 ;;Already at end - can't go anywhere
3293 (when (< row ses--numrows) ; Otherwise it's a range that includes last cell.
3294 (while (eq (ses-cell-value row col) '*skip*)
3295 ;; Back to beginning of multi-column cell.
3296 (setq col (1- col)))
3297 (ses-goto-print row col)))))
3299 (defun ses-renarrow-buffer ()
3300 "Narrow the buffer so only the print area is visible.
3301 Use after \\[widen]."
3303 (setq ses--deferred-narrow t))
3305 (defun ses-sort-column (sorter &optional reverse)
3306 "Sort the range by a specified column.
3307 With prefix, sorts in REVERSE order."
3308 (interactive "*sSort column: \nP")
3309 (ses-check-curcell 'needrange)
3310 (let ((min (ses-sym-rowcol (car ses--curcell)))
3311 (max (ses-sym-rowcol (cdr ses--curcell))))
3312 (let ((minrow (car min))
3317 (setq sorter (cdr (ses-sym-rowcol (intern (concat sorter "1")))))
3318 (or (and sorter (>= sorter mincol) (<= sorter maxcol))
3319 (error "Invalid sort column"))
3320 ;;Get key columns and sort them
3321 (dotimes (x (- maxrow minrow -1))
3322 (ses-goto-print (+ minrow x) sorter)
3323 (setq end (next-single-property-change (point) 'intangible))
3324 (push (cons (buffer-substring-no-properties (point) end)
3327 (setq keys (sort keys #'(lambda (x y) (string< (car x) (car y)))))
3328 ;;Extract the lines in reverse sorted order
3330 (setq keys (nreverse keys)))
3332 (ses-goto-print (cdr x) (1+ maxcol))
3334 (ses-goto-print (cdr x) mincol)
3335 (push (ses-copy-region (point) end) extracts))
3337 ;;Paste the lines sequentially
3338 (dotimes (x (- maxrow minrow -1))
3339 (ses-goto-print (+ minrow x) mincol)
3341 (ses-yank-cells (pop extracts) nil)))))
3343 (defun ses-sort-column-click (event reverse)
3344 "Mouse version of `ses-sort-column'."
3345 (interactive "*e\nP")
3346 (setq event (event-end event))
3347 (select-window (posn-window event))
3348 (setq event (car (posn-col-row event))) ; Click column.
3350 (while (and (< col ses--numcols) (> event (ses-col-width col)))
3351 (setq event (- event (ses-col-width col) 1)
3353 (if (>= col ses--numcols)
3355 (ses-sort-column (ses-column-letter col) reverse))))
3357 (defun ses-insert-range ()
3358 "Insert into minibuffer the list of cells currently highlighted in the
3362 (with-current-buffer (window-buffer minibuffer-scroll-window)
3363 (ses-command-hook) ; For ses-coverage.
3364 (ses-check-curcell 'needrange)
3365 (setq x (cdr (macroexpand `(ses-range ,(car ses--curcell)
3366 ,(cdr ses--curcell))))))
3367 (insert (substring (prin1-to-string (nreverse x)) 1 -1))))
3369 (defun ses-insert-ses-range ()
3370 "Insert \"(ses-range x y)\" in the minibuffer to represent the currently
3371 highlighted range in the spreadsheet."
3374 (with-current-buffer (window-buffer minibuffer-scroll-window)
3375 (ses-command-hook) ; For ses-coverage.
3376 (ses-check-curcell 'needrange)
3377 (setq x (format "(ses-range %S %S)"
3379 (cdr ses--curcell))))
3382 (defun ses-insert-range-click (event)
3383 "Mouse version of `ses-insert-range'."
3385 (mouse-set-point event)
3388 (defun ses-insert-ses-range-click (event)
3389 "Mouse version of `ses-insert-ses-range'."
3391 (mouse-set-point event)
3392 (ses-insert-ses-range))
3394 (defun ses-replace-name-in-formula (formula old-name new-name)
3395 (let ((new-formula formula))
3396 (unless (and (consp formula)
3397 (eq (car-safe formula) 'quote))
3399 (let ((elt (car-safe formula)))
3402 (setcar formula (ses-replace-name-in-formula elt old-name new-name)))
3404 (eq (car-safe formula) old-name))
3405 (setcar formula new-name))))
3406 (setq formula (cdr formula))))
3409 (defun ses-rename-cell (new-name &optional cell)
3410 "Rename current cell."
3411 (interactive "*SEnter new name: ")
3413 (and (local-variable-p new-name)
3414 (ses-is-cell-sym-p new-name)
3415 (error "Already a cell name"))
3416 (and (boundp new-name)
3417 (null (yes-or-no-p (format "`%S' is already bound outside this buffer, continue? "
3419 (error "Already a bound cell name")))
3421 (sym (if (ses-cell-p cell)
3422 (ses-cell-symbol cell)
3427 (rowcol (ses-sym-rowcol sym))
3430 new-rowcol old-name)
3431 (setq cell (or cell (ses-get-cell row col))
3432 old-name (ses-cell-symbol cell)
3433 new-rowcol (ses-decode-cell-symbol (symbol-name new-name)))
3435 (if (equal new-rowcol rowcol)
3436 (put new-name 'ses-cell rowcol)
3437 (error "Not a valid name for this cell location"))
3438 (setq ses--named-cell-hashmap (or ses--named-cell-hashmap (make-hash-table :test 'eq)))
3439 (put new-name 'ses-cell :ses-named)
3440 (puthash new-name rowcol ses--named-cell-hashmap))
3441 (push `(ses-rename-cell ,old-name ,cell) buffer-undo-list)
3442 ;; replace name by new name in formula of cells refering to renamed cell
3443 (dolist (ref (ses-cell-references cell))
3444 (let* ((x (ses-sym-rowcol ref))
3445 (xcell (ses-get-cell (car x) (cdr x))))
3446 (ses-cell-formula-aset xcell
3447 (ses-replace-name-in-formula
3448 (ses-cell-formula xcell)
3451 ;; replace name by new name in reference list of cells to which renamed cell refers to
3452 (dolist (ref (ses-formula-references (ses-cell-formula cell)))
3453 (let* ((x (ses-sym-rowcol ref))
3454 (xcell (ses-get-cell (car x) (cdr x))))
3455 (ses-cell-references-aset xcell
3456 (cons new-name (delq sym
3457 (ses-cell-references xcell))))))
3458 (push new-name ses--renamed-cell-symb-list)
3459 (set new-name (symbol-value sym))
3460 (aset cell 0 new-name)
3462 (and curcell (setq ses--curcell new-name))
3463 (let* ((pos (point))
3464 (inhibit-read-only t)
3465 (col (current-column))
3466 (end (save-excursion
3467 (move-to-column (1+ col))
3469 (+ pos (ses-col-width col) 1)
3471 (put-text-property pos end 'intangible new-name))
3473 (setq mode-line-process (list " cell "
3474 (symbol-name new-name)))
3475 (force-mode-line-update)))
3477 (defun ses-refresh-local-printer (name compiled-value)
3478 "Refresh printout of spreadsheet for all cells with printer
3479 defined to local printer named NAME using the value COMPILED-VALUE for this printer"
3480 (message "Refreshing cells using printer %S" name)
3482 (dotimes (row ses--numrows)
3483 (dotimes (col ses--numcols)
3484 (let ((cell-printer (ses-cell-printer row col)))
3485 (when (eq cell-printer name)
3489 (ses-print-cell row col)))))))
3491 (defun ses-define-local-printer (printer-name)
3492 "Define a local printer with name PRINTER-NAME."
3493 (interactive "*SEnter printer name: ")
3494 (let* ((cur-printer (gethash printer-name ses--local-printer-hashmap))
3495 (default (and (vectorp cur-printer) (ses-locprn-get-def cur-printer)))
3498 (new-printer (ses-read-printer (format "Enter definition of printer %S: " printer-name) default)))
3500 ;; cancelled operation => do nothing
3501 ((eq new-printer t))
3502 ;; no change => do nothing
3503 ((and (vectorp cur-printer) (equal new-printer default)))
3504 ;; re-defined printer
3505 ((vectorp cur-printer)
3506 (setq create-printer 0)
3507 (ses-locprn-def-aset cur-printer new-printer)
3508 (ses-refresh-local-printer
3510 (ses-locprn-compiled-aset cur-printer (ses-local-printer-compile new-printer))))
3513 (setq create-printer 1)
3514 (puthash printer-name
3516 (ses-make-local-printer-info new-printer))
3517 ses--local-printer-hashmap)))
3518 (when create-printer
3519 (setq printer-def-text
3521 "(ses-local-printer "
3522 (symbol-name printer-name)
3524 (prin1-to-string (ses-locprn-get-def cur-printer))
3527 (ses-goto-data ses--numrows
3528 (ses-locprn-get-number cur-printer))
3529 (let ((inhibit-read-only t))
3530 ;; Special undo since it's outside the narrowed buffer.
3531 (let (buffer-undo-list)
3532 (if (= create-printer 0)
3533 (delete-region (point) (line-end-position))
3536 (insert printer-def-text)
3537 (when (= create-printer 1)
3538 (ses-file-format-extend-paramter-list 3)
3539 (ses-set-parameter 'ses--numlocprn (+ ses--numlocprn create-printer))) ))))) )
3542 ;;----------------------------------------------------------------------------
3543 ;; Checking formulas for safety
3544 ;;----------------------------------------------------------------------------
3546 (defun ses-safe-printer (printer)
3547 "Return PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
3548 (if (or (stringp printer)
3549 (stringp (car-safe printer))
3551 (and (symbolp printer) (gethash printer ses--local-printer-hashmap))
3552 (ses-warn-unsafe printer 'unsafep-function))
3556 (defun ses-safe-formula (formula)
3557 "Return FORMULA if safe, or the substitute formula *unsafe* otherwise."
3558 (if (ses-warn-unsafe formula 'unsafep)
3560 `(ses-unsafe ',formula)))
3562 (defun ses-warn-unsafe (formula checker)
3563 "Apply CHECKER to FORMULA.
3564 If result is non-nil, asks user for confirmation about FORMULA,
3565 which might be unsafe. Returns t if formula is safe or user allows
3566 execution anyway. Always returns t if `safe-functions' is t."
3567 (if (eq safe-functions t)
3569 (setq checker (funcall checker formula))
3572 (y-or-n-p (format "Formula %S\nmight be unsafe %S. Process it? "
3573 formula checker)))))
3576 ;;----------------------------------------------------------------------------
3577 ;; Standard formulas
3578 ;;----------------------------------------------------------------------------
3580 (defun ses--clean-! (&rest x)
3581 "Clean by `delq' list X from any occurrence of `nil' or `*skip*'."
3582 (delq nil (delq '*skip* x)))
3584 (defun ses--clean-_ (x y)
3585 "Clean list X by replacing by Y any occurrence of `nil' or `*skip*'.
3587 This will change X by making `setcar' on its cons cells."
3588 (let ((ret x) ret-elt)
3590 (setq ret-elt (car ret))
3591 (when (memq ret-elt '(nil *skip*))
3593 (setq ret (cdr ret))))
3596 (defmacro ses-range (from to &rest rest)
3597 "Expand to a list of cell-symbols for the range going from
3598 FROM up to TO. The range automatically expands to include any
3599 new row or column inserted into its middle. The SES library code
3600 specifically looks for the symbol `ses-range', so don't create an
3601 alias for this macro!
3603 By passing in REST some flags one can configure the way the range
3604 is read and how it is formatted.
3606 In the sequel we assume that cells A1, B1, A2 B2 have respective values
3609 Readout direction is specified by a `>v', '`>^', `<v', `<^',
3610 `v>', `v<', `^>', `^<' flag. For historical reasons, in absence
3611 of such a flag, a default direction of `^<' is assumed. This
3612 way `(ses-range A1 B2 ^>)' will evaluate to `(1 3 2 4)',
3613 while `(ses-range A1 B2 >^)' will evaluate to (3 4 1 2).
3615 If the range is one row, then `>' can be used as a shorthand to
3616 `>v' or `>^', and `<' to `<v' or `<^'.
3618 If the range is one column, then `v' can be used as a shorthand to
3619 `v>' or `v<', and `^' to `^>' or `v<'.
3621 A `!' flag will remove all cells whose value is nil or `*skip*'.
3623 A `_' flag will replace nil or `*skip*' by the value following
3624 the `_' flag. If the `_' flag is the last argument, then they are
3625 replaced by integer 0.
3627 A `*', `*1' or `*2' flag will vectorize the range in the sense of
3628 Calc. See info node `(Calc) Top'. Flag `*' will output either a
3629 vector or a matrix depending on the number of rows, `*1' will
3630 flatten the result to a one row vector, and `*2' will make a
3631 matrix whatever the number of rows.
3633 Warning: interaction with Calc is experimental and may produce
3634 confusing results if you are not aware of Calc data format.
3635 Use `math-format-value' as a printer for Calc objects."
3643 (ses-dorange (cons from to)
3644 (when (/= prev-row row)
3645 (push result-row result)
3646 (setq result-row nil))
3647 (push (ses-cell-symbol row col) result-row)
3648 (setq prev-row row))
3649 (push result-row result)
3651 (let ((x (pop rest)))
3653 (`>v (setq transpose nil reorient-x nil reorient-y nil))
3654 (`>^ (setq transpose nil reorient-x nil reorient-y t))
3655 (`<^ (setq transpose nil reorient-x t reorient-y t))
3656 (`<v (setq transpose nil reorient-x t reorient-y nil))
3657 (`v> (setq transpose t reorient-x nil reorient-y t))
3658 (`^> (setq transpose t reorient-x nil reorient-y nil))
3659 (`^< (setq transpose t reorient-x t reorient-y nil))
3660 (`v< (setq transpose t reorient-x t reorient-y t))
3661 ((or `* `*2 `*1) (setq vectorize x))
3662 (`! (setq clean 'ses--clean-!))
3663 (`_ (setq clean `(lambda (&rest x)
3664 (ses--clean-_ x ,(if rest (pop rest) 0)))))
3667 ; shorthands one row
3668 ((and (null (cddr result)) (memq x '(> <)))
3669 (push (intern (concat (symbol-name x) "v")) rest))
3670 ; shorthands one col
3671 ((and (null (cdar result)) (memq x '(v ^)))
3672 (push (intern (concat (symbol-name x) ">")) rest))
3673 (t (error "Unexpected flag `%S' in ses-range" x)))))))
3675 (setcdr (last result 2) nil)
3676 (setq result (cdr (nreverse result))))
3678 (setq result (mapcar 'nreverse result)))
3680 (let ((ret (mapcar (lambda (x) (list x)) (pop result))) iter)
3683 (dolist (elt (pop result))
3684 (setcar iter (cons elt (car iter)))
3685 (setq iter (cdr iter))))
3688 (cl-flet ((vectorize-*1
3690 (cons clean (cons (quote 'vec) (apply 'append result))))
3693 (cons clean (cons (quote 'vec)
3695 (cons clean (cons (quote 'vec) x)))
3698 (`nil (cons clean (apply 'append result)))
3699 (`*1 (vectorize-*1 clean result))
3700 (`*2 (vectorize-*2 clean result))
3701 (`* (funcall (if (cdr result)
3706 (defun ses-delete-blanks (&rest args)
3707 "Return ARGS reversed, with the blank elements (nil and *skip*) removed."
3710 (unless (memq cur '(nil *skip*))
3714 (defun ses+ (&rest args)
3715 "Compute the sum of the arguments, ignoring blanks."
3716 (apply '+ (apply 'ses-delete-blanks args)))
3718 (defun ses-average (list)
3719 "Computes the sum of the numbers in LIST, divided by their length. Blanks
3720 are ignored. Result is always floating-point, even if all args are integers."
3721 (setq list (apply 'ses-delete-blanks list))
3722 (/ (float (apply '+ list)) (length list)))
3724 (defmacro ses-select (fromrange test torange)
3725 "Select cells in FROMRANGE that are `equal' to TEST.
3726 For each match, return the corresponding cell from TORANGE.
3727 The ranges are macroexpanded but not evaluated so they should be
3728 either (ses-range BEG END) or (list ...). The TEST is evaluated."
3729 (setq fromrange (cdr (macroexpand fromrange))
3730 torange (cdr (macroexpand torange))
3732 (or (= (length fromrange) (length torange))
3733 (error "ses-select: Ranges not same length"))
3735 (dolist (x fromrange)
3736 (if (equal test (symbol-value x))
3737 (push (car torange) result))
3738 (setq torange (cdr torange)))
3739 (cons 'list result)))
3741 ;;All standard formulas are safe
3742 (dolist (x '(ses-cell-value ses-range ses-delete-blanks ses+ ses-average
3744 (put x 'side-effect-free t))
3747 ;;----------------------------------------------------------------------------
3748 ;; Standard print functions
3749 ;;----------------------------------------------------------------------------
3751 ;; These functions use the variables 'row' and 'col' that are dynamically bound
3752 ;; by ses-print-cell. We define these variables at compile-time to make the
3757 (defun ses-center (value &optional span fill)
3758 "Print VALUE, centered within column.
3759 FILL is the fill character for centering (default = space).
3760 SPAN indicates how many additional rightward columns to include
3761 in width (default = 0)."
3762 (let ((printer (or (ses-col-printer col) ses--default-printer))
3763 (width (ses-col-width col))
3765 (or fill (setq fill ?\s))
3766 (or span (setq span 0))
3767 (setq value (ses-call-printer printer value))
3769 (setq width (+ width 1 (ses-col-width (+ col span (- x))))))
3770 ;; Set column width.
3771 (setq width (- width (string-width value)))
3773 value ; Too large for field, anyway.
3774 (setq half (make-string (/ width 2) fill))
3775 (concat half value half
3776 (if (> (% width 2) 0) (char-to-string fill))))))
3778 (defun ses-center-span (value &optional fill)
3779 "Print VALUE, centered within the span that starts in the current column
3780 and continues until the next nonblank column.
3781 FILL specifies the fill character (default = space)."
3782 (let ((end (1+ col)))
3783 (while (and (< end ses--numcols)
3784 (memq (ses-cell-value row end) '(nil *skip*)))
3785 (setq end (1+ end)))
3786 (ses-center value (- end col 1) fill)))
3788 (defun ses-dashfill (value &optional span)
3789 "Print VALUE centered using dashes.
3790 SPAN indicates how many rightward columns to include in width (default = 0)."
3791 (ses-center value span ?-))
3793 (defun ses-dashfill-span (value)
3794 "Print VALUE, centered using dashes within the span that starts in the
3795 current column and continues until the next nonblank column."
3796 (ses-center-span value ?-))
3798 (defun ses-tildefill-span (value)
3799 "Print VALUE, centered using tildes within the span that starts in the
3800 current column and continues until the next nonblank column."
3801 (ses-center-span value ?~))
3803 (defun ses-unsafe (_value)
3804 "Substitute for an unsafe formula or printer."
3805 (error "Unsafe formula or printer"))
3807 ;;All standard printers are safe, including ses-unsafe!
3808 (dolist (x (cons 'ses-unsafe ses-standard-printer-functions))
3809 (put x 'side-effect-free t))
3811 (defun ses-unload-function ()
3812 "Unload the Simple Emacs Spreadsheet."
3813 (advice-remove 'yank #'ses--advice-yank)
3814 (advice-remove 'copy-region-as-kill #'ses--advice-copy-region-as-kill)
3815 ;; Continue standard unloading.
3820 ;;; ses.el ends here