| blob | bcf8bdb6368a5f083ddb7cf1b2284121a76df61b |
1 ;;; ses.el -- Simple Emacs Spreadsheet -*- lexical-binding:t -*-
3 ;; Copyright (C) 2002-2018 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 <https://www.gnu.org/licenses/>.
24 ;;; Commentary:
26 ;;; To-do list:
28 ;; * M-w should deactivate the mark.
29 ;; * offer some way to use absolute cell addressing.
30 ;; * Maybe some way to copy a reference to a cell's formula rather than the
31 ;; formula itself.
32 ;; * split (catch 'cycle ...) call back into one or more functions
33 ;; * Use $ or … for truncated fields
34 ;; * M-t to transpose 2 columns.
35 ;; * M-d should kill the cell under point.
36 ;; * C-t to transpose 2 rows.
37 ;; * C-k and M-k should be ses-kill-row and ses-kill-column.
38 ;; * C-o should insert the row below point rather than above?
39 ;; * rows inserted with C-o should inherit formulas from surrounding rows.
40 ;; * Add command to make a range of columns be temporarily invisible.
41 ;; * Allow paste of one cell to a range of cells -- copy formula to each.
42 ;; * Do something about control characters & octal codes in cell print
43 ;; areas. Use string-width?
44 ;; * Input validation functions. How specified?
45 ;; * Faces (colors & styles) in print cells.
46 ;; * Move a column by dragging its letter in the header line.
47 ;; * Left-margin column for row number.
48 ;; * Move a row by dragging its number in the left-margin.
50 ;;; Cycle detection
52 ;; Cycles used to be detected by stationarity of ses--deferred-recalc. This was
53 ;; working fine in most cases, however failed in some cases of several path
54 ;; racing together.
55 ;;
56 ;; The current algorithm is based on Dijkstra's algorithm. The cycle length is
57 ;; stored in some cell property. In order not to reset in all cells such
58 ;; property at each update, the cycle length is stored in this property along
59 ;; with some update attempt id that is incremented at each update. The current
60 ;; update id is ses--Dijkstra-attempt-nb. In case there is a cycle the cycle
61 ;; length diverge to infinite so it will exceed ses--Dijkstra-weight-bound at
62 ;; some point of time that allows detection. Otherwise it converges to the
63 ;; longest path length in the update tree.
66 ;;; Code:
73 ;;----------------------------------------------------------------------------
74 ;; User-customizable variables
75 ;;----------------------------------------------------------------------------
78 "Simple Emacs Spreadsheet."
86 "Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)."
91 "Initial width of columns in a new spreadsheet."
96 "Initial default printer for a new spreadsheet."
100 function))
103 "Things to do after entering a value into a cell.
104 An abnormal hook that usually runs a cursor-movement function.
105 Each function is called with ARG=1."
111 "Hook functions to be run upon entering SES mode."
116 ;;----------------------------------------------------------------------------
117 ;; Global variables and constants
118 ;;----------------------------------------------------------------------------
127 "Context menu when mouse-3 is used on the header-line in an SES buffer."
134 "\C-c\C-l" ses-recalculate-all
135 "\C-c\C-n" ses-renarrow-buffer
136 "\C-c\C-c" ses-recalculate-cell
137 "\C-c\M-\C-s" ses-sort-column
138 "\C-c\M-\C-h" ses-set-header-row
139 "\C-c\C-t" ses-truncate-cell
140 "\C-c\C-j" ses-jump
141 "\C-c\C-p" ses-read-default-printer
142 "\M-\C-l" ses-reprint-all
150 newmap)
154 "Menu bar menu for SES."
174 "Set globally to what completion table to use depending on type
175 of completion (local printers, cells, etc.). We need to go
176 through a local variable to pass the SES buffer local variable
177 to completing function while the current buffer is the
181 "Calling buffer for SES listing help. Used for listing local
187 "\C-c\C-s" ses-insert-ses-range
190 "\C-h\C-p" ses-list-local-printers
191 "\C-h\C-n" ses-list-named-cells
193 ; dynamically in
194 ; editing
195 ; functions
200 newmap)
203 ;Local keymap for SES print area
206 [tab] ses-forward-or-insert
207 "\C-i" ses-forward-or-insert ; Needed for ses-coverage.el?
208 "\M-o" ses-insert-column
209 "\C-o" ses-insert-row
210 "\C-m" ses-edit-cell
211 "\M-k" ses-delete-column
212 "\M-y" ses-yank-pop
213 "\C-k" ses-delete-row
214 "\C-j" ses-append-row-jump-first-column
215 "\M-h" ses-mark-row
216 "\M-H" ses-mark-column
217 "\C-d" ses-clear-cell-forward
218 "\C-?" ses-clear-cell-backward
219 "(" ses-read-cell
221 "'" ses-read-symbol
222 "=" ses-edit-cell
223 "c" ses-recalculate-cell
224 "j" ses-jump
225 "p" ses-read-cell-printer
226 "t" ses-truncate-cell
227 "w" ses-set-column-width
228 "x" ses-export-keymap
229 "\M-p" ses-read-column-printer))
230 (repl '(;;We'll replace these wherever they appear in the keymap
231 clipboard-kill-region ses-kill-override
232 end-of-line ses-end-of-line
233 kill-line ses-delete-row
234 kill-region ses-kill-override
235 open-line ses-insert-row))
236 (numeric "0123456789.-")
237 (newmap (make-keymap)))
238 ;;Get rid of printables
239 (suppress-keymap newmap t)
240 ;;These keys insert themselves as the beginning of a numeric value
241 (dotimes (x (length numeric))
242 (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell))
243 ;;Override these global functions wherever they're bound
244 (while repl
245 (substitute-key-definition (car repl) (cadr repl) newmap
246 (current-global-map))
247 (setq repl (cddr repl)))
248 ;;Apparently substitute-key-definition doesn't catch this?
249 (define-key newmap [(menu-bar) edit cut] 'ses-kill-override)
250 ;;Define our other local keys
251 (while keys
252 (define-key newmap (car keys) (cadr keys))
253 (setq keys (cddr keys)))
254 newmap))
256 ;;Helptext for ses-mode wants keymap as variable, not function
257 (defconst ses-mode-print-map (symbol-function 'ses-mode-print-map))
259 ;;Key map used for 'x' key.
260 (defalias 'ses-export-keymap
261 (let ((map (make-sparse-keymap "SES export")))
262 (define-key map "T" (cons " tab-formulas" 'ses-export-tsf))
263 (define-key map "t" (cons " tab-values" 'ses-export-tsv))
264 map))
267 "Marker string denoting the boundary between print area and data area.")
269 (defconst ses-initial-global-parameters
270 "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n"
271 "Initial contents for the three-element list at the bottom of the data area.")
273 (defconst ses-initial-global-parameters-re
274 "\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"
275 "Match Global parameters for .")
277 (defconst ses-initial-file-trailer
279 "Initial contents for the file-trailer area at the bottom of the file.")
281 (defconst ses-initial-file-contents
283 ses-print-data-boundary
290 ses-initial-global-parameters
291 ses-initial-file-trailer)
292 "The initial contents of an empty spreadsheet.")
294 (defconst ses-box-prop '(:box (:line-width 2 :style released-button))
295 "Display properties to create a raised box for cells in the header line.")
297 (defconst ses-standard-printer-functions
298 '(ses-center
299 ses-center-span ses-dashfill ses-dashfill-span
300 ses-tildefill-span
301 ses-prin1)
302 "List of print functions to be included in initial history of
303 printer functions. None of these standard-printer functions,
304 except function `ses-prin1', is suitable for use as a column
305 printer or a global-default printer because they invoke the
306 column or default printer and then modify its output.")
309 ;;----------------------------------------------------------------------------
310 ;; Local variables and constants
311 ;;----------------------------------------------------------------------------
313 (eval-and-compile
314 (defconst ses-localvars
315 '(ses--blank-line ses--cells ses--col-printers
316 ses--col-widths ses--curcell ses--curcell-overlay
317 ses--default-printer
318 (ses--local-printer-hashmap . :hashmap)
319 (ses--numlocprn . 0); count of local printers
320 ses--deferred-narrow ses--deferred-recalc
321 ses--deferred-write ses--file-format
322 ses--named-cell-hashmap
323 (ses--header-hscroll . -1) ; Flag for "initial recalc needed"
324 ses--header-row ses--header-string ses--linewidth
325 ses--numcols ses--numrows ses--symbolic-formulas
326 ses--data-marker ses--params-marker (ses--Dijkstra-attempt-nb . 0)
327 ses--Dijkstra-weight-bound
328 ;; This list is useful for clean-up of symbols when an area
329 ;; containing renamed cell is deleted.
330 ses--in-killing-named-cell-list
331 ;; Global variables that we override
332 next-line-add-newlines transient-mark-mode)
333 "Buffer-local variables used by SES."))
335 (defmacro ses--metaprogramming (exp) (declare (debug t)) (eval exp t))
336 (ses--metaprogramming
337 `(progn ,@(mapcar (lambda (x) `(defvar ,(or (car-safe x) x))) ses-localvars)))
339 (defun ses-set-localvars ()
340 "Set buffer-local and initialize some SES variables."
341 (dolist (x ses-localvars)
342 (cond
343 ((symbolp x)
344 (set (make-local-variable x) nil))
345 ((consp x)
346 (cond
347 ((integerp (cdr x))
348 (set (make-local-variable (car x)) (cdr x)))
349 ((eq (cdr x) :hashmap)
350 (set (make-local-variable (car x)) (make-hash-table :test 'eq)))
351 (t (error "Unexpected initializer `%S' in list `ses-localvars' for entry %S"
352 (cdr x) (car x)) ) ))
353 (t (error "Unexpected elements `%S' in list `ses-localvars'" x)))))
355 ;;; This variable is documented as being permitted in file-locals:
356 (put 'ses--symbolic-formulas 'safe-local-variable 'consp)
358 (defconst ses-paramlines-plist
359 '(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3
360 ses--header-row -2 ses--file-format 1 ses--numrows 2
361 ses--numcols 3 ses--numlocprn 4)
363 data area of a spreadsheet.")
365 (defconst ses-paramfmt-plist
366 '(ses--col-widths "(ses-column-widths %S)"
367 ses--col-printers "(ses-column-printers %S)"
368 ses--default-printer "(ses-default-printer %S)"
369 ses--header-row "(ses-header-row %S)"
370 ses--file-format " %S ;SES file-format"
371 ses--numrows " %S ;numrows"
372 ses--numcols " %S ;numcols"
373 ses--numlocprn " %S ;numlocprn")
375 area of a spreadsheet.")
377 ;;
378 ;; "Side-effect variables". They are set in one function, altered in
379 ;; another as a side effect, then read back by the first, as a way of
380 ;; passing back more than one value. These declarations are just to make
381 ;; the compiler happy, and to conform to standard Emacs-Lisp practice (I
382 ;; think the make-local-variable trick above is cleaner).
383 ;;
385 (defvar ses-relocate-return nil
386 "Set by `ses-relocate-formula' and `ses-relocate-range', read by
387 `ses-relocate-all'. Set to `delete' if a cell-reference was deleted from a
388 formula--so the formula needs recalculation. Set to `range' if the size of a
389 `ses-range' was changed--so both the formula's value and list of dependents
390 need to be recalculated.")
392 (defvar ses-call-printer-return nil
393 "Set to t if last cell printer invoked by `ses-call-printer' requested
394 left-justification of the result. Set to error-signal if `ses-call-printer'
395 encountered an error during printing. Otherwise nil.")
397 (defvar ses-start-time nil
398 "Time when current operation started. Used by `ses-time-check' to decide
399 when to emit a progress message.")
402 ;;----------------------------------------------------------------------------
403 ;; Macros
404 ;;----------------------------------------------------------------------------
406 (defmacro ses-get-cell (row col)
407 "Return the cell structure that stores information about cell (ROW,COL)."
408 (declare (debug t))
409 `(aref (aref ses--cells ,row) ,col))
411 (cl-defstruct (ses-cell
412 (:constructor nil)
413 (:constructor ses-make-cell
414 (&optional symbol formula printer references))
415 (:copier nil)
416 ;; This is treated as an 4-elem array in various places.
417 ;; Mostly in ses-set-cell.
418 (:type vector) ;Not named.
419 (:conc-name ses-cell--))
420 symbol formula printer references properties)
422 (cl-defstruct (ses--locprn
423 (:constructor)
424 (:constructor ses-make-local-printer-info
425 (def &optional (compiled (ses-local-printer-compile def))
426 (number ses--numlocprn))))
427 def
428 compiled
429 number
430 local-printer-list)
432 (defmacro ses-cell-symbol (row &optional col)
433 "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value. (0,0) => A1."
434 (declare (debug t))
435 `(ses-cell--symbol ,(if col `(ses-get-cell ,row ,col) row)))
436 (put 'ses-cell-symbol 'safe-function t)
438 (defmacro ses-cell-formula (row &optional col)
439 "From a CELL or a pair (ROW,COL), get the function that computes its value."
440 (declare (debug t))
441 `(ses-cell--formula ,(if col `(ses-get-cell ,row ,col) row)))
443 (defmacro ses-cell-printer (row &optional col)
444 "From a CELL or a pair (ROW,COL), get the function that prints its value."
445 (declare (debug t))
446 `(ses-cell--printer ,(if col `(ses-get-cell ,row ,col) row)))
448 (defmacro ses-cell-references (row &optional col)
449 "From a CELL or a pair (ROW,COL), get the list of symbols for cells whose
450 functions refer to its value."
451 (declare (debug t))
452 `(ses-cell--references ,(if col `(ses-get-cell ,row ,col) row)))
454 (defmacro ses-sym-rowcol (sym)
455 "From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0). Result
456 is nil if SYM is not a symbol that names a cell."
457 (declare (debug t))
458 `(let ((rc (and (symbolp ,sym) (get ,sym 'ses-cell))))
459 (if (eq rc :ses-named)
460 (and ses--named-cell-hashmap (gethash ,sym ses--named-cell-hashmap))
461 rc)))
463 (defun ses-cell-p (cell)
464 "Return non-nil if CELL is a cell of current buffer."
465 (and (vectorp cell)
466 (= (length cell) 5)
467 (eq cell (let ((rowcol (ses-sym-rowcol (ses-cell-symbol cell))))
468 (and (consp rowcol)
469 (ses-get-cell (car rowcol) (cdr rowcol)))))))
471 (defun ses-plist-delq (plist prop)
472 "Return PLIST after deleting the first pair (if any) with symbol PROP.
473 This can alter PLIST."
474 (cond
475 ((null plist) nil)
476 ((eq (car plist) prop) (cddr plist))
477 (t (let* ((plist-1 (cdr plist))
478 (plist-2 (cdr plist-1)))
479 (setcdr plist-1 (ses-plist-delq plist-2 prop))
480 plist))))
482 (defvar ses--ses-buffer-list nil "A list of buffers containing a SES spreadsheet.")
484 (defun ses--unbind-cell-name (name)
485 "Make NAME non longer a renamed cell name."
486 (remhash name ses--named-cell-hashmap)
487 (kill-local-variable name)
488 ;; remove symbol property 'ses-cell from symbol NAME, unless this
489 ;; symbol is also a renamed cell name in another SES buffer.
490 (let (used-elsewhere (buffer-list ses--ses-buffer-list) buf)
491 (while buffer-list
492 (setq buf (pop buffer-list))
493 (cond
494 ((eq buf (current-buffer)))
495 ;; This case should not happen, some SES buffer has been
496 ;; killed without the ses-killbuffer-hook being called.
497 ((null (buffer-live-p buf))
498 ;; Silently repair ses--ses-buffer-list
499 (setq ses--ses-buffer-list (delq buf ses--ses-buffer-list)))
500 (t
501 (with-current-buffer buf
502 (when (gethash name ses--named-cell-hashmap)
503 (setq used-elsewhere t
504 buffer-list nil))))))
505 (unless used-elsewhere
506 (setplist name (ses-plist-delq (symbol-plist name) 'ses-cell))) ))
508 (defmacro ses--letref (vars place &rest body)
509 (declare (indent 2) (debug (sexp form &rest body)))
510 (gv-letplace (getter setter) place
511 `(cl-macrolet ((,(nth 0 vars) () ',getter)
512 (,(nth 1 vars) (v) (funcall ',setter v)))
513 ,@body)))
515 (defmacro ses-cell-property (property-name row &optional col)
516 "Get property named PROPERTY-NAME from a CELL or a pair (ROW,COL).
518 When COL is omitted, CELL=ROW is a cell object. When COL is
519 present ROW and COL are the integer coordinates of the cell of
520 interest."
521 (declare (debug t))
522 `(alist-get ,property-name
523 (ses-cell--properties
524 ,(if col `(ses-get-cell ,row ,col) row))))
526 (defmacro ses-cell-property-pop (property-name row &optional col)
527 "From a CELL or a pair (ROW,COL), get and remove the property value of
528 the corresponding cell with name PROPERTY-NAME."
529 `(ses--letref (pget pset)
530 (alist-get ,property-name
531 (ses-cell--properties
532 ,(if col `(ses-get-cell ,row ,col) row))
533 nil t)
534 (prog1 (pget) (pset nil))))
536 (defmacro ses-cell-value (row &optional col)
537 "From a CELL or a pair (ROW,COL), get the current value for that cell."
538 (declare (debug t))
539 `(symbol-value (ses-cell-symbol ,row ,col)))
541 (defmacro ses-col-width (col)
542 "Return the width for column COL."
543 (declare (debug t))
544 `(aref ses--col-widths ,col))
546 (defmacro ses-col-printer (col)
547 "Return the default printer for column COL."
548 (declare (debug t))
549 `(aref ses--col-printers ,col))
551 (defun ses-is-cell-sym-p (sym)
552 "Check whether SYM point at a cell of this spread sheet."
553 (let ((rowcol (get sym 'ses-cell)))
554 (and rowcol
555 (if (eq rowcol :ses-named)
556 (and ses--named-cell-hashmap (gethash sym ses--named-cell-hashmap))
557 (and (< (car rowcol) ses--numrows)
558 (< (cdr rowcol) ses--numcols)
559 (eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym))))))
561 (defun ses--cell (sym value formula printer references)
562 "Load a cell SYM from the spreadsheet file. Does not recompute VALUE from
563 FORMULA, does not reprint using PRINTER, does not check REFERENCES.
564 Safety-checking for FORMULA and PRINTER are deferred until first use."
565 (let ((rowcol (ses-sym-rowcol sym)))
566 (ses-formula-record formula)
567 (ses-printer-record printer)
568 (unless (or formula (eq value '*skip*))
569 (setq formula (macroexp-quote value)))
570 (or (atom formula)
571 (eq safe-functions t)
572 (setq formula `(ses-safe-formula ,formula)))
573 (or (not printer)
574 (stringp printer)
575 (eq safe-functions t)
576 (setq printer `(ses-safe-printer ,printer)))
577 (setf (ses-get-cell (car rowcol) (cdr rowcol))
578 (ses-make-cell sym formula printer references)))
579 (set sym value))
581 (defun ses-local-printer-compile (printer)
582 "Convert local printer function into faster printer
583 definition."
584 (cond
585 ((functionp printer) printer)
586 ((stringp printer)
587 `(lambda (x)
588 (if (null x) ""
589 (format ,printer x))))
590 ((stringp (car-safe printer))
591 `(lambda (x)
592 (if (null x) ""
593 (setq ses-call-printer-return t)
594 (format ,(car printer) x))))
595 (t (error "Invalid printer %S" printer))))
597 (defun ses--local-printer (name def)
598 "Define a local printer with name NAME and definition DEF.
599 Return the printer info."
600 (or
601 (and (symbolp name)
602 (ses-printer-validate def))
603 (error "Invalid local printer definition"))
604 (and (gethash name ses--local-printer-hashmap)
605 (error "Duplicate printer definition %S" name))
606 (add-to-list 'ses-read-printer-history (symbol-name name))
607 (puthash name
608 (ses-make-local-printer-info (ses-safe-printer def))
609 ses--local-printer-hashmap))
611 (defmacro ses-column-widths (widths)
612 "Load the vector of column widths from the spreadsheet file. This is a
613 macro to prevent propagate-on-load viruses."
614 (or (and (vectorp widths) (= (length widths) ses--numcols))
615 (error "Bad column-width vector"))
616 ;;To save time later, we also calculate the total width of each line in the
617 ;;print area (excluding the terminating newline)
618 (setq ses--col-widths widths
619 ses--linewidth (apply #'+ -1 (mapcar #'1+ widths))
621 t)
623 (defmacro ses-column-printers (printers)
624 "Load the vector of column printers from the spreadsheet file and checks
625 them for safety. This is a macro to prevent propagate-on-load viruses."
626 (or (and (vectorp printers) (= (length printers) ses--numcols))
627 (error "Bad column-printers vector"))
628 (dotimes (x ses--numcols)
629 (aset printers x (ses-safe-printer (aref printers x))))
630 (setq ses--col-printers printers)
631 (mapc #'ses-printer-record printers)
632 t)
634 (defmacro ses-default-printer (def)
635 "Load the global default printer from the spreadsheet file and checks it
636 for safety. This is a macro to prevent propagate-on-load viruses."
637 (setq ses--default-printer (ses-safe-printer def))
638 (ses-printer-record def)
639 t)
641 (defmacro ses-header-row (row)
642 "Load the header row from the spreadsheet file and checks it
643 for safety. This is a macro to prevent propagate-on-load viruses."
644 (or (and (wholenump row) (or (zerop ses--numrows) (< row ses--numrows)))
645 (error "Bad header-row"))
646 (setq ses--header-row row)
647 t)
649 (defmacro ses-dorange (curcell &rest body)
650 "Execute BODY repeatedly, with the variables `row' and `col' set to each
651 cell in the range specified by CURCELL. The range is available in the
652 variables `minrow', `maxrow', `mincol', and `maxcol'."
653 (declare (indent defun) (debug (form body)))
654 (let ((cur (make-symbol "cur"))
655 (min (make-symbol "min"))
656 (max (make-symbol "max"))
657 (r (make-symbol "r"))
658 (c (make-symbol "c")))
659 `(let* ((,cur ,curcell)
660 (,min (ses-sym-rowcol (if (consp ,cur) (car ,cur) ,cur)))
661 (,max (ses-sym-rowcol (if (consp ,cur) (cdr ,cur) ,cur))))
662 (let ((minrow (car ,min))
663 (maxrow (car ,max))
664 (mincol (cdr ,min))
665 (maxcol (cdr ,max)))
666 (if (or (> minrow maxrow) (> mincol maxcol))
667 (error "Empty range"))
668 (dotimes (,r (- maxrow minrow -1))
669 (let ((row (+ ,r minrow)))
670 (dotimes (,c (- maxcol mincol -1))
671 (let ((col (+ ,c mincol)))
672 ,@body))))))))
674 ;;Support for coverage testing.
675 (defmacro 1value (form)
676 "For code-coverage testing, indicate that FORM is expected to always have
677 the same value."
678 (declare (debug t))
679 form)
680 (defmacro noreturn (form)
681 "For code-coverage testing, indicate that FORM will always signal an error."
682 (declare (debug t))
683 form)
686 ;;----------------------------------------------------------------------------
687 ;; Utility functions
688 ;;----------------------------------------------------------------------------
690 (defun ses-vector-insert (array idx new)
691 "Create a new vector which is one larger than ARRAY and has NEW inserted
692 before element IDX."
693 (let* ((len (length array))
694 (result (make-vector (1+ len) new)))
695 (dotimes (x len)
696 (aset result
697 (if (< x idx) x (1+ x))
698 (aref array x)))
699 result))
701 ;;Allow ARRAY to be a symbol for use in buffer-undo-list
702 (defun ses-vector-delete (array idx count)
703 "Create a new vector which is a copy of ARRAY with COUNT objects removed
704 starting at element IDX. ARRAY is either a vector or a symbol whose value
705 is a vector--if a symbol, the new vector is assigned as the symbol's value."
706 (let* ((a (if (arrayp array) array (symbol-value array)))
707 (len (- (length a) count))
708 (result (make-vector len nil)))
709 (dotimes (x len)
710 (aset result x (aref a (if (< x idx) x (+ x count)))))
711 (if (symbolp array)
712 (set array result))
713 result))
715 (defun ses-delete-line (count)
716 "Like `kill-line', but no kill ring."
717 (let ((pos (point)))
718 (forward-line count)
719 (delete-region pos (point))))
721 (defun ses-printer-validate (printer)
722 "Signal an error if PRINTER is not a valid SES cell printer."
723 (or (not printer)
724 (stringp printer)
725 ;; printer is a local printer
726 (and (symbolp printer) (gethash printer ses--local-printer-hashmap))
727 (functionp printer)
728 (and (stringp (car-safe printer)) (not (cdr printer)))
729 (error "Invalid printer function %S" printer))
730 printer)
732 (defun ses-printer-record (printer)
733 "Add PRINTER to `ses-read-printer-history' if not already there, after first
734 checking that it is a valid printer function."
735 (ses-printer-validate printer)
736 ;;To speed things up, we avoid calling prin1 for the very common "nil" case.
737 (if printer
738 (add-to-list 'ses-read-printer-history (prin1-to-string printer))))
740 (defun ses-formula-record (formula)
742 for this spreadsheet."
743 (when (and (eq (car-safe formula) 'quote)
744 (symbolp (cadr formula)))
745 (add-to-list 'ses--symbolic-formulas
746 (list (symbol-name (cadr formula))))))
748 (defun ses-column-letter (col)
749 "Return the alphabetic name of column number COL.
750 0-25 become A-Z; 26-701 become AA-ZZ, and so on."
751 (let ((units (char-to-string (+ ?A (% col 26)))))
752 (if (< col 26)
753 units
754 (concat (ses-column-letter (1- (/ col 26))) units))))
756 (defun ses-create-cell-symbol (row col)
757 "Produce a symbol that names the cell (ROW,COL). (0,0) => A1."
758 (intern (concat (ses-column-letter col) (number-to-string (1+ row)))))
760 (defun ses-decode-cell-symbol (str)
762 canonical cell name."
763 (let (case-fold-search)
765 (let* ((col-str (match-string-no-properties 1 str))
766 (col 0)
767 (col-base 1)
768 (col-idx (1- (length col-str)))
769 (row (1- (string-to-number
770 (match-string-no-properties 2 str)))))
771 (and (>= row 0)
772 (progn
773 (while
774 (progn
775 (setq col (+ col (* (- (aref col-str col-idx) ?A)
776 col-base))
777 col-base (* col-base 26)
778 col-idx (1- col-idx))
779 (and (>= col-idx 0)
780 (setq col (+ col col-base)))))
781 (cons row col)))))))
783 (defun ses-create-cell-variable-range (minrow maxrow mincol maxcol)
784 "Create buffer-local variables for cells. This is undoable."
785 (push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
786 buffer-undo-list)
787 (let (sym xrow xcol)
788 (dotimes (row (1+ (- maxrow minrow)))
789 (dotimes (col (1+ (- maxcol mincol)))
790 (setq xrow (+ row minrow)
791 xcol (+ col mincol)
792 sym (ses-create-cell-symbol xrow xcol))
793 (put sym 'ses-cell (cons xrow xcol))
794 (make-local-variable sym)))))
796 (defun ses-create-cell-variable (sym row col)
797 "Create a buffer-local variable `SYM' for cell at position (ROW, COL).
799 SYM is the symbol for that variable, ROW and COL are integers for
800 row and column of the cell, with numbering starting from 0.
802 Return nil in case of failure."
803 (unless (local-variable-p sym)
804 (make-local-variable sym)
806 (put sym 'ses-cell (cons row col))
807 (put sym 'ses-cell :ses-named)
808 (setq ses--named-cell-hashmap (or ses--named-cell-hashmap (make-hash-table :test 'eq)))
809 (puthash sym (cons row col) ses--named-cell-hashmap))))
811 ;; We do not delete the ses-cell properties for the cell-variables, in
812 ;; case a formula that refers to this cell is in the kill-ring and is
813 ;; later pasted back in.
814 (defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol)
815 "Destroy buffer-local variables for cells. This is undoable."
816 (let (sym)
817 (dotimes (row (1+ (- maxrow minrow)))
818 (dotimes (col (1+ (- maxcol mincol)))
819 (let ((xrow (+ row minrow)) (xcol (+ col mincol)))
820 (setq sym (if (and (< xrow ses--numrows) (< xcol ses--numcols))
821 (ses-cell-symbol xrow xcol)
822 (ses-create-cell-symbol xrow xcol))))
823 (if (boundp sym)
824 (push `(apply ses-set-with-undo ,sym ,(symbol-value sym))
825 buffer-undo-list))
826 (kill-local-variable sym))))
827 (push `(apply ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
828 buffer-undo-list))
830 (defun ses-reset-header-string ()
831 "Flag the header string for update. Upon undo, the header string will be
832 updated again."
833 (push '(apply ses-reset-header-string) buffer-undo-list)
834 (setq ses--header-hscroll -1))
836 ;;Split this code off into a function to avoid coverage-testing difficulties
837 (defmacro ses--time-check (format &rest args)
838 "If `ses-start-time' is more than a second ago, call `message' with FORMAT
839 and ARGS and reset `ses-start-time' to the current time."
840 `(when (> (- (float-time) ses-start-time) 1.0)
841 (message ,format ,@args)
842 (setq ses-start-time (float-time))))
845 ;;----------------------------------------------------------------------------
846 ;; The cells
847 ;;----------------------------------------------------------------------------
849 (defmacro ses-set-cell (row col field val)
850 "Install VAL as the contents for field FIELD (named by a quoted symbol) of
851 cell (ROW,COL). This is undoable. The cell's data will be updated through
852 `post-command-hook'."
853 `(let ((row ,row)
854 (col ,col)
855 (val ,val))
856 (let* ((cell (ses-get-cell row col))
857 (change
858 ,(let ((field (progn (cl-assert (eq (car field) 'quote))
859 (cadr field))))
860 (if (eq field 'value)
861 `(ses-set-with-undo (ses-cell-symbol cell) val)
862 ;; (let* ((slots (get 'ses-cell 'cl-struct-slots))
863 ;; (slot (or (assq field slots)
864 ;; (error "Unknown field %S" field)))
865 ;; (idx (- (length slots)
866 ;; (length (memq slot slots)))))
867 ;; `(ses-aset-with-undo cell ,idx val))
868 (let ((getter (intern-soft (format "ses-cell--%s" field))))
869 `(ses-setter-with-undo
870 (eval-when-compile
871 (cons #',getter
872 (lambda (newval cell)
873 (setf (,getter cell) newval))))
874 val cell))))))
875 (if change
876 (add-to-list 'ses--deferred-write (cons row col))))
877 nil)) ; Make coverage-tester happy.
879 (defun ses-cell-set-formula (row col formula)
880 "Store a new formula for (ROW . COL) and enqueue the cell for
881 recalculation via `post-command-hook'. Updates the reference lists for the
882 cells that this cell refers to. Does not update cell value or reprint the
883 cell. To avoid inconsistencies, this function is not interruptible, which
884 means Emacs will crash if FORMULA contains a circular list."
885 (let* ((cell (ses-get-cell row col))
886 (old (ses-cell-formula cell)))
887 (let ((sym (ses-cell-symbol cell))
888 (oldref (ses-formula-references old))
889 (newref (ses-formula-references formula))
890 (inhibit-quit t)
891 not-a-cell-ref-list
892 x xrow xcol)
893 (cl-pushnew sym ses--deferred-recalc)
894 ;;Delete old references from this cell. Skip the ones that are also
895 ;;in the new list.
896 (dolist (ref oldref)
897 (unless (memq ref newref)
898 ;; because we do not cancel edit when the user provides a
899 ;; false reference in it, then we need to check that ref
900 ;; points to a cell that is within the spreadsheet.
901 (setq x (ses-sym-rowcol ref))
902 (and x
903 (< (setq xrow (car x)) ses--numrows)
904 (< (setq xcol (cdr x)) ses--numcols)
905 (ses-set-cell xrow xcol 'references
906 (delq sym (ses-cell-references xrow xcol))))))
907 ;;Add new ones. Skip ones left over from old list
908 (dolist (ref newref)
909 (setq x (ses-sym-rowcol ref))
910 ;;Do not trust the user, the reference may be outside the spreadsheet
911 (if (and
912 x
913 (< (setq xrow (car x)) ses--numrows)
914 (< (setq xcol (cdr x)) ses--numcols))
915 (progn
916 (setq x (ses-cell-references xrow xcol))
917 (or (memq sym x)
918 (ses-set-cell xrow xcol 'references (cons sym x))))
919 (cl-pushnew ref not-a-cell-ref-list)))
920 (ses-formula-record formula)
921 (ses-set-cell row col 'formula formula)
922 (and not-a-cell-ref-list
923 (error "Found in formula cells not in spreadsheet: %S" not-a-cell-ref-list)))))
926 (defun ses-repair-cell-reference-all ()
927 "Repair cell reference and warn if there was some reference corruption."
928 (interactive "*")
929 (let (errors)
930 ;; Step 1, reset :ses-repair-reference cell property in the whole sheet.
931 (dotimes (row ses--numrows)
932 (dotimes (col ses--numcols)
933 (let ((references (ses-cell-property-pop :ses-repair-reference
934 row col)))
935 (when references
936 (push (list (ses-cell-symbol row col)
937 :corrupt-property
938 references)
939 errors)))))
941 ;; Step 2, build new.
942 (dotimes (row ses--numrows)
943 (dotimes (col ses--numcols)
944 (let* ((cell (ses-get-cell row col))
945 (sym (ses-cell-symbol cell))
946 (formula (ses-cell-formula cell))
947 (new-ref (ses-formula-references formula)))
948 (dolist (ref new-ref)
949 (let ((rowcol (ses-sym-rowcol ref)))
950 (cl-pushnew sym (ses-cell-property :ses-repair-reference
951 (car rowcol)
952 (cdr rowcol))))))))
954 ;; Step 3, overwrite with check.
955 (dotimes (row ses--numrows)
956 (dotimes (col ses--numcols)
957 (let* ((cell (ses-get-cell row col))
958 (irrelevant (ses-cell-references cell))
959 (new-ref (ses-cell-property-pop :ses-repair-reference cell))
960 missing)
961 (dolist (ref new-ref)
962 (if (memq ref irrelevant)
963 (setq irrelevant (delq ref irrelevant))
964 (push ref missing)))
965 (ses-set-cell row col 'references new-ref)
966 (when (or missing irrelevant)
967 (push `( ,(ses-cell-symbol cell)
968 ,@(and missing (list :missing missing))
969 ,@(and irrelevant (list :irrelevant irrelevant)))
970 errors)))))
971 (if errors
972 (warn "----------------------------------------------------------------
973 Some references were corrupted.
975 The following is a list where each element ELT is such
976 that (car ELT) is the reference of cell CELL with corruption,
977 and (cdr ELT) is a property list where
979 * property `:corrupt-property' means that
980 property `:ses-repair-reference' of cell CELL was initially non
981 nil,
983 * property `:missing' is a list of missing references
985 * property `:irrelevant' is a list of non needed references
987 %S" errors)
988 (message "No reference corruption found"))))
990 (defun ses-calculate-cell (row col force)
991 "Calculate and print the value for cell (ROW,COL) using the cell's formula
992 function and print functions, if any. Result is nil for normal operation, or
993 the error signal if the formula or print function failed. The old value is
994 left unchanged if it was *skip* and the new value is nil.
995 Any cells that depend on this cell are queued for update after the end of
996 processing for the current keystroke, unless the new value is the same as
997 the old and FORCE is nil."
998 (let ((cell (ses-get-cell row col))
999 cycle-error formula-error printer-error)
1000 (let ((oldval (ses-cell-value cell))
1001 (formula (ses-cell-formula cell))
1002 newval
1003 this-cell-Dijkstra-attempt+1)
1004 (when (eq (car-safe formula) 'ses-safe-formula)
1005 (setq formula (ses-safe-formula (cadr formula)))
1006 (ses-set-cell row col 'formula formula))
1007 (condition-case sig
1008 (setq newval (eval formula t))
1009 (error
1010 ;; Variable `sig' can't be nil.
1011 (nconc sig (list (ses-cell-symbol cell)))
1012 (setq formula-error sig
1013 newval '*error*)))
1014 (if (and (not newval) (eq oldval '*skip*))
1015 ;; Don't lose the *skip* --- previous field spans this one.
1016 (setq newval '*skip*))
1017 (catch 'cycle
1018 (when (or force (not (eq newval oldval)))
1019 (cl-pushnew (cons row col) ses--deferred-write :test #'equal) ; In case force=t.
1020 (ses--letref (pget pset)
1021 (ses-cell-property :ses-Dijkstra-attempt cell)
1022 (let ((this-cell-Dijkstra-attempt (pget)))
1023 (if (null this-cell-Dijkstra-attempt)
1024 (pset
1025 (setq this-cell-Dijkstra-attempt
1026 (cons ses--Dijkstra-attempt-nb 0)))
1027 (unless (= ses--Dijkstra-attempt-nb
1028 (car this-cell-Dijkstra-attempt))
1029 (setcar this-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb)
1030 (setcdr this-cell-Dijkstra-attempt 0)))
1031 (setq this-cell-Dijkstra-attempt+1
1032 (1+ (cdr this-cell-Dijkstra-attempt)))))
1033 (ses-set-cell row col 'value newval)
1034 (dolist (ref (ses-cell-references cell))
1035 (cl-pushnew ref ses--deferred-recalc)
1036 (ses--letref (pget pset)
1037 (let ((ref-rowcol (ses-sym-rowcol ref)))
1038 (ses-cell-property
1039 :ses-Dijkstra-attempt
1040 (car ref-rowcol) (cdr ref-rowcol)))
1041 (let ((ref-cell-Dijkstra-attempt (pget)))
1043 (if (null ref-cell-Dijkstra-attempt)
1044 (pset
1045 (setq ref-cell-Dijkstra-attempt
1046 (cons ses--Dijkstra-attempt-nb
1047 this-cell-Dijkstra-attempt+1)))
1048 (if (= (car ref-cell-Dijkstra-attempt) ses--Dijkstra-attempt-nb)
1049 (setcdr ref-cell-Dijkstra-attempt
1050 (max (cdr ref-cell-Dijkstra-attempt)
1051 this-cell-Dijkstra-attempt+1))
1052 (setcar ref-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb)
1053 (setcdr ref-cell-Dijkstra-attempt
1054 this-cell-Dijkstra-attempt+1)))))
1056 (when (> this-cell-Dijkstra-attempt+1 ses--Dijkstra-weight-bound)
1057 ;; Update print of this cell.
1058 (throw 'cycle (setq formula-error
1059 `(error ,(format "Found cycle on cells %S"
1060 (ses-cell-symbol cell)))
1061 cycle-error formula-error)))))))
1062 (setq printer-error (ses-print-cell row col))
1063 (or
1064 (and cycle-error
1065 (error (error-message-string cycle-error)))
1066 formula-error printer-error)))
1068 (defun ses-clear-cell (row col)
1069 "Delete formula and printer for cell (ROW,COL)."
1070 (ses-set-cell row col 'printer nil)
1071 (ses-cell-set-formula row col nil))
1073 (defcustom ses-self-reference-early-detection nil
1074 "True if cycle detection is early for cells that refer to themselves."
1075 :version "24.1"
1076 :type 'boolean
1077 :group 'ses)
1079 (defun ses-update-cells (list &optional force)
1080 "Recalculate cells in LIST, checking for dependency loops. Prints
1081 progress messages every second. Dependent cells are not recalculated
1082 if the cell's value is unchanged and FORCE is nil."
1083 (let ((ses--deferred-recalc list)
1084 (nextlist list)
1085 (pos (point))
1086 curlist prevlist this-sym this-rowcol formula)
1087 (with-temp-message " "
1088 (while ses--deferred-recalc
1089 ;; In each loop, recalculate cells that refer only to other cells that
1090 ;; have already been recalculated or aren't in the recalculation region.
1091 ;; Repeat until all cells have been processed or until the set of cells
1092 ;; being worked on stops changing.
1093 (if prevlist
1094 (message "Recalculating... (%d cells left)"
1095 (length ses--deferred-recalc)))
1096 (setq curlist ses--deferred-recalc
1097 ses--deferred-recalc nil
1098 prevlist nextlist)
1099 (while curlist
1100 ;; this-sym has to be popped from curlist *BEFORE* the check, and not
1101 ;; after because of the case of cells referring to themselves.
1102 (setq this-sym (pop curlist)
1103 this-rowcol (ses-sym-rowcol this-sym)
1104 formula (ses-cell-formula (car this-rowcol)
1105 (cdr this-rowcol)))
1106 (or (catch 'ref
1107 (dolist (ref (ses-formula-references formula))
1108 (if (and ses-self-reference-early-detection (eq ref this-sym))
1109 (error "Cycle found: cell %S is self-referring" this-sym)
1110 (when (or (memq ref curlist)
1111 (memq ref ses--deferred-recalc))
1112 ;; This cell refers to another that isn't done yet
1113 (cl-pushnew this-sym ses--deferred-recalc :test #'equal)
1114 (throw 'ref t)))))
1115 ;; ses-update-cells is called from post-command-hook, so
1116 ;; inhibit-quit is implicitly bound to t.
1117 (when quit-flag
1118 ;; Abort the recalculation. User will probably undo now.
1119 (error "Quit"))
1120 (ses-calculate-cell (car this-rowcol) (cdr this-rowcol) force)))
1121 (dolist (ref ses--deferred-recalc)
1122 (cl-pushnew ref nextlist :test #'equal)))
1123 (when ses--deferred-recalc
1124 ;; Just couldn't finish these.
1125 (dolist (x ses--deferred-recalc)
1126 (let ((this-rowcol (ses-sym-rowcol x)))
1127 (ses-set-cell (car this-rowcol) (cdr this-rowcol) 'value '*error*)
1128 (1value (ses-print-cell (car this-rowcol) (cdr this-rowcol)))))
1129 (error "Circular references: %s" ses--deferred-recalc))
1130 (message " "))
1131 ;; Can't use save-excursion here: if the cell under point is updated,
1132 ;; save-excursion's marker will move past the cell.
1133 (goto-char pos)))
1136 ;;----------------------------------------------------------------------------
1137 ;; The print area
1138 ;;----------------------------------------------------------------------------
1140 (defun ses-in-print-area ()
1141 "Return t if point is in print area of spreadsheet."
1142 (<= (point) ses--data-marker))
1144 ;; We turn off point-motion-hooks and explicitly position the cursor, in case
1145 ;; the intangible properties have gotten screwed up (e.g., when ses-goto-print
1146 ;; is called during a recursive ses-print-cell).
1147 (defun ses-goto-print (row col)
1148 "Move point to print area for cell (ROW,COL)."
1149 (let ((n 0))
1150 (goto-char (point-min))
1151 (forward-line row)
1152 ;; Calculate column position.
1153 (dotimes (c col)
1154 (setq n (+ n (ses-col-width c) 1)))
1155 ;; Move to the position.
1156 (and (> n (move-to-column n))
1157 (eolp)
1158 ;; Move point to the bol of next line (for TAB at the last cell).
1159 (forward-char))))
1161 (defun ses--cell-at-pos (pos &optional object)
1162 (or (get-text-property pos 'cursor-intangible object)
1163 ;; (when (> pos (if object 0 (point-min)))
1164 ;; (get-text-property (1- pos) 'cursor-intangible object))
1165 ))
1167 (defun ses--curcell (&optional pos)
1168 "Return the current cell symbol, or a cons (BEG,END) for a
1169 region, or nil if cursor is not at a cell."
1170 (unless pos (setq pos (point)))
1171 (if (or (not mark-active)
1172 deactivate-mark
1173 (= pos (mark t)))
1174 ;; Single cell.
1175 (ses--cell-at-pos pos)
1176 ;; Range.
1177 (let* ((re (max pos (mark t)))
1178 (bcell (ses--cell-at-pos (min pos (mark t))))
1179 (ecell (ses--cell-at-pos (1- re))))
1180 (when (= re ses--data-marker)
1181 ;; Correct for overflow.
1182 (setq ecell (ses--cell-at-pos (- (region-end) 2))))
1183 (if (and bcell ecell)
1184 (cons bcell ecell)
1185 nil))))
1187 (defun ses-set-curcell ()
1188 "Set `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a
1189 region, or nil if cursor is not at a cell."
1190 (setq ses--curcell (ses--curcell))
1191 nil)
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 (ses-set-curcell); fix bug#21054
1199 (cond
1200 ((not ses--curcell)
1201 (or (memq 'end args)
1202 (error "Not at cell")))
1203 ((consp ses--curcell)
1204 (or (memq 'range args)
1205 (memq 'needrange args)
1206 (error "Can't use a range")))
1207 ((memq 'needrange args)
1208 (error "Need a range"))))
1210 (defvar ses--row)
1211 (defvar ses--col)
1213 (defun ses-print-cell (row col)
1214 "Format and print the value of cell (ROW,COL) to the print area.
1215 Use the cell's printer function. If the cell's new print form is too wide,
1216 it will spill over into the following cell, but will not run off the end of the
1217 row or overwrite the next non-nil field. Result is nil for normal operation,
1218 or the error signal if the printer function failed and the cell was formatted
1220 preceding cell has spilled over."
1221 (catch 'ses-print-cell
1222 (let* ((cell (ses-get-cell row col))
1223 (value (ses-cell-value cell))
1224 (printer (ses-cell-printer cell))
1225 (maxcol (1+ col))
1226 text sig startpos x)
1227 ;; Create the string to print.
1228 (cond
1229 ((eq value '*skip*)
1230 ;; Don't print anything.
1231 (throw 'ses-print-cell nil))
1232 ((eq value '*error*)
1233 (setq text (make-string (ses-col-width col) ?#)))
1234 (t
1235 ;; Deferred safety-check on printer.
1236 (if (eq (car-safe printer) 'ses-safe-printer)
1237 (ses-set-cell row col 'printer
1238 (setq printer (ses-safe-printer (cadr printer)))))
1239 ;; Print the value.
1240 (setq text
1241 (let ((ses--row row)
1242 (ses--col col))
1243 (ses-call-printer (or printer
1244 (ses-col-printer col)
1245 ses--default-printer)
1246 value)))
1247 (if (consp ses-call-printer-return)
1248 ;; Printer returned an error.
1249 (setq sig ses-call-printer-return))))
1250 ;; Adjust print width to match column width.
1251 (let ((width (ses-col-width col))
1252 (len (string-width text)))
1253 (cond
1254 ((< len width)
1255 ;; Fill field to length with spaces.
1256 (setq len (make-string (- width len) ?\s)
1257 text (if (eq ses-call-printer-return t)
1258 (concat text len)
1259 (concat len text))))
1260 ((> len width)
1261 ;; Spill over into following cells, if possible.
1262 (let ((maxwidth width))
1263 (while (and (> len maxwidth)
1264 (< maxcol ses--numcols)
1265 (or (not (setq x (ses-cell-value row maxcol)))
1266 (eq x '*skip*)))
1267 (unless x
1268 ;; Set this cell to '*skip* so it won't overwrite our spillover.
1269 (ses-set-cell row maxcol 'value '*skip*))
1270 (setq maxwidth (+ maxwidth (ses-col-width maxcol) 1)
1271 maxcol (1+ maxcol)))
1272 (if (<= len maxwidth)
1273 ;; Fill to complete width of all the fields spanned.
1274 (setq text (concat text (make-string (- maxwidth len) ?\s)))
1275 ;; Not enough room to end of line or next non-nil field. Truncate
1276 ;; if string or decimal; otherwise fill with error indicator.
1277 (setq sig `(error "Too wide" ,text))
1278 (cond
1279 ((stringp value)
1280 (setq text (truncate-string-to-width text maxwidth 0 ?\s)))
1281 ((and (numberp value)
1283 (>= 0 (setq width
1284 (- len maxwidth
1285 (- (match-end 0) (match-beginning 0))))))
1286 ;; Turn 6.6666666666e+49 into 6.66e+49. Rounding is too hard!
1287 (setq text (concat (substring text
1288 0
1289 (- (match-beginning 0) width))
1290 (substring text (match-end 0)))))
1291 (t
1292 (setq text (make-string maxwidth ?#)))))))))
1293 ;; Substitute question marks for tabs and newlines. Newlines are used as
1294 ;; row-separators; tabs could confuse the reimport logic.
1296 (ses-goto-print row col)
1297 (setq startpos (point))
1298 ;; Install the printed result. This is not interruptible.
1299 (let ((inhibit-read-only t)
1300 (inhibit-quit t))
1301 (delete-region (point) (progn
1302 (move-to-column (+ (current-column)
1303 (string-width text)))
1304 (1+ (point))))
1305 ;; We use concat instead of inserting separate strings in order to
1306 ;; reduce the number of cells in the undo list.
1308 ;; We use set-text-properties to prevent a wacky print function from
1309 ;; inserting rogue properties, and to ensure that the keymap property is
1310 ;; inherited (is it a bug that only unpropertized strings actually
1311 ;; inherit from surrounding text?)
1312 (set-text-properties 0 (length x) nil x)
1313 (insert-and-inherit x)
1314 (put-text-property startpos (point) 'cursor-intangible
1315 (ses-cell-symbol cell))
1316 (when (and (zerop row) (zerop col))
1317 ;; Reconstruct special beginning-of-buffer attributes.
1318 (put-text-property (point-min) (point) 'keymap 'ses-mode-print-map)
1319 (put-text-property (point-min) (point) 'read-only 'ses)
1320 (put-text-property (point-min) (1+ (point-min))
1321 ;; `cursor-intangible' shouldn't be sticky at BOB.
1322 'front-sticky '(read-only keymap))))
1323 (if (= row (1- ses--header-row))
1324 ;; This line is part of the header --- force recalc.
1325 (ses-reset-header-string))
1326 ;; If this cell (or a preceding one on the line) previously spilled over
1327 ;; and has gotten shorter, redraw following cells on line recursively.
1328 (when (and (< maxcol ses--numcols)
1329 (eq (ses-cell-value row maxcol) '*skip*))
1330 (ses-set-cell row maxcol 'value nil)
1331 (ses-print-cell row maxcol))
1332 ;; Return to start of cell.
1333 (goto-char startpos)
1334 sig)))
1336 (defun ses-call-printer (printer &optional value)
1337 "Invoke PRINTER (a string or parenthesized string or function-symbol or
1338 lambda of one argument) on VALUE. Result is the printed cell as a string.
1339 The variable `ses-call-printer-return' is set to t if the printer used
1340 parenthesis to request left-justification, or the error-signal if the
1342 (setq ses-call-printer-return nil)
1343 (condition-case signal
1344 (cond
1345 ((stringp printer)
1346 (if value
1347 (format printer value)
1348 ""))
1349 ((stringp (car-safe printer))
1350 (setq ses-call-printer-return t)
1351 (if value
1352 (format (car printer) value)
1353 ""))
1354 (t
1355 (setq value
1356 (funcall
1357 (or (and (symbolp printer)
1358 (let ((locprn (gethash printer
1359 ses--local-printer-hashmap)))
1360 (and locprn
1361 (ses--locprn-compiled locprn))))
1362 printer)
1363 value))
1364 (if (stringp value)
1365 value
1366 (or (stringp (car-safe value))
1368 (setq ses-call-printer-return t)
1369 (car value))))
1370 (error
1371 (setq ses-call-printer-return signal)
1372 (ses-prin1 value))))
1374 (defun ses-adjust-print-width (col change)
1375 "Insert CHANGE spaces in front of column COL, or at end of line if
1376 COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind
1377 `inhibit-quit' to t."
1378 (let ((inhibit-read-only t)
1379 (blank (if (> change 0) (make-string change ?\s)))
1380 (at-end (= col ses--numcols)))
1381 (ses-set-with-undo 'ses--linewidth (+ ses--linewidth change))
1382 ;; ses-set-with-undo always returns t for strings.
1383 (1value (ses-set-with-undo 'ses--blank-line
1385 (dotimes (row ses--numrows)
1386 (ses-goto-print row col)
1387 (when at-end
1388 ;; Insert new columns before newline.
1389 (backward-char 1))
1390 (if blank
1391 (insert blank)
1392 (delete-char (- change))))))
1394 (defun ses-print-cell-new-width (row col)
1395 "Same as `ses-print-cell', except if the cell's value is *skip*,
1396 the preceding nonskipped cell is reprinted. This function is used
1397 when the width of cell (ROW,COL) has changed."
1398 (if (not (eq (ses-cell-value row col) '*skip*))
1399 (ses-print-cell row col)
1400 ;;Cell was skipped over - reprint previous
1401 (ses-goto-print row col)
1402 (backward-char 1)
1403 (let ((rowcol (ses-sym-rowcol (ses--cell-at-pos (point)))))
1404 (ses-print-cell (car rowcol) (cdr rowcol)))))
1407 ;;----------------------------------------------------------------------------
1408 ;; The data area
1409 ;;----------------------------------------------------------------------------
1411 (defun ses-widen ()
1412 "Turn off narrowing, to be reenabled at end of command loop."
1413 (if (buffer-narrowed-p)
1414 (setq ses--deferred-narrow t))
1415 (widen))
1417 (defun ses-goto-data (def &optional col)
1418 "Move point to data area for (DEF,COL). If DEF is a row
1419 number, COL is the column number for a data cell -- otherwise DEF
1420 is one of the symbols ses--col-widths, ses--col-printers,
1421 ses--default-printer, ses--numrows, or ses--numcols."
1422 (ses-widen)
1423 (if col
1424 ;; It's a cell.
1425 (progn
1426 (goto-char ses--data-marker)
1427 (forward-line (+ 1 (* def (1+ ses--numcols)) col)))
1428 ;; Convert def-symbol to offset.
1429 (setq def (plist-get ses-paramlines-plist def))
1430 (or def (signal 'args-out-of-range nil))
1431 (goto-char ses--params-marker)
1432 (forward-line def)))
1434 (defun ses-file-format-extend-parameter-list (new-file-format)
1435 "Extend the global parameters list when file format is updated
1436 from 2 to 3. This happens when local printer function are added
1437 to a sheet that was created with SES version 2. This is not
1438 undoable. Return nil when there was no change, and non nil otherwise."
1439 (save-excursion
1440 (cond
1441 ((and (= ses--file-format 2) (= 3 new-file-format))
1442 (ses-set-parameter 'ses--file-format 3)
1443 (message "Upgrading from SES-2 to SES-3 file format")
1444 (ses-widen)
1445 (goto-char ses--params-marker)
1446 (forward-line (plist-get ses-paramlines-plist 'ses--numlocprn ))
1447 (insert (format (plist-get ses-paramfmt-plist 'ses--numlocprn)
1448 ses--numlocprn)
1450 t) )))
1452 (defun ses-set-parameter (def value &optional elem)
1453 "Set parameter DEF to VALUE (with undo) and write the value to the data area.
1454 See `ses-goto-data' for meaning of DEF. Newlines in the data are escaped.
1455 If ELEM is specified, it is the array subscript within DEF to be set to VALUE."
1456 (save-excursion
1457 ;; We call ses-goto-data early, using the old values of numrows and numcols
1458 ;; in case one of them is being changed.
1459 (ses-goto-data def)
1460 (let ((inhibit-read-only t)
1461 (fmt (plist-get ses-paramfmt-plist
1462 def))
1463 oldval)
1464 (if elem
1465 (progn
1466 (setq oldval (aref (symbol-value def) elem))
1467 (aset (symbol-value def) elem value))
1468 (setq oldval (symbol-value def))
1469 (set def value))
1470 ;; Special undo since it's outside the narrowed buffer.
1471 (let (buffer-undo-list)
1472 (delete-region (point) (line-end-position))
1473 (insert (format fmt (symbol-value def))))
1474 (push `(apply ses-set-parameter ,def ,oldval ,elem) buffer-undo-list))))
1477 (defun ses-write-cells ()
1478 "Write cells in `ses--deferred-write' from local variables to data area.
1479 Newlines in the data are escaped."
1480 (let* ((inhibit-read-only t)
1481 (print-escape-newlines t)
1482 rowcol row col cell sym formula printer text)
1483 (setq ses-start-time (float-time))
1484 (with-temp-message " "
1485 (save-excursion
1486 (while ses--deferred-write
1487 (ses--time-check "Writing... (%d cells left)"
1488 (length ses--deferred-write))
1489 (setq rowcol (pop ses--deferred-write)
1490 row (car rowcol)
1491 col (cdr rowcol)
1492 cell (ses-get-cell row col)
1493 sym (ses-cell-symbol cell)
1494 formula (ses-cell-formula cell)
1495 printer (ses-cell-printer cell))
1496 (if (eq (car-safe formula) 'ses-safe-formula)
1497 (setq formula (cadr formula)))
1498 (if (eq (car-safe printer) 'ses-safe-printer)
1499 (setq printer (cadr printer)))
1500 (setq text (prin1-to-string
1501 ;; We could shorten it to (ses-cell SYM VAL) when
1502 ;; the other parameters are nil, but in practice most
1503 ;; cells have non-nil `references', so it's
1504 ;; rather pointless.
1505 `(ses-cell ,sym
1506 ,(symbol-value sym)
1507 ,(unless (equal formula (symbol-value sym))
1508 formula)
1509 ,printer
1510 ,(ses-cell-references cell))))
1511 (ses-goto-data row col)
1512 (delete-region (point) (line-end-position))
1513 (insert text)))
1514 (message " "))))
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 (cl-pushnew formula result-so-far :test #'equal)
1529 (if (consp formula)
1530 (cond
1531 ((eq (car formula) 'ses-range)
1532 (dolist (cur
1533 (cdr (funcall 'macroexpand
1534 (list 'ses-range (nth 1 formula)
1535 (nth 2 formula)))))
1536 (cl-pushnew cur result-so-far :test #'equal)))
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))))
1541 (t
1542 ;;Ignore other stuff
1543 ))
1544 ;; other type of atom are ignored
1545 ))
1546 result-so-far)
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))
1553 (col (cdr rowcol)))
1554 (if (or (< row startrow) (< col startcol))
1555 sym
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, unless it is a named cell
1561 (if (eq (get sym 'ses-cell) :ses-named)
1562 sym
1563 ;; otherwise, we create the relocated cell symbol because
1564 ;; ses-cell-symbol gives the old symbols, however since
1565 ;; renamed cell are not relocated we keep the relocated
1566 ;; cell old symbol in this case.
1567 (if (eq (get (setq sym (ses-cell-symbol row col)) 'ses-cell) :ses-named)
1568 sym
1569 (ses-create-cell-symbol row col)))
1570 ;;Delete reference to a deleted cell
1571 nil))))
1573 (defun ses-relocate-formula (formula startrow startcol rowincr colincr)
1574 "Produce a copy of FORMULA where all symbols that refer to cells in row
1575 STARTROW or above, and col STARTCOL or above, are altered by adding ROWINCR
1576 and COLINCR. STARTROW and STARTCOL are 0-based. Example:
1578 => (+ A1 B2 C4)
1579 If ROWINCR or COLINCR is negative, references to cells being deleted are
1580 removed. Example:
1582 => (+ A1 C3)
1583 Sets `ses-relocate-return' to `delete' if cell-references were removed."
1584 (let (rowcol result)
1585 (if (or (atom formula) (eq (car formula) 'quote))
1586 (if (setq rowcol (ses-sym-rowcol formula))
1587 (ses-relocate-symbol formula rowcol
1588 startrow startcol rowincr colincr)
1589 ;; Constants pass through as-is.
1590 formula)
1591 (dolist (cur formula)
1592 (setq rowcol (ses-sym-rowcol cur))
1593 (cond
1594 (rowcol
1595 (setq cur (ses-relocate-symbol cur rowcol
1596 startrow startcol rowincr colincr))
1597 (if cur
1598 (push cur result)
1599 ;; Reference to a deleted cell. Set a flag in ses-relocate-return.
1600 ;; don't change the flag if it's already 'range, since range implies
1601 ;; 'delete.
1602 (unless ses-relocate-return
1603 (setq ses-relocate-return 'delete))))
1604 ((eq (car-safe cur) 'ses-range)
1605 (setq cur (ses-relocate-range cur startrow startcol rowincr colincr))
1606 (if cur
1607 (push cur result)))
1608 ((or (atom cur) (eq (car cur) 'quote))
1609 ;; Constants pass through unchanged.
1610 (push cur result))
1611 (t
1612 ;; Recursively copy and alter subformulas.
1613 (push (ses-relocate-formula cur startrow startcol
1614 rowincr colincr)
1615 result))))
1616 (nreverse result))))
1618 (defun ses-relocate-range (range startrow startcol rowincr colincr)
1619 "Relocate one RANGE, of the form (ses-range MIN MAX). Cells starting
1620 at (STARTROW,STARTCOL) are being shifted by (ROWINCR,COLINCR). Result is the
1621 new range, or nil if the entire range is deleted. If new rows are being added
1622 just beyond the end of a row range, or new columns just beyond a column range,
1623 the new rows/columns will be added to the range. Sets `ses-relocate-return'
1624 if the range was altered."
1625 (let* ((minorig (cadr range))
1626 (minrowcol (ses-sym-rowcol minorig))
1627 (min (ses-relocate-symbol minorig minrowcol
1628 startrow startcol
1629 rowincr colincr))
1630 (maxorig (nth 2 range))
1631 (maxrowcol (ses-sym-rowcol maxorig))
1632 (max (ses-relocate-symbol maxorig maxrowcol
1633 startrow startcol
1634 rowincr colincr))
1635 field)
1636 (cond
1637 ((and (not min) (not max))
1638 (setq range nil)) ; The entire range is deleted.
1639 ((zerop colincr)
1640 ;; Inserting or deleting rows.
1641 (setq field 'car)
1642 (if (not min)
1643 ;; Chopped off beginning of range.
1644 (setq min (ses-create-cell-symbol startrow (cdr minrowcol))
1645 ses-relocate-return 'range))
1646 (if (not max)
1647 (if (> rowincr 0)
1648 ;; Trying to insert a nonexistent row.
1649 (setq max (ses-create-cell-symbol (1- ses--numrows)
1650 (cdr minrowcol)))
1651 ;; End of range is being deleted.
1652 (setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol))
1653 ses-relocate-return 'range))
1654 (and (> rowincr 0)
1655 (= (car maxrowcol) (1- startrow))
1656 (= (cdr minrowcol) (cdr maxrowcol))
1657 ;; Insert after ending row of vertical range --- include it.
1658 (setq max (ses-create-cell-symbol (+ startrow rowincr -1)
1659 (cdr maxrowcol))))))
1660 (t
1661 ;; Inserting or deleting columns.
1662 (setq field 'cdr)
1663 (if (not min)
1664 ;; Chopped off beginning of range.
1665 (setq min (ses-create-cell-symbol (car minrowcol) startcol)
1666 ses-relocate-return 'range))
1667 (if (not max)
1668 (if (> colincr 0)
1669 ;; Trying to insert a nonexistent column.
1670 (setq max (ses-create-cell-symbol (car maxrowcol)
1671 (1- ses--numcols)))
1672 ;; End of range is being deleted.
1673 (setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol))
1674 ses-relocate-return 'range))
1675 (and (> colincr 0)
1676 (= (cdr maxrowcol) (1- startcol))
1677 (= (car minrowcol) (car maxrowcol))
1678 ;; Insert after ending column of horizontal range --- include it.
1679 (setq max (ses-create-cell-symbol (car maxrowcol)
1680 (+ startcol colincr -1)))))))
1681 (when range
1682 (if (/= (- (funcall field maxrowcol)
1683 (funcall field minrowcol))
1684 (- (funcall field (ses-sym-rowcol max))
1685 (funcall field (ses-sym-rowcol min))))
1686 ;; This range has changed size.
1687 (setq ses-relocate-return 'range))
1688 `(ses-range ,min ,max ,@(cl-cdddr range)))))
1690 (defun ses-relocate-all (minrow mincol rowincr colincr)
1691 "Alter all cell values, symbols, formulas, and reference-lists to relocate
1692 the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR
1693 to each symbol."
1694 (let (reform)
1695 (let (mycell newval xrow)
1696 (dotimes-with-progress-reporter
1697 (row ses--numrows) "Relocating formulas..."
1698 (dotimes (col ses--numcols)
1699 (setq ses-relocate-return nil
1700 mycell (ses-get-cell row col)
1701 newval (ses-relocate-formula (ses-cell-formula mycell)
1702 minrow mincol rowincr colincr)
1703 xrow (- row rowincr))
1704 (ses-set-cell row col 'formula newval)
1705 (if (eq ses-relocate-return 'range)
1706 ;; This cell contains a (ses-range X Y) where a cell has been
1707 ;; inserted or deleted in the middle of the range.
1708 (push (cons row col) reform))
1709 (if ses-relocate-return
1710 ;; This cell referred to a cell that's been deleted or is no
1711 ;; longer part of the range. We can't fix that now because
1712 ;; reference lists cells have been partially updated.
1713 (cl-pushnew (ses-create-cell-symbol row col)
1714 ses--deferred-recalc :test #'equal))
1715 (setq newval (ses-relocate-formula (ses-cell-references mycell)
1716 minrow mincol rowincr colincr))
1717 (ses-set-cell row col 'references newval)
1718 (and (>= row minrow) (>= col mincol)
1719 (let ((sym (ses-cell-symbol row col))
1720 (xcol (- col colincr)))
1721 (if (and
1722 sym
1723 (>= xrow 0)
1724 (>= xcol 0)
1725 ;; the following could also be tested as
1726 ;; (null (eq sym (ses-create-cell-symbol xrow xcol)))
1727 (eq (get sym 'ses-cell) :ses-named))
1728 ;; This is a renamed cell, do not update the cell
1729 ;; name, but just update the coordinate property.
1730 (puthash sym (cons row col) ses--named-cell-hashmap)
1731 (ses-set-cell row col 'symbol
1732 (setq sym (ses-create-cell-symbol row col)))
1733 (unless (local-variable-if-set-p sym)
1734 (set (make-local-variable sym) nil)
1735 (put sym 'ses-cell (cons row col)))))) )))
1736 ;; Relocate the cell values.
1737 (let (oldval myrow mycol xrow xcol sym)
1738 (cond
1739 ((and (<= rowincr 0) (<= colincr 0))
1740 ;; Deletion of rows and/or columns.
1741 (dotimes-with-progress-reporter
1742 (row (- ses--numrows minrow)) "Relocating variables..."
1743 (setq myrow (+ row minrow))
1744 (dotimes (col (- ses--numcols mincol))
1745 (setq mycol (+ col mincol)
1746 xrow (- myrow rowincr)
1747 xcol (- mycol colincr)
1748 sym (ses-cell-symbol myrow mycol))
1749 ;; We don't need to relocate value for renamed cells, as they keep the same
1750 ;; symbol.
1751 (unless (eq (get sym 'ses-cell) :ses-named)
1752 (ses-set-cell myrow mycol 'value
1753 (if (and (< xrow ses--numrows) (< xcol ses--numcols))
1754 (ses-cell-value xrow xcol)
1755 ;; Cell is off the end of the array.
1756 (symbol-value (ses-create-cell-symbol xrow xcol)))))))
1757 (when ses--in-killing-named-cell-list
1758 (message "Unbinding killed named cell symbols...")
1759 (setq ses-start-time (float-time))
1760 (while ses--in-killing-named-cell-list
1761 (ses--time-check "Unbinding killed named cell symbols... (%d left)" (length ses--in-killing-named-cell-list))
1762 (ses--unbind-cell-name (pop ses--in-killing-named-cell-list)) )
1763 (message nil)) )
1765 ((and (wholenump rowincr) (wholenump colincr))
1766 ;; Insertion of rows and/or columns. Run the loop backwards.
1767 (let ((disty (1- ses--numrows))
1768 (distx (1- ses--numcols))
1769 myrow mycol)
1770 (dotimes-with-progress-reporter
1771 (row (- ses--numrows minrow)) "Relocating variables..."
1772 (setq myrow (- disty row))
1773 (dotimes (col (- ses--numcols mincol))
1774 (setq mycol (- distx col)
1775 xrow (- myrow rowincr)
1776 xcol (- mycol colincr)
1777 sym (ses-cell-symbol myrow mycol))
1778 ;; We don't need to relocate value for renamed cells, as they keep the same
1779 ;; symbol.
1780 (unless (eq (get sym 'ses-cell) :ses-named)
1781 (if (or (< xrow minrow) (< xcol mincol))
1782 ;; Newly-inserted value.
1783 (setq oldval nil)
1784 ;; Transfer old value.
1785 (setq oldval (ses-cell-value xrow xcol)))
1786 (ses-set-cell myrow mycol 'value oldval))))
1787 t)) ; Make testcover happy by returning non-nil here.
1788 (t
1789 (error "ROWINCR and COLINCR must have the same sign"))))
1790 ;; Reconstruct reference lists for cells that contain ses-ranges that have
1791 ;; changed size.
1792 (when reform
1793 (message "Fixing ses-ranges...")
1794 (let (row col)
1795 (setq ses-start-time (float-time))
1796 (while reform
1797 (ses--time-check "Fixing ses-ranges... (%d left)" (length reform))
1798 (setq row (caar reform)
1799 col (cdar reform)
1800 reform (cdr reform))
1801 (ses-cell-set-formula row col (ses-cell-formula row col))))
1802 (message nil))))
1805 ;;----------------------------------------------------------------------------
1806 ;; Undo control
1807 ;;----------------------------------------------------------------------------
1809 (defun ses-begin-change ()
1810 "For undo, remember point before we start changing hidden stuff."
1811 (let ((inhibit-read-only t))
1812 (insert-and-inherit "X")
1813 (delete-region (1- (point)) (point))))
1815 (defun ses-setter-with-undo (accessors newval &rest args)
1816 "Set a field/variable and record it so it can be undone.
1817 Result is non-nil if field/variable has changed."
1818 (let ((oldval (apply (car accessors) args)))
1819 (unless (equal-including-properties oldval newval)
1820 (push `(apply ses-setter-with-undo ,accessors ,oldval ,@args)
1821 buffer-undo-list)
1822 (apply (cdr accessors) newval args)
1823 t)))
1825 (defun ses-aset-with-undo (array idx newval)
1826 (ses-setter-with-undo (eval-when-compile
1827 (cons #'aref
1828 (lambda (newval array idx) (aset array idx newval))))
1829 newval array idx))
1831 (defun ses-set-with-undo (sym newval)
1832 (ses-setter-with-undo
1833 (eval-when-compile
1834 (cons (lambda (sym) (if (boundp sym) (symbol-value sym) :ses--unbound))
1835 (lambda (newval sym) (if (eq newval :ses--unbound)
1836 (makunbound sym)
1837 (set sym newval)))))
1838 newval sym))
1840 ;;----------------------------------------------------------------------------
1841 ;; Startup for major mode
1842 ;;----------------------------------------------------------------------------
1844 (defun ses-load ()
1845 "Parse the current buffer and set up buffer-local variables.
1846 Does not execute cell formulas or print functions."
1847 (widen)
1848 ;; Read our global parameters, which should be a 3-element list.
1849 (goto-char (point-max))
1851 (backward-list 1)
1852 (setq ses--params-marker (point-marker))
1853 (let* ((params (ignore-errors (read (current-buffer))))
1854 (params-len (safe-length params)))
1855 (or (and (>= params-len 3)
1856 (<= params-len 4)
1857 (numberp (car params))
1858 (numberp (cadr params))
1859 (>= (cadr params) 0)
1860 (numberp (nth 2 params))
1861 (> (nth 2 params) 0)
1862 (or (<= params-len 3)
1863 (let ((numlocprn (nth 3 params)))
1864 (and (integerp numlocprn) (>= numlocprn 0)))))
1865 (error "Invalid SES file"))
1866 (setq ses--file-format (car params)
1867 ses--numrows (cadr params)
1868 ses--numcols (nth 2 params)
1869 ses--numlocprn (or (nth 3 params) 0))
1870 (when (= ses--file-format 1)
1871 (let (buffer-undo-list) ; This is not undoable.
1872 (ses-goto-data 'ses--header-row)
1874 (ses-set-parameter 'ses--file-format 3)
1875 (message "Upgrading from SES-1 to SES-2 file format")))
1876 (or (<= ses--file-format 3)
1877 (error "This file needs a newer version of the SES library code"))
1878 ;; Initialize cell array.
1879 (setq ses--cells (make-vector ses--numrows nil))
1880 (dotimes (row ses--numrows)
1881 (aset ses--cells row (make-vector ses--numcols nil)))
1882 ;; initialize local printer map.
1883 (clrhash ses--local-printer-hashmap))
1885 ;; Skip over print area, which we assume is correct.
1886 (goto-char (point-min))
1887 (forward-line ses--numrows)
1888 (or (looking-at-p ses-print-data-boundary)
1889 (error "Missing marker between print and data areas"))
1890 (forward-char 1)
1891 (setq ses--data-marker (point-marker))
1892 (forward-char (1- (length ses-print-data-boundary)))
1893 ;; Initialize printer and symbol lists.
1894 (mapc #'ses-printer-record ses-standard-printer-functions)
1895 (setq ses--symbolic-formulas nil)
1897 ;; Load local printer definitions.
1898 ;; This must be loaded *BEFORE* cells and column printers because the latter
1899 ;; may call them.
1900 (save-excursion
1901 (forward-line (* ses--numrows (1+ ses--numcols)))
1902 (let ((numlocprn ses--numlocprn))
1903 (setq ses--numlocprn 0)
1904 (dotimes (_ numlocprn)
1905 (let ((x (read (current-buffer))))
1907 (eq (car-safe x) 'ses-local-printer)
1908 (apply #'ses--local-printer (cdr x)))
1909 (error "local printer-def error"))
1910 (setq ses--numlocprn (1+ ses--numlocprn))))))
1911 ;; Load cell definitions.
1912 (dotimes (row ses--numrows)
1913 (dotimes (col ses--numcols)
1914 (let* ((x (read (current-buffer)))
1915 (sym (car-safe (cdr-safe x))))
1917 (eq (car-safe x) 'ses-cell)
1918 (ses-create-cell-variable sym row col))
1919 (error "Cell-def error"))
1920 (apply #'ses--cell (cdr x))))
1922 (error "Missing blank line between rows")))
1923 ;; Skip local printer function declaration --- that were already loaded.
1924 (forward-line (+ 2 ses--numlocprn))
1925 ;; Load global parameters.
1926 (let ((widths (read (current-buffer)))
1927 (n1 (char-after (point)))
1928 (printers (read (current-buffer)))
1929 (n2 (char-after (point)))
1930 (def-printer (read (current-buffer)))
1931 (n3 (char-after (point)))
1932 (head-row (read (current-buffer)))
1933 (n4 (char-after (point))))
1934 (or (and (eq (car-safe widths) 'ses-column-widths)
1936 (eq (car-safe printers) 'ses-column-printers)
1938 (eq (car-safe def-printer) 'ses-default-printer)
1940 (eq (car-safe head-row) 'ses-header-row)
1942 (error "Invalid SES global parameters"))
1943 (1value (eval widths t))
1944 (1value (eval def-printer t))
1945 (1value (eval printers t))
1946 (1value (eval head-row t)))
1947 ;; Should be back at global-params.
1948 (forward-char 1)
1949 (or (looking-at-p ses-initial-global-parameters-re)
1950 (error "Problem with column-defs or global-params"))
1951 ;; Check for overall newline count in definitions area.
1952 (forward-line 3)
1953 (let ((start (point)))
1954 (ses-goto-data 'ses--numrows)
1955 (or (= (point) start)
1956 (error "Extraneous newlines someplace?"))))
1958 (defun ses-setup ()
1959 "Set up for display of only the printed cell values.
1961 Narrows the buffer to show only the print area. Gives it `read-only' and
1962 `intangible' properties. Sets up highlighting for current cell."
1963 (interactive)
1964 (let ((end (point-min))
1965 pos sym)
1966 (with-silent-modifications
1967 (ses-goto-data 0 0) ; Include marker between print-area and data-area.
1968 (set-text-properties (point) (point-max) nil) ; Delete garbage props.
1969 (mapc #'delete-overlay (overlays-in (point-min) (point-max)))
1970 ;; The print area is read-only (except for our special commands) and
1971 ;; uses a special keymap.
1972 (put-text-property (point-min) (1- (point)) 'read-only 'ses)
1973 (put-text-property (point-min) (1- (point)) 'keymap 'ses-mode-print-map)
1974 ;; For the beginning of the buffer, we want the read-only and keymap
1975 ;; attributes to be inherited from the first character.
1976 (put-text-property (point-min) (1+ (point-min))
1977 ;; `cursor-intangible' shouldn't be sticky at BOB.
1978 'front-sticky '(read-only keymap))
1979 ;; Create intangible properties, which also indicate which cell the text
1980 ;; came from.
1981 (dotimes-with-progress-reporter (row ses--numrows) "Finding cells..."
1982 (dotimes (col ses--numcols)
1983 (setq pos end
1984 sym (ses-cell-symbol row col))
1985 (unless (eq (symbol-value sym) '*skip*)
1986 ;; Include skipped cells following this one.
1987 (while (and (< col (1- ses--numcols))
1988 (eq (ses-cell-value row (1+ col)) '*skip*))
1989 (setq end (+ end (ses-col-width col) 1)
1990 ;; Beware: Modifying the iteration variable of `dotimes'
1991 ;; may or may not affect the iteration!
1992 col (1+ col)))
1993 (setq end (save-excursion
1994 (goto-char pos)
1995 (move-to-column (+ (current-column) (- end pos)
1996 (ses-col-width col)))
1997 (if (eolp)
1998 (+ end (ses-col-width col) 1)
1999 (forward-char)
2000 (point))))
2001 (put-text-property pos end 'cursor-intangible sym))))))
2002 ;; Create the underlining overlay. It's impossible for (point) to be 2,
2003 ;; because column A must be at least 1 column wide.
2004 (setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min))))
2005 (overlay-put ses--curcell-overlay 'face 'underline))
2007 (defun ses-cleanup ()
2008 "Cleanup when changing a buffer from SES mode to something else.
2009 Delete overlays, remove special text properties."
2010 (widen)
2011 (let ((inhibit-read-only t)
2012 ;; When reverting, hide the buffer name, otherwise Emacs will ask the
2013 ;; user "the file is modified, do you really want to make modifications
2014 ;; to this buffer", where the "modifications" refer to the irrelevant
2015 ;; set-text-properties below.
2016 (buffer-file-name nil)
2017 (was-modified (buffer-modified-p)))
2018 ;; Delete read-only, keymap, and intangible properties.
2019 (set-text-properties (point-min) (point-max) nil)
2020 ;; Delete overlay.
2021 (mapc #'delete-overlay (overlays-in (point-min) (point-max)))
2022 (unless was-modified
2023 (restore-buffer-modified-p nil))))
2025 (defun ses-killbuffer-hook ()
2026 "Hook when the current buffer is killed."
2027 (setq ses--ses-buffer-list (delq (current-buffer) ses--ses-buffer-list)))
2030 ;;;###autoload
2031 (defun ses-mode ()
2032 "Major mode for Simple Emacs Spreadsheet.
2034 When you invoke SES in a new buffer, it is divided into cells
2035 that you can enter data into. You can navigate the cells with
2036 the arrow keys and add more cells with the tab key. The contents
2037 of these cells can be numbers, text, or Lisp expressions. (To
2038 enter text, enclose it in double quotes.)
2040 In an expression, you can use cell coordinates to refer to the
2041 contents of another cell. For example, you can sum a range of
2042 cells with `(+ A1 A2 A3)'. There are specialized functions like
2043 `ses+' (addition for ranges with empty cells), `ses-average' (for
2044 performing calculations on cells), and `ses-range' and `ses-select'
2045 \(for extracting ranges of cells).
2047 Each cell also has a print function that controls how it is
2048 displayed.
2050 Each SES buffer is divided into a print area and a data area.
2051 Normally, you can simply use SES to look at and manipulate the print
2052 area, and let SES manage the data area outside the visible region.
2055 spreadsheet, and the Info node `(ses)Top.'
2057 In the following, note the separate keymaps for cell editing mode
2058 and print mode specifications. Key definitions:
2061 These key definitions are active only in the print area (the visible
2062 part):
2064 These are active only in the minibuffer, when entering or editing a
2065 formula:
2067 (interactive)
2068 (unless (and (boundp 'ses--deferred-narrow)
2069 (eq ses--deferred-narrow 'ses-mode))
2070 (kill-all-local-variables)
2071 (ses-set-localvars)
2072 (setq major-mode 'ses-mode
2073 mode-name "SES"
2074 next-line-add-newlines nil
2075 truncate-lines t
2076 ;; SES deliberately puts lots of trailing whitespace in its buffer.
2077 show-trailing-whitespace nil
2078 ;; Cell ranges do not work reasonably without this.
2079 transient-mark-mode t
2080 ;; Not to use tab characters for safe (tabs may do bad for column
2081 ;; calculation).
2082 indent-tabs-mode nil)
2083 (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t))
2084 (1value (add-hook 'kill-buffer-hook 'ses-killbuffer-hook nil t))
2085 (cl-pushnew (current-buffer) ses--ses-buffer-list :test 'eq)
2086 ;; This makes revert impossible if the buffer is read-only.
2087 ;; (1value (add-hook 'before-revert-hook 'ses-cleanup nil t))
2088 (setq header-line-format '(:eval (progn
2089 (when (/= (window-hscroll)
2090 ses--header-hscroll)
2091 ;; Reset ses--header-hscroll first,
2092 ;; to avoid recursion problems when
2093 ;; debugging ses-create-header-string
2094 (setq ses--header-hscroll
2095 (window-hscroll))
2096 (ses-create-header-string))
2097 ses--header-string)))
2098 (setq-local mode-line-process '(:eval (ses--mode-line-process)))
2099 (add-hook 'pre-redisplay-functions #'ses--cursor-sensor-highlight
2100 ;; Highlight the cell after moving cursor out of intangible.
2101 'append t)
2102 (cursor-intangible-mode 1)
2103 (let ((was-empty (zerop (buffer-size)))
2104 (was-modified (buffer-modified-p)))
2105 (save-excursion
2106 (if was-empty
2107 ;; Initialize buffer to contain one cell, for now.
2108 (insert ses-initial-file-contents))
2109 (ses-load)
2110 (ses-setup))
2111 (when was-empty
2112 (unless (equal ses-initial-default-printer
2113 (1value ses--default-printer))
2114 (1value (ses-read-default-printer ses-initial-default-printer)))
2115 (unless (= ses-initial-column-width (1value (ses-col-width 0)))
2116 (1value (ses-set-column-width 0 ses-initial-column-width)))
2117 (ses-set-curcell)
2118 (if (> (car ses-initial-size) (1value ses--numrows))
2119 (1value (ses-insert-row (1- (car ses-initial-size)))))
2120 (if (> (cdr ses-initial-size) (1value ses--numcols))
2121 (1value (ses-insert-column (1- (cdr ses-initial-size)))))
2122 (ses-write-cells)
2123 (restore-buffer-modified-p was-modified)
2124 (buffer-disable-undo)
2125 (buffer-enable-undo)
2126 (goto-char (point-min))))
2127 (use-local-map ses-mode-map)
2128 ;; Set the deferred narrowing flag (we can't narrow until after
2129 ;; after-find-file completes). If .ses is on the auto-load alist and the
2130 ;; file has "mode: ses", our ses-mode function will be called twice! Use a
2131 ;; special flag to detect this (will be reset by ses-command-hook). For
2132 ;; find-alternate-file, post-command-hook doesn't get run for some reason,
2133 ;; so use an idle timer to make sure.
2134 (setq ses--deferred-narrow 'ses-mode)
2135 (1value (add-hook 'post-command-hook 'ses-command-hook nil t))
2136 (run-with-idle-timer 0.01 nil 'ses-command-hook)
2137 (run-mode-hooks 'ses-mode-hook)))
2139 (put 'ses-mode 'mode-class 'special)
2141 (defun ses-command-hook ()
2142 "Invoked from `post-command-hook'. If point has moved to a different cell,
2143 moves the underlining overlay. Performs any recalculations or cell-data
2144 writes that have been deferred. If buffer-narrowing has been deferred,
2145 narrows the buffer now."
2146 (condition-case err
2147 (when (eq major-mode 'ses-mode) ; Otherwise, not our buffer anymore.
2148 (when ses--deferred-recalc
2149 ;; We reset the deferred list before starting on the recalc --- in
2150 ;; case of error, we don't want to retry the recalc after every
2151 ;; keystroke!
2152 (ses-initialize-Dijkstra-attempt)
2153 (let ((old ses--deferred-recalc))
2154 (setq ses--deferred-recalc nil)
2155 (ses-update-cells old)))
2156 (when ses--deferred-write
2157 ;; We don't reset the deferred list before starting --- the most
2158 ;; likely error is keyboard-quit, and we do want to keep trying these
2159 ;; writes after a quit.
2160 (ses-write-cells)
2161 (push '(apply ses-widen) buffer-undo-list))
2162 (when ses--deferred-narrow
2163 ;; We're not allowed to narrow the buffer until after-find-file has
2164 ;; read the local variables at the end of the file. Now it's safe to
2165 ;; do the narrowing.
2166 (narrow-to-region (point-min) ses--data-marker)
2167 (setq ses--deferred-narrow nil)))
2168 ;; Prevent errors in this post-command-hook from silently erasing the hook!
2169 (error
2170 (unless executing-kbd-macro
2171 (ding))
2172 (message "%s" (error-message-string err))))
2173 nil) ; Make coverage-tester happy.
2175 (defun ses--mode-line-process ()
2176 (let ((cmlp (window-parameter nil 'ses--mode-line-process))
2177 (curcell (ses--curcell (window-point))))
2178 (if (equal curcell (car cmlp))
2179 (cdr cmlp)
2180 (let ((mlp
2181 (cond
2182 ((not curcell) nil)
2183 ((atom curcell) (list " cell " (symbol-name curcell)))
2184 (t
2185 (list " range "
2186 (symbol-name (car curcell))
2187 "-"
2188 (symbol-name (cdr curcell)))))))
2189 (set-window-parameter nil 'ses--mode-line-process (cons curcell mlp))
2190 mlp))))
2192 (defun ses--cursor-sensor-highlight (window)
2193 (let ((curcell (ses--curcell))
2194 (ol (window-parameter window 'ses--curcell-overlay)))
2195 (unless ol
2196 (setq ol (make-overlay (point) (point)))
2197 (overlay-put ol 'window window)
2198 (overlay-put ol 'face 'underline)
2199 (set-window-parameter window 'ses--curcell-overlay ol))
2200 ;; Use underline overlay for single-cells only, turn off otherwise.
2201 (if (listp curcell)
2202 (delete-overlay ol)
2203 (let* ((pos (window-point window))
2204 (next (next-single-property-change pos 'cursor-intangible)))
2205 (move-overlay ol pos (1- next))))))
2207 (defun ses-create-header-string ()
2208 "Set up `ses--header-string' as the buffer's header line.
2209 Based on the current set of columns and `window-hscroll' position."
2210 (let ((totwidth (- (window-hscroll)))
2211 result width x)
2212 ;; Leave room for the left-side fringe and scrollbar.
2213 (push (propertize " " 'display '((space :align-to 0))) result)
2214 (dotimes (col ses--numcols)
2215 (setq width (ses-col-width col)
2216 totwidth (+ totwidth width 1))
2217 (if (= totwidth 1)
2218 ;; Scrolled so intercolumn space is leftmost.
2219 (push " " result))
2220 (when (> totwidth 1)
2221 (if (> ses--header-row 0)
2222 (save-excursion
2223 (ses-goto-print (1- ses--header-row) col)
2224 (setq x (buffer-substring-no-properties (point)
2225 (+ (point) width)))
2226 ;; Strip trailing space.
2228 (setq x (substring x 0 (match-beginning 0))))
2229 ;; Cut off excess text.
2230 (if (>= (length x) totwidth)
2231 (setq x (substring x 0 (- totwidth -1)))))
2232 (setq x (ses-column-letter col)))
2233 (push (propertize x 'face ses-box-prop) result)
2234 (push (propertize "."
2235 'display `((space :align-to ,(1- totwidth)))
2236 'face ses-box-prop)
2237 result)
2238 ;; Allow the following space to be squished to make room for the 3-D box
2239 ;; Coverage test ignores properties, thinks this is always a space!
2240 (push (1value (propertize " " 'display `((space :align-to ,totwidth))))
2241 result)))
2242 (if (> ses--header-row 0)
2243 (push (propertize (format " [row %d]" ses--header-row)
2244 'display '((height (- 1))))
2245 result))
2246 (setq ses--header-string (apply #'concat (nreverse result)))))
2249 ;;----------------------------------------------------------------------------
2250 ;; Redisplay and recalculation
2251 ;;----------------------------------------------------------------------------
2253 (defun ses-jump (sym)
2254 "Move point to cell SYM."
2255 (interactive (let* (names
2256 (s (completing-read
2257 "Jump to cell: "
2258 (and ses--named-cell-hashmap
2259 (progn (maphash (lambda (key _val)
2260 (push (symbol-name key) names))
2261 ses--named-cell-hashmap)
2262 names)))))
2263 (if
2264 (string= s "")
2265 (error "Invalid cell name")
2266 (list (intern s)))))
2267 (let ((rowcol (ses-sym-rowcol sym)))
2268 (or rowcol (error "Invalid cell name"))
2269 (if (eq (symbol-value sym) '*skip*)
2270 (error "Cell is covered by preceding cell"))
2271 (ses-goto-print (car rowcol) (cdr rowcol))))
2273 (defun ses-jump-safe (cell)
2274 "Like `ses-jump', but no error if invalid cell."
2275 (ignore-errors
2276 (ses-jump cell)))
2278 (defun ses-reprint-all (&optional nonarrow)
2279 "Recreate the display area. Calls all printer functions. Narrows to
2280 print area if NONARROW is nil."
2281 (interactive "*P")
2282 (widen)
2283 (unless nonarrow
2284 (setq ses--deferred-narrow t))
2285 (let ((startcell (ses--cell-at-pos (point)))
2286 (inhibit-read-only t))
2287 (ses-begin-change)
2288 (goto-char (point-min))
2289 (search-forward ses-print-data-boundary)
2290 (backward-char (length ses-print-data-boundary))
2291 (delete-region (point-min) (point))
2292 ;; Insert all blank lines before printing anything, so ses-print-cell can
2293 ;; find the data area when inserting or deleting *skip* values for cells.
2294 (dotimes (_ ses--numrows)
2295 (insert-and-inherit ses--blank-line))
2296 (dotimes-with-progress-reporter (row ses--numrows) "Reprinting..."
2297 (if (eq (ses-cell-value row 0) '*skip*)
2298 ;; Column deletion left a dangling skip.
2299 (ses-set-cell row 0 'value nil))
2300 (dotimes (col ses--numcols)
2301 (ses-print-cell row col))
2302 (beginning-of-line 2))
2303 (ses-jump-safe startcell)))
2305 (defun ses-initialize-Dijkstra-attempt ()
2306 (setq ses--Dijkstra-attempt-nb (1+ ses--Dijkstra-attempt-nb)
2307 ses--Dijkstra-weight-bound (* ses--numrows ses--numcols)))
2309 ;; These functions use the variables 'row' and 'col' that are dynamically bound
2310 ;; by ses-print-cell. We define these variables at compile-time to make the
2311 ;; compiler happy.
2312 ;; (defvar row)
2313 ;; (defvar col)
2314 ;; (defvar maxrow)
2315 ;; (defvar maxcol)
2317 (defun ses-recalculate-cell (&optional curcell)
2318 "Recalculate and reprint the current cell or range.
2320 If CURCELL is non nil use it as current cell or range
2321 without any check, otherwise function (ses-check-curcell 'range)
2322 is called.
2324 For an individual cell, shows the error if the formula or printer
2325 signals one, or otherwise shows the cell's complete value. For a range, the
2327 to are recalculated first."
2328 (interactive "*")
2329 (if curcell (setq ses--curcell curcell)
2330 (ses-check-curcell 'range))
2331 (ses-begin-change)
2332 (ses-initialize-Dijkstra-attempt)
2333 (let (sig cur-rowcol)
2334 (setq ses-start-time (float-time))
2335 (if (atom ses--curcell)
2336 (when
2337 (setq cur-rowcol (ses-sym-rowcol ses--curcell)
2338 sig (progn
2339 (setf (ses-cell-property :ses-Dijkstra-attempt
2340 (car cur-rowcol)
2341 (cdr cur-rowcol))
2342 (cons ses--Dijkstra-attempt-nb 0))
2343 (ses-calculate-cell (car cur-rowcol) (cdr cur-rowcol) t)))
2344 (nconc sig (list (ses-cell-symbol (car cur-rowcol)
2345 (cdr cur-rowcol)))))
2346 ;; First, recalculate all cells that don't refer to other cells and
2347 ;; produce a list of cells with references.
2348 (ses-dorange ses--curcell
2349 (ses--time-check "Recalculating... %s" (ses-cell-symbol row col))
2350 (condition-case nil
2351 (progn
2352 ;; The t causes an error if the cell has references. If no
2353 ;; references, the t will be the result value.
2354 (1value (ses-formula-references (ses-cell-formula row col) t))
2355 (setf (ses-cell-property :ses-Dijkstra-attempt row col)
2356 (cons ses--Dijkstra-attempt-nb 0))
2357 (when (setq sig (ses-calculate-cell row col t))
2358 (nconc sig (list (ses-cell-symbol row col)))))
2359 (wrong-type-argument
2360 ;; The formula contains a reference.
2361 (cl-pushnew (ses-cell-symbol row col) ses--deferred-recalc
2362 :test #'equal)))))
2363 ;; Do the update now, so we can force recalculation.
2364 (let ((x ses--deferred-recalc))
2365 (setq ses--deferred-recalc nil)
2366 (condition-case hold
2367 (ses-update-cells x t)
2368 (error (setq sig hold))))
2369 (cond
2370 (sig
2371 (message "%s" (error-message-string sig)))
2372 ((consp ses--curcell)
2373 (message " "))
2374 (t
2375 (princ (symbol-value ses--curcell))))))
2377 (defun ses-recalculate-all ()
2378 "Recalculate and reprint all cells."
2379 (interactive "*")
2380 (let ((startcell (ses--cell-at-pos (point)))
2381 (ses--curcell (cons (ses-cell-symbol 0 0)
2382 (ses-cell-symbol (1- ses--numrows)
2383 (1- ses--numcols)))))
2384 (ses-recalculate-cell ses--curcell)
2385 (ses-jump-safe startcell)))
2387 (defun ses-truncate-cell ()
2388 "Reprint current cell, but without spillover into any following blank cells."
2389 (interactive "*")
2390 (ses-check-curcell)
2391 (let* ((rowcol (ses-sym-rowcol ses--curcell))
2392 (row (car rowcol))
2393 (col (cdr rowcol)))
2394 (when (and (< col (1- ses--numcols)) ;;Last column can't spill over, anyway
2395 (eq (ses-cell-value row (1+ col)) '*skip*))
2396 ;; This cell has spill-over. We'll momentarily pretend the following cell
2397 ;; has a t in it.
2398 (cl-progv
2399 (list (ses-cell-symbol row (1+ col)))
2400 '(t)
2401 (ses-print-cell row col))
2402 ;; Now remove the *skip*. ses-print-cell is always nil here.
2403 (ses-set-cell row (1+ col) 'value nil)
2404 (1value (ses-print-cell row (1+ col))))))
2406 (defun ses-reconstruct-all ()
2407 "Reconstruct buffer based on cell data stored in Emacs variables."
2408 (interactive "*")
2409 (ses-begin-change)
2410 ;;Reconstruct reference lists.
2411 (let (x yrow ycol)
2412 ;;Delete old reference lists
2413 (dotimes-with-progress-reporter
2414 (row ses--numrows) "Deleting references..."
2415 (dotimes (col ses--numcols)
2416 (ses-set-cell row col 'references nil)))
2417 ;;Create new reference lists
2418 (dotimes-with-progress-reporter
2419 (row ses--numrows) "Computing references..."
2420 (dotimes (col ses--numcols)
2421 (dolist (ref (ses-formula-references (ses-cell-formula row col)))
2422 (setq x (ses-sym-rowcol ref)
2423 yrow (car x)
2424 ycol (cdr x))
2425 (ses-set-cell yrow ycol 'references
2426 (cons (ses-cell-symbol row col)
2427 (ses-cell-references yrow ycol)))))))
2428 ;; Delete everything and reconstruct basic data area.
2429 (ses-widen)
2430 (let ((inhibit-read-only t))
2431 (goto-char (point-max))
2433 (delete-region (point-min) (point))
2434 ;; Buffer is quite screwed up --- can't even save the user-specified
2435 ;; locals.
2436 (delete-region (point-min) (point-max))
2437 (insert ses-initial-file-trailer)
2438 (goto-char (point-min)))
2439 ;; Create a blank display area.
2440 (dotimes (_ ses--numrows)
2441 (insert ses--blank-line))
2442 (insert ses-print-data-boundary)
2443 (backward-char (1- (length ses-print-data-boundary)))
2444 (setq ses--data-marker (point-marker))
2445 (forward-char (1- (length ses-print-data-boundary)))
2446 ;; Placeholders for cell data.
2448 ;; Placeholders for col-widths, col-printers, default-printer, header-row.
2450 (insert ses-initial-global-parameters)
2451 (backward-char (1- (length ses-initial-global-parameters)))
2452 (setq ses--params-marker (point-marker))
2453 (forward-char (1- (length ses-initial-global-parameters))))
2454 (ses-set-parameter 'ses--col-widths ses--col-widths)
2455 (ses-set-parameter 'ses--col-printers ses--col-printers)
2456 (ses-set-parameter 'ses--default-printer ses--default-printer)
2457 (ses-set-parameter 'ses--header-row ses--header-row)
2458 (ses-set-parameter 'ses--numrows ses--numrows)
2459 (ses-set-parameter 'ses--numcols ses--numcols)
2460 ;;Keep our old narrowing
2461 (ses-setup)
2462 (ses-recalculate-all)
2463 (goto-char (point-min)))
2466 ;;----------------------------------------------------------------------------
2467 ;; Input of cell formulas
2468 ;;----------------------------------------------------------------------------
2469 (defun ses-edit-cell-complete-symbol ()
2470 (interactive)
2471 (let ((completion-at-point-functions (cons 'ses--edit-cell-completion-at-point-function
2472 completion-at-point-functions)))
2473 (completion-at-point)))
2475 (defun ses--edit-cell-completion-at-point-function ()
2476 (and
2477 ses--completion-table
2478 (let* ((bol (save-excursion (move-beginning-of-line nil) (point)))
2479 start end collection
2480 (prefix
2481 (save-excursion
2482 (setq end (point))
2483 (backward-sexp)
2484 (if (< (point) bol)
2485 (progn
2486 (setq start bol)
2487 (buffer-substring start end))
2488 (setq start (point))
2489 (forward-sexp)
2490 (if (>= (point) end)
2491 (progn
2492 (setq end (point))
2493 (buffer-substring start end))
2494 nil))))
2495 prefix-length)
2496 (when (and prefix (null (string= prefix "")))
2497 (setq prefix-length (length prefix))
2498 (maphash (lambda (key _val)
2499 (let ((key-name (symbol-name key)))
2500 (when (and (>= (length key-name) prefix-length)
2501 (string= prefix (substring key-name 0 prefix-length)))
2502 (push key-name collection))))
2503 ses--completion-table)
2504 (and collection (list start end collection))))))
2506 (defun ses-edit-cell (row col newval)
2507 "Display current cell contents in minibuffer, for editing. Returns nil if
2508 cell formula was unsafe and user declined confirmation."
2509 (interactive
2510 (progn
2511 (barf-if-buffer-read-only)
2512 (ses-check-curcell)
2513 (let* ((rowcol (ses-sym-rowcol ses--curcell))
2514 (row (car rowcol))
2515 (col (cdr rowcol))
2516 (formula (ses-cell-formula row col))
2517 initial)
2518 (if (eq (car-safe formula) 'ses-safe-formula)
2519 (setq formula (cadr formula)))
2520 (if (eq (car-safe formula) 'quote)
2521 (setq initial (format "'%S" (cadr formula)))
2522 (setq initial (prin1-to-string formula)))
2523 (if (stringp formula)
2524 ;; Position cursor inside close-quote.
2525 (setq initial (cons initial (length initial))))
2526 (dolist (key ses-completion-keys)
2527 (define-key ses-mode-edit-map key 'ses-edit-cell-complete-symbol))
2528 ;; make it globally visible, so that it can be visible from the minibuffer.
2529 (setq ses--completion-table ses--named-cell-hashmap)
2530 (list row col
2531 (read-from-minibuffer (format "Cell %s: " ses--curcell)
2532 initial
2533 ses-mode-edit-map
2534 t ; Convert to Lisp object.
2535 'ses-read-cell-history)))))
2536 (when (ses-warn-unsafe newval 'unsafep)
2537 (ses-begin-change)
2538 (ses-cell-set-formula row col newval)
2539 t))
2541 (defun ses-read-cell (row col newval)
2542 "Self-insert for initial character of cell function."
2543 (interactive
2544 (let* ((initial (this-command-keys))
2545 (rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
2546 (curval (ses-cell-formula (car rowcol) (cdr rowcol))))
2547 (barf-if-buffer-read-only)
2548 (list (car rowcol)
2549 (cdr rowcol)
2551 (progn
2552 (if (not (stringp curval)) (setq curval nil))
2553 (read-string (if curval
2554 (format "String Cell %s (default %s): "
2555 ses--curcell curval)
2556 (format "String Cell %s: " ses--curcell))
2557 nil 'ses-read-string-history curval))
2558 (read-from-minibuffer
2559 (format "Cell %s: " ses--curcell)
2560 (cons (if (equal initial "(") "()" initial) 2)
2561 ses-mode-edit-map
2562 t ; Convert to Lisp object.
2563 'ses-read-cell-history
2564 (prin1-to-string (if (eq (car-safe curval) 'ses-safe-formula)
2565 (cadr curval)
2566 curval)))))))
2567 (when (ses-edit-cell row col newval)
2568 (ses-command-hook) ; Update cell widths before movement.
2569 (dolist (x ses-after-entry-functions)
2570 (funcall x 1))))
2572 (defun ses-read-symbol (row col symb)
2573 "Self-insert for a symbol as a cell formula. The set of all symbols that
2574 have been used as formulas in this spreadsheet is available for completions."
2575 (interactive
2576 (let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
2577 newval)
2578 (barf-if-buffer-read-only)
2579 (setq newval (completing-read (format "Cell %s ': " ses--curcell)
2580 ses--symbolic-formulas))
2581 (list (car rowcol)
2582 (cdr rowcol)
2583 (if (string= newval "")
2584 nil ; Don't create zero-length symbols!
2585 (list 'quote (intern newval))))))
2586 (when (ses-edit-cell row col symb)
2587 (ses-command-hook) ; Update cell widths before movement.
2588 (dolist (x ses-after-entry-functions)
2589 (funcall x 1))))
2591 (defun ses-clear-cell-forward (count)
2592 "Delete formula and printer for current cell and then move to next cell.
2593 With prefix, deletes several cells."
2594 (interactive "*p")
2595 (if (< count 0)
2596 (1value (ses-clear-cell-backward (- count)))
2597 (ses-check-curcell)
2598 (ses-begin-change)
2599 (dotimes (_ count)
2600 (ses-set-curcell)
2601 (let ((rowcol (ses-sym-rowcol ses--curcell)))
2602 (or rowcol (signal 'end-of-buffer nil))
2603 (ses-clear-cell (car rowcol) (cdr rowcol)))
2604 (forward-char 1))))
2606 (defun ses-clear-cell-backward (count)
2607 "Move to previous cell and then delete it. With prefix, deletes several
2608 cells."
2609 (interactive "*p")
2610 (if (< count 0)
2611 (1value (ses-clear-cell-forward (- count)))
2612 (ses-check-curcell 'end)
2613 (ses-begin-change)
2614 (dotimes (_ count)
2615 (backward-char 1) ; Will signal 'beginning-of-buffer if appropriate.
2616 (ses-set-curcell)
2617 (let ((rowcol (ses-sym-rowcol ses--curcell)))
2618 (ses-clear-cell (car rowcol) (cdr rowcol))))))
2621 ;;----------------------------------------------------------------------------
2622 ;; Input of cell-printer functions
2623 ;;----------------------------------------------------------------------------
2624 (defun ses-read-printer-complete-symbol ()
2625 (interactive)
2626 (let ((completion-at-point-functions (cons 'ses--read-printer-completion-at-point-function
2627 completion-at-point-functions)))
2628 (completion-at-point)))
2630 (defun ses--read-printer-completion-at-point-function ()
2631 (let* ((bol (save-excursion (move-beginning-of-line nil) (point)))
2632 start end collection
2633 (prefix
2634 (save-excursion
2635 (setq end (point))
2636 (backward-sexp)
2637 (if (< (point) bol)
2638 (progn
2639 (setq start bol)
2640 (buffer-substring start end))
2641 (setq start (point))
2642 (forward-sexp)
2643 (if (>= (point) end)
2644 (progn
2645 (setq end (point))
2646 (buffer-substring start end))
2647 nil))))
2648 prefix-length)
2649 (when prefix
2650 (setq prefix-length (length prefix))
2651 (maphash (lambda (key _val)
2652 (let ((key-name (symbol-name key)))
2653 (when (and (>= (length key-name) prefix-length)
2654 (string= prefix (substring key-name 0 prefix-length)))
2655 (push key-name collection))))
2656 ses--completion-table)
2657 (and collection (list start end collection)))))
2659 (defun ses-read-printer (prompt default)
2660 "Common code for functions `ses-read-cell-printer', `ses-read-column-printer',
2661 `ses-read-default-printer' and `ses-define-local-printer'.
2663 canceled."
2664 (barf-if-buffer-read-only)
2665 (if (eq default t)
2666 (setq default "")
2667 (setq prompt (format "%s (default %S): "
2668 (substring prompt 0 -2)
2669 default)))
2670 (dolist (key ses-completion-keys)
2671 (define-key ses-mode-edit-map key 'ses-read-printer-complete-symbol))
2672 ;; make it globally visible, so that it can be visible from the minibuffer.
2673 (setq ses--completion-table ses--local-printer-hashmap)
2674 (let ((new (read-from-minibuffer prompt
2675 nil ; Initial contents.
2676 ses-mode-edit-map
2677 t ; Evaluate the result.
2678 'ses-read-printer-history
2679 (prin1-to-string default))))
2680 (if (equal new default)
2681 ;; User changed mind, decided not to change printer.
2682 (setq new t)
2683 (ses-printer-validate new)
2684 (or (not new)
2685 (stringp new)
2686 (stringp (car-safe new))
2687 (and (symbolp new) (gethash new ses--local-printer-hashmap))
2688 (ses-warn-unsafe new 'unsafep-function)
2689 (setq new t)))
2690 new))
2692 (defun ses-read-cell-printer (newval)
2693 "Set the printer function for the current cell or range.
2695 A printer function is either a string (a format control-string with one
2696 %-sequence -- result from format will be right-justified), or a list of one
2697 string (result from format will be left-justified), or a lambda-expression of
2698 one argument, or a symbol that names a function of one argument. In the
2699 latter two cases, the function's result should be either a string (will be
2700 right-justified) or a list of one string (will be left-justified)."
2701 (interactive
2702 (let ((default t))
2703 (ses-check-curcell 'range)
2704 ;;Default is none if not all cells in range have same printer
2705 (catch 'ses-read-cell-printer
2706 (ses-dorange ses--curcell
2707 (let ((x (ses-cell-printer row col)))
2708 (if (eq (car-safe x) 'ses-safe-printer)
2709 (setq x (cadr x)))
2710 (if (eq default t)
2711 (setq default x)
2712 (unless (equal default x)
2713 ;;Range contains differing printer functions
2714 (setq default t)
2715 (throw 'ses-read-cell-printer t))))))
2716 (list (ses-read-printer (format "Cell %S printer: " ses--curcell)
2717 default))))
2718 (unless (eq newval t)
2719 (ses-begin-change)
2720 (ses-dorange ses--curcell
2721 (ses-set-cell row col 'printer newval)
2722 (ses-print-cell row col))))
2724 (defun ses-read-column-printer (col newval)
2725 "Set the printer function for the current column.
2726 See `ses-read-cell-printer' for input forms."
2727 (interactive
2728 (let ((col (cdr (ses-sym-rowcol ses--curcell))))
2729 (ses-check-curcell)
2730 (list col (ses-read-printer (format "Column %s printer: "
2731 (ses-column-letter col))
2732 (ses-col-printer col)))))
2734 (unless (eq newval t)
2735 (ses-begin-change)
2736 (ses-set-parameter 'ses--col-printers newval col)
2737 (save-excursion
2738 (dotimes (row ses--numrows)
2739 (ses-print-cell row col)))))
2741 (defun ses-read-default-printer (newval)
2742 "Set the default printer function for cells that have no other.
2743 See `ses-read-cell-printer' for input forms."
2744 (interactive
2745 (list (ses-read-printer "Default printer: " ses--default-printer)))
2746 (unless (eq newval t)
2747 (ses-begin-change)
2748 (ses-set-parameter 'ses--default-printer newval)
2749 (ses-reprint-all t)))
2752 ;;----------------------------------------------------------------------------
2753 ;; Spreadsheet size adjustments
2754 ;;----------------------------------------------------------------------------
2756 (defun ses-insert-row (count)
2757 "Insert a new row before the current one.
2758 With prefix, insert COUNT rows before current one."
2759 (interactive "*p")
2760 (ses-check-curcell 'end)
2761 (or (> count 0) (signal 'args-out-of-range nil))
2762 (ses-begin-change)
2763 (let ((inhibit-quit t)
2764 (inhibit-read-only t)
2765 (row (or (car (ses-sym-rowcol ses--curcell)) ses--numrows))
2766 newrow)
2767 ;;Create a new set of cell-variables
2768 (ses-create-cell-variable-range ses--numrows (+ ses--numrows count -1)
2769 0 (1- ses--numcols))
2770 (ses-set-parameter 'ses--numrows (+ ses--numrows count))
2771 ;;Insert each row
2772 (ses-goto-print row 0)
2773 (dotimes-with-progress-reporter (x count) "Inserting row..."
2774 ;;Create a row of empty cells. The `symbol' fields will be set by
2775 ;;the call to ses-relocate-all.
2776 (setq newrow (make-vector ses--numcols nil))
2777 (dotimes (col ses--numcols)
2778 (aset newrow col (ses-make-cell)))
2779 (setq ses--cells (ses-vector-insert ses--cells row newrow))
2780 (push `(apply ses-vector-delete ses--cells ,row 1) buffer-undo-list)
2781 (insert ses--blank-line))
2782 ;;Insert empty lines in cell data area (will be replaced by
2783 ;;ses-relocate-all)
2784 (ses-goto-data row 0)
2786 (ses-relocate-all row 0 count 0)
2787 ;;If any cell printers insert constant text, insert that text
2788 ;;into the line.
2789 (let ((cols (mapconcat #'ses-call-printer ses--col-printers nil))
2790 (global (ses-call-printer ses--default-printer)))
2791 (if (or (> (length cols) 0) (> (length global) 0))
2792 (dotimes (x count)
2793 (dotimes (col ses--numcols)
2794 ;;These cells are always nil, only constant formatting printed
2795 (1value (ses-print-cell (+ x row) col))))))
2796 (when (> ses--header-row row)
2797 ;;Inserting before header
2798 (ses-set-parameter 'ses--header-row (+ ses--header-row count))
2799 (ses-reset-header-string)))
2800 ;;Reconstruct text attributes
2801 (ses-setup)
2802 ;;Prepare for undo
2803 (push '(apply ses-widen) buffer-undo-list)
2804 ;;Return to current cell
2805 (if ses--curcell
2806 (ses-jump-safe ses--curcell)
2807 (ses-goto-print (1- ses--numrows) 0)))
2809 (defun ses-delete-row (count)
2810 "Delete the current row.
2811 With prefix, deletes COUNT rows starting from the current one."
2812 (interactive "*p")
2813 (ses-check-curcell)
2814 (or (> count 0) (signal 'args-out-of-range nil))
2815 (let ((inhibit-quit t)
2816 (inhibit-read-only t)
2817 (row (car (ses-sym-rowcol ses--curcell))))
2818 (setq count (min count (- ses--numrows row)))
2819 (ses-begin-change)
2820 (ses-set-parameter 'ses--numrows (- ses--numrows count))
2821 ;;Delete lines from print area
2822 (ses-goto-print row 0)
2823 (ses-delete-line count)
2824 ;;Delete lines from cell data area
2825 (ses-goto-data row 0)
2826 (ses-delete-line (* count (1+ ses--numcols)))
2827 ;; Collect named cells in the deleted rows, in order to clean the
2828 ;; symbols out of the named cell hash map, once the deletion is
2829 ;; complete
2830 (unless (null ses--in-killing-named-cell-list)
2831 (warn "Internal error, `ses--in-killing-named-cell-list' should be nil, but is equal to %S"
2832 ses--in-killing-named-cell-list)
2833 (setq ses--in-killing-named-cell-list nil))
2834 (dotimes-with-progress-reporter (nrow count)
2835 "Collecting named cell in deleted rows..."
2836 (dotimes (col ses--numcols)
2837 (let* ((row (+ row nrow))
2838 (sym (ses-cell-symbol row col)))
2839 (and (eq (get sym 'ses-cell) :ses-named)
2840 (push sym ses--in-killing-named-cell-list)))))
2841 ;;Relocate variables and formulas
2842 (ses-set-with-undo 'ses--cells (ses-vector-delete ses--cells row count))
2843 (ses-relocate-all row 0 (- count) 0)
2844 (ses-destroy-cell-variable-range ses--numrows (+ ses--numrows count -1)
2845 0 (1- ses--numcols))
2846 (when (> ses--header-row row)
2847 (if (<= ses--header-row (+ row count))
2848 ;;Deleting the header row
2849 (ses-set-parameter 'ses--header-row 0)
2850 (ses-set-parameter 'ses--header-row (- ses--header-row count)))
2851 (ses-reset-header-string)))
2852 ;;Reconstruct attributes
2853 (ses-setup)
2854 ;;Prepare for undo
2855 (push '(apply ses-widen) buffer-undo-list)
2856 (ses-jump-safe ses--curcell))
2858 (defun ses-insert-column (count &optional col width printer)
2859 "Insert a new column before COL (default is the current one).
2860 With prefix, insert COUNT columns before current one.
2861 If COL is specified, the new column(s) get the specified WIDTH and PRINTER
2862 \(otherwise they're taken from the current column)."
2863 (interactive "*p")
2864 (ses-check-curcell)
2865 (or (> count 0) (signal 'args-out-of-range nil))
2866 (or col
2867 (setq col (cdr (ses-sym-rowcol ses--curcell))
2868 width (ses-col-width col)
2869 printer (ses-col-printer col)))
2870 (ses-begin-change)
2871 (let ((inhibit-quit t)
2872 (inhibit-read-only t)
2873 (widths ses--col-widths)
2874 (printers ses--col-printers)
2875 has-skip)
2876 ;;Create a new set of cell-variables
2877 (ses-create-cell-variable-range 0 (1- ses--numrows)
2878 ses--numcols (+ ses--numcols count -1))
2879 ;;Insert each column.
2880 (dotimes-with-progress-reporter (x count) "Inserting column..."
2881 ;;Create a column of empty cells. The `symbol' fields will be set by
2882 ;;the call to ses-relocate-all.
2883 (ses-adjust-print-width col (1+ width))
2884 (ses-set-parameter 'ses--numcols (1+ ses--numcols))
2885 (dotimes (row ses--numrows)
2886 (and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*)
2887 ;;Inserting in the middle of a spill-over
2888 (setq has-skip t))
2889 (ses-aset-with-undo ses--cells row
2890 (ses-vector-insert (aref ses--cells row)
2891 col (ses-make-cell)))
2892 ;;Insert empty lines in cell data area (will be replaced by
2893 ;;ses-relocate-all)
2894 (ses-goto-data row col)
2896 ;; Insert column width and printer.
2897 (setq widths (ses-vector-insert widths col width)
2898 printers (ses-vector-insert printers col printer)))
2899 (ses-set-parameter 'ses--col-widths widths)
2900 (ses-set-parameter 'ses--col-printers printers)
2901 (ses-reset-header-string)
2902 (ses-relocate-all 0 col 0 count)
2903 (if has-skip
2904 (ses-reprint-all t)
2905 (when (or (> (length (ses-call-printer printer)) 0)
2906 (> (length (ses-call-printer ses--default-printer)) 0))
2907 ;; Either column printer or global printer inserts some constant text.
2908 ;; Reprint the new columns to insert that text.
2909 (dotimes (x ses--numrows)
2910 (dotimes (y count)
2911 ;; Always nil here --- this is a blank column.
2912 (1value (ses-print-cell-new-width x (+ y col))))))
2913 (ses-setup)))
2914 (ses-jump-safe ses--curcell))
2916 (defun ses-delete-column (count)
2917 "Delete the current column.
2918 With prefix, deletes COUNT columns starting from the current one."
2919 (interactive "*p")
2920 (ses-check-curcell)
2921 (or (> count 0) (signal 'args-out-of-range nil))
2922 (let ((inhibit-quit t)
2923 (inhibit-read-only t)
2924 (rowcol (ses-sym-rowcol ses--curcell))
2925 (width 0)
2926 col origrow has-skip)
2927 (setq origrow (car rowcol)
2928 col (cdr rowcol)
2929 count (min count (- ses--numcols col)))
2930 (if (= count ses--numcols)
2931 (error "Can't delete all columns!"))
2932 ;;Determine width of column(s) being deleted
2933 (dotimes (x count)
2934 (setq width (+ width (ses-col-width (+ col x)) 1)))
2935 (ses-begin-change)
2936 (ses-set-parameter 'ses--numcols (- ses--numcols count))
2937 (ses-adjust-print-width col (- width))
2938 ;; Prepare collecting named cells in the deleted columns, in order
2939 ;; to clean the symbols out of the named cell hash map, once the
2940 ;; deletion is complete
2941 (unless (null ses--in-killing-named-cell-list)
2942 (warn "Internal error, `ses--in-killing-named-cell-list' should be nil, but is equal to %S"
2943 ses--in-killing-named-cell-list)
2944 (setq ses--in-killing-named-cell-list nil))
2945 (dotimes-with-progress-reporter (row ses--numrows) "Deleting column..."
2946 ;;Delete lines from cell data area
2947 (ses-goto-data row col)
2948 (ses-delete-line count)
2949 ;; Collect named cells in the deleted columns within this row
2950 (dotimes (ncol count)
2951 (let ((sym (ses-cell-symbol row (+ col ncol))))
2952 (and (eq (get sym 'ses-cell) :ses-named)
2953 (push sym ses--in-killing-named-cell-list))))
2954 ;;Delete cells. Check if deletion area begins or ends with a skip.
2955 (if (or (eq (ses-cell-value row col) '*skip*)
2956 (and (< col ses--numcols)
2957 (eq (ses-cell-value row (+ col count)) '*skip*)))
2958 (setq has-skip t))
2959 (ses-aset-with-undo ses--cells row
2960 (ses-vector-delete (aref ses--cells row) col count)))
2961 ;;Update globals
2962 (ses-set-parameter 'ses--col-widths
2963 (ses-vector-delete ses--col-widths col count))
2964 (ses-set-parameter 'ses--col-printers
2965 (ses-vector-delete ses--col-printers col count))
2966 (ses-reset-header-string)
2967 ;;Relocate variables and formulas
2968 (ses-relocate-all 0 col 0 (- count))
2969 (ses-destroy-cell-variable-range 0 (1- ses--numrows)
2970 ses--numcols (+ ses--numcols count -1))
2971 (if has-skip
2972 (ses-reprint-all t)
2973 (ses-setup))
2974 (if (>= col ses--numcols)
2975 (setq col (1- col)))
2976 (ses-goto-print origrow col)))
2978 (defun ses-forward-or-insert (&optional count)
2979 "Move to next cell in row, or inserts a new cell if already in last one, or
2980 inserts a new row if at bottom of print area. Repeat COUNT times."
2981 (interactive "p")
2982 (ses-check-curcell 'end)
2983 (setq deactivate-mark t) ; Doesn't combine well with ranges.
2984 (dotimes (x count)
2985 (ses-set-curcell)
2986 (if (not ses--curcell)
2987 (progn ; At bottom of print area.
2988 (barf-if-buffer-read-only)
2989 (ses-insert-row 1))
2990 (let ((col (cdr (ses-sym-rowcol ses--curcell))))
2991 (when (/= 32
2992 (char-before (next-single-property-change (point)
2993 'cursor-intangible)))
2994 ;; We're already in last nonskipped cell on line. Need to create a
2995 ;; new column.
2996 (barf-if-buffer-read-only)
2997 (ses-insert-column (- count x)
2998 ses--numcols
2999 (ses-col-width col)
3000 (ses-col-printer col)))))
3001 (forward-char)))
3003 (defun ses-append-row-jump-first-column ()
3004 "Insert a new row after current one and jump to its first column."
3005 (interactive "*")
3006 (ses-check-curcell)
3007 (ses-begin-change)
3008 (beginning-of-line 2)
3009 (ses-set-curcell)
3010 (ses-insert-row 1))
3012 (defun ses-set-column-width (col newwidth)
3013 "Set the width of the current column."
3014 (interactive
3015 (let ((col (cdr (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))))
3016 (barf-if-buffer-read-only)
3017 (list col
3018 (if current-prefix-arg
3019 (prefix-numeric-value current-prefix-arg)
3020 (read-from-minibuffer (format "Column %s width (default %d): "
3021 (ses-column-letter col)
3022 (ses-col-width col))
3023 nil ; No initial contents.
3024 nil ; No override keymap.
3025 t ; Convert to Lisp object.
3026 nil ; No history.
3027 (number-to-string
3028 (ses-col-width col))))))) ; Default value.
3029 (if (< newwidth 1)
3030 (error "Invalid column width"))
3031 (ses-begin-change)
3032 (ses-reset-header-string)
3033 (save-excursion
3034 (let ((inhibit-quit t))
3035 (ses-adjust-print-width col (- newwidth (ses-col-width col)))
3036 (ses-set-parameter 'ses--col-widths newwidth col))
3037 (dotimes (row ses--numrows)
3038 (ses-print-cell-new-width row col))))
3041 ;;----------------------------------------------------------------------------
3042 ;; Cut and paste, import and export
3043 ;;----------------------------------------------------------------------------
3045 (defun ses--advice-copy-region-as-kill (crak-fun beg end &rest args)
3046 ;; FIXME: Why doesn't it make sense to copy read-only or
3047 ;; intangible attributes? They're removed upon yank!
3048 "It doesn't make sense to copy read-only or intangible attributes into the
3049 kill ring. It probably doesn't make sense to copy keymap properties.
3050 We'll assume copying front-sticky properties doesn't make sense, either.
3052 This advice also includes some SES-specific code because otherwise it's too
3053 hard to override how mouse-1 works."
3054 (when (and beg end (> beg end))
3055 (let ((temp beg))
3056 (setq beg end
3057 end temp)))
3058 (if (not (and (derived-mode-p 'ses-mode)
3059 (eq (get-text-property beg 'read-only) 'ses)
3060 (eq (get-text-property (1- end) 'read-only) 'ses)))
3061 (apply crak-fun beg end args) ; Normal copy-region-as-kill.
3062 (kill-new (ses-copy-region beg end))
3063 (if transient-mark-mode
3064 (setq deactivate-mark t))
3065 nil))
3066 (advice-add 'copy-region-as-kill :around #'ses--advice-copy-region-as-kill)
3068 (defun ses-copy-region (beg end)
3069 "Treat the region as rectangular. Convert the intangible attributes to
3070 SES attributes recording the contents of the cell as of the time of copying."
3071 (when (= end ses--data-marker)
3072 ;;Avoid overflow situation
3073 (setq end (1- ses--data-marker)))
3074 (let* ((x (mapconcat #'ses-copy-region-helper
3076 (remove-text-properties 0 (length x)
3077 '(read-only t
3078 cursor-intangible t
3079 keymap t
3080 front-sticky t)
3081 x)
3082 x))
3084 (defun ses-copy-region-helper (line)
3085 "Converts one line (of a rectangle being extracted from a spreadsheet) to
3086 external form by attaching to each print cell a `ses' attribute that records
3087 the corresponding data cell."
3088 (or (> (length line) 1)
3089 (error "Empty range"))
3090 (let ((inhibit-read-only t)
3091 (pos 0)
3092 mycell next sym rowcol)
3093 (while pos
3094 (setq sym (ses--cell-at-pos pos line)
3095 next (next-single-property-change pos 'cursor-intangible line)
3096 rowcol (ses-sym-rowcol sym)
3097 mycell (ses-get-cell (car rowcol) (cdr rowcol)))
3098 (put-text-property pos (or next (length line))
3099 'ses
3100 (list (ses-cell-symbol mycell)
3101 (ses-cell-formula mycell)
3102 (ses-cell-printer mycell))
3103 line)
3104 (setq pos next)))
3105 line)
3107 (defun ses-kill-override (beg end)
3108 "Generic override for any commands that kill text.
3109 We clear the killed cells instead of deleting them."
3110 (interactive "r")
3111 (ses-check-curcell 'needrange)
3112 ;; For some reason, the text-read-only error is not caught by `delete-region',
3113 ;; so we have to use subterfuge.
3114 (let ((buffer-read-only t))
3115 (1value (condition-case nil
3116 (noreturn (funcall (lookup-key (current-global-map)
3117 (this-command-keys))
3118 beg end))
3119 (buffer-read-only nil)))) ; The expected error.
3120 ;; Because the buffer was marked read-only, the kill command turned itself
3121 ;; into a copy. Now we clear the cells or signal the error. First we check
3122 ;; whether the buffer really is read-only.
3123 (barf-if-buffer-read-only)
3124 (ses-begin-change)
3125 (ses-dorange ses--curcell
3126 (ses-clear-cell row col))
3127 (ses-jump (car ses--curcell)))
3129 (defun ses--advice-yank (yank-fun &optional arg &rest args)
3130 "In SES mode, the yanked text is inserted as cells.
3132 If the text contains `ses' attributes (meaning it went to the kill-ring from a
3133 SES buffer), the formulas and print functions are restored for the cells. If
3134 the text contains tabs, this is an insertion of tab-separated formulas.
3135 Otherwise the text is inserted as the formula for the current cell.
3137 When inserting cells, the formulas are usually relocated to keep the same
3138 relative references to neighboring cells. This is best if the formulas
3139 generally refer to other cells within the yanked text. You can use the C-u
3140 prefix to specify insertion without relocation, which is best when the
3141 formulas refer to cells outside the yanked text.
3143 When inserting formulas, the text is treated as a string constant if it doesn't
3144 make sense as a sexp or would otherwise be considered a symbol. Use `sym' to
3145 explicitly insert a symbol, or use the C-u prefix to treat all unmarked words
3146 as symbols."
3147 (if (not (and (derived-mode-p 'ses-mode)
3148 (eq (get-text-property (point) 'keymap) 'ses-mode-print-map)))
3149 (apply yank-fun arg args) ; Normal non-SES yank.
3150 (ses-check-curcell 'end)
3151 (push-mark)
3152 (let ((text (current-kill (cond
3153 ((listp arg) 0)
3154 ((eq arg '-) -1)
3155 (t (1- arg))))))
3156 (or (ses-yank-cells text arg)
3157 (ses-yank-tsf text arg)
3158 (ses-yank-one (ses-yank-resize 1 1)
3159 text
3160 0
3162 ;; Just one cell --- delete final tab or newline.
3163 (1- (length text)))
3164 arg)))
3165 (if (consp arg)
3166 (exchange-point-and-mark))))
3167 (advice-add 'yank :around #'ses--advice-yank)
3169 (defun ses-yank-pop (arg)
3170 "Replace just-yanked stretch of killed text with a different stretch.
3171 This command is allowed only immediately after a `yank' or a `yank-pop',
3172 when the region contains a stretch of reinserted previously-killed text.
3173 We replace it with a different stretch of killed text.
3174 Unlike standard `yank-pop', this function uses `undo' to delete the
3175 previous insertion."
3176 (interactive "*p")
3177 (or (eq last-command 'yank)
3178 ;;Use noreturn here just to avoid a "poor-coverage" warning in its
3179 ;;macro definition.
3180 (noreturn (error "Previous command was not a yank")))
3181 (undo)
3182 (ses-set-curcell)
3183 (yank (1+ (or arg 1)))
3184 (setq this-command 'yank))
3186 (defun ses-yank-cells (text arg)
3187 "If the TEXT has a proper set of `ses' attributes, insert the text as
3188 cells, else return nil. The cells are reprinted--the supplied text is
3189 ignored because the column widths, default printer, etc. at yank time might
3190 be different from those at kill-time. ARG is a list to indicate that
3191 formulas are to be inserted without relocation."
3192 (let ((first (get-text-property 0 'ses text))
3193 (last (get-text-property (1- (length text)) 'ses text)))
3194 (when (and first last) ;;Otherwise not proper set of attributes
3195 (setq first (ses-sym-rowcol (car first))
3196 last (ses-sym-rowcol (car last)))
3197 (let* ((needrows (- (car last) (car first) -1))
3198 (needcols (- (cdr last) (cdr first) -1))
3199 (rowcol (ses-yank-resize needrows needcols))
3200 (rowincr (- (car rowcol) (car first)))
3201 (colincr (- (cdr rowcol) (cdr first)))
3202 (pos 0)
3203 myrow mycol x)
3204 (dotimes-with-progress-reporter (row needrows) "Yanking..."
3205 (setq myrow (+ row (car rowcol)))
3206 (dotimes (col needcols)
3207 (setq mycol (+ col (cdr rowcol))
3208 last (get-text-property pos 'ses text)
3209 pos (next-single-property-change pos 'ses text)
3210 x (ses-sym-rowcol (car last)))
3211 (if (not last)
3212 ;; Newline --- all remaining cells on row are skipped.
3213 (setq x (cons (- myrow rowincr) (+ needcols colincr -1))
3214 last (list nil nil nil)
3215 pos (1- pos)))
3216 (if (/= (car x) (- myrow rowincr))
3217 (error "Cell row error"))
3218 (if (< (- mycol colincr) (cdr x))
3219 ;; Some columns were skipped.
3220 (let ((oldcol mycol))
3221 (while (< (- mycol colincr) (cdr x))
3222 (ses-clear-cell myrow mycol)
3223 (setq col (1+ col)
3224 mycol (1+ mycol)))
3225 (ses-print-cell myrow (1- oldcol)))) ;; This inserts *skip*.
3226 (when (car last) ; Skip this for *skip* cells.
3227 (setq x (nth 2 last))
3228 (unless (equal x (ses-cell-printer myrow mycol))
3229 (or (not x)
3230 (stringp x)
3231 (eq (car-safe x) 'ses-safe-printer)
3232 (setq x `(ses-safe-printer ,x)))
3233 (ses-set-cell myrow mycol 'printer x))
3234 (setq x (cadr last))
3235 (if (atom arg)
3236 (setq x (ses-relocate-formula x 0 0 rowincr colincr)))
3237 (or (atom x)
3238 (eq (car-safe x) 'ses-safe-formula)
3239 (setq x `(ses-safe-formula ,x)))
3240 (ses-cell-set-formula myrow mycol x)))
3241 (when pos
3242 (if (get-text-property pos 'ses text)
3243 (error "Missing newline between rows"))
3244 (setq pos (next-single-property-change pos 'ses text))))
3245 t))))
3247 (defun ses-yank-one (rowcol text from to arg)
3248 "Insert the substring [FROM,TO] of TEXT as the formula for cell ROWCOL (a
3249 cons of ROW and COL). Treat plain symbols as strings unless ARG is a list."
3250 (let ((val (condition-case nil
3251 (read-from-string text from to)
3252 (error (cons nil from)))))
3253 (cond
3254 ((< (cdr val) (or to (length text)))
3255 ;; Invalid sexp --- leave it as a string.
3256 (setq val (substring text from to)))
3257 ((and (car val) (symbolp (car val)))
3258 (setq val (if (consp arg)
3259 (list 'quote (car val)) ; Keep symbol.
3260 (substring text from to)))) ; Treat symbol as text.
3261 (t
3262 (setq val (car val))))
3263 (let ((row (car rowcol))
3264 (col (cdr rowcol)))
3265 (or (atom val)
3266 (setq val `(ses-safe-formula ,val)))
3267 (ses-cell-set-formula row col val))))
3269 (defun ses-yank-tsf (text arg)
3270 "If TEXT contains tabs and/or newlines, treat the tabs as
3271 column-separators and the newlines as row-separators and insert the text as
3272 cell formulas--else return nil. Treat plain symbols as strings unless ARG
3273 is a list. Ignore a final newline."
3275 (= (match-end 0) (length text)))
3276 ;;Not TSF format
3277 nil
3280 (let ((pos -1)
3281 (spots (list -1))
3282 (cols 0)
3283 (needrows 0)
3284 needcols rowcol)
3285 ;;Find all the tabs and newlines
3287 (push pos spots)
3288 (setq cols (1+ cols))
3290 (if (not needcols)
3291 (setq needcols cols)
3292 (or (= needcols cols)
3293 (error "Inconsistent row lengths")))
3294 (setq cols 0
3295 needrows (1+ needrows))))
3296 ;;Insert the formulas
3297 (setq rowcol (ses-yank-resize needrows needcols))
3298 (dotimes (row needrows)
3299 (dotimes (col needcols)
3300 (ses-yank-one (cons (+ (car rowcol) needrows (- row) -1)
3301 (+ (cdr rowcol) needcols (- col) -1))
3302 text (1+ (cadr spots)) (car spots) arg)
3303 (setq spots (cdr spots))))
3304 (ses-goto-print (+ (car rowcol) needrows -1)
3305 (+ (cdr rowcol) needcols -1))
3306 t)))
3308 (defun ses-yank-resize (needrows needcols)
3309 "If this yank will require inserting rows and/or columns, ask for
3310 confirmation and then insert them. Result is (row,col) for top left of yank
3311 spot, or error signal if user requests cancel."
3312 (ses-begin-change)
3313 (let ((rowcol (if ses--curcell
3314 (ses-sym-rowcol ses--curcell)
3315 (cons ses--numrows 0)))
3316 rowbool colbool)
3317 (setq needrows (- (+ (car rowcol) needrows) ses--numrows)
3318 needcols (- (+ (cdr rowcol) needcols) ses--numcols)
3319 rowbool (> needrows 0)
3320 colbool (> needcols 0))
3321 (when (or rowbool colbool)
3322 ;;Need to insert. Get confirm
3323 (or (y-or-n-p (format "Yank will insert %s%s%s. Continue? "
3324 (if rowbool (format "%d rows" needrows) "")
3325 (if (and rowbool colbool) " and " "")
3326 (if colbool (format "%d columns" needcols) "")))
3327 (error "Canceled"))
3328 (when rowbool
3329 (let (ses--curcell)
3330 (save-excursion
3331 (ses-goto-print ses--numrows 0)
3332 (ses-insert-row needrows))))
3333 (when colbool
3334 (ses-insert-column needcols
3335 ses--numcols
3336 (ses-col-width (1- ses--numcols))
3337 (ses-col-printer (1- ses--numcols)))))
3338 rowcol))
3340 (defun ses-export-tsv (_beg _end)
3341 "Export values from the current range, with tabs between columns and
3342 newlines between rows. Result is placed in kill ring."
3343 (interactive "r")
3344 (ses-export-tab nil))
3346 (defun ses-export-tsf (_beg _end)
3347 "Export formulas from the current range, with tabs between columns and
3348 newlines between rows. Result is placed in kill ring."
3349 (interactive "r")
3350 (ses-export-tab t))
3352 (defun ses-export-tab (want-formulas)
3353 "Export the current range with tabs between columns and newlines between rows.
3354 Result is placed in kill ring. The export is values unless WANT-FORMULAS
3355 is non-nil. Newlines and tabs in the export text are escaped."
3356 (ses-check-curcell 'needrange)
3357 (let ((print-escape-newlines t)
3358 result item)
3359 (ses-dorange ses--curcell
3360 (setq item (if want-formulas
3361 (ses-cell-formula row col)
3362 (ses-cell-value row col)))
3363 (if (eq (car-safe item) 'ses-safe-formula)
3364 ;;Hide our deferred safety-check marker
3365 (setq item (cadr item)))
3366 (if (or (not item) (eq item '*skip*))
3367 (setq item ""))
3368 (when (eq (car-safe item) 'quote)
3369 (push "'" result)
3370 (setq item (cadr item)))
3371 (setq item (ses-prin1 item))
3373 (push item result)
3374 (cond
3375 ((< col maxcol)
3377 ((< row maxrow)
3379 (setq result (apply #'concat (nreverse result)))
3380 (kill-new result)))
3382 ;;----------------------------------------------------------------------------
3383 ;; Interactive help on symbols
3384 ;;----------------------------------------------------------------------------
3386 (defun ses-list-local-printers (&optional local-printer-hashmap)
3387 "List local printers in a help buffer. Can be called either
3388 during editing a printer or a formula, or while in the SES
3389 buffer."
3390 (interactive
3391 (list (cond
3392 ((derived-mode-p 'ses-mode) ses--local-printer-hashmap)
3393 ((minibufferp) ses--completion-table)
3394 ((derived-mode-p 'help-mode) nil)
3395 (t (error "Not in a SES buffer")))))
3396 (when local-printer-hashmap
3397 (let ((ses--list-orig-buffer (or ses--list-orig-buffer (current-buffer))))
3398 (help-setup-xref
3399 (list (lambda (local-printer-hashmap buffer)
3400 (let ((ses--list-orig-buffer
3401 (if (buffer-live-p buffer) buffer)))
3402 (ses-list-local-printers local-printer-hashmap)))
3403 local-printer-hashmap ses--list-orig-buffer)
3404 (called-interactively-p 'interactive))
3406 (save-excursion
3407 (with-help-window (help-buffer)
3408 (if (= 0 (hash-table-count local-printer-hashmap))
3409 (princ "No local printers defined.")
3411 (maphash (lambda (key val)
3412 (princ key)
3413 (princ " as ")
3414 (prin1 (ses--locprn-def val))
3416 local-printer-hashmap))
3417 (with-current-buffer standard-output
3418 (buffer-string)))))))
3420 (defun ses-list-named-cells (&optional named-cell-hashmap)
3421 "List named cells in a help buffer. Can be called either
3422 during editing a printer or a formula, or while in the SES
3423 buffer."
3424 (interactive
3425 (list (cond
3426 ((derived-mode-p 'ses-mode) ses--named-cell-hashmap)
3427 ((minibufferp) ses--completion-table)
3428 ((derived-mode-p 'help-mode) nil)
3429 (t (error "Not in a SES buffer")))))
3430 (when named-cell-hashmap
3431 (let ((ses--list-orig-buffer (or ses--list-orig-buffer (current-buffer))))
3432 (help-setup-xref
3433 (list (lambda (named-cell-hashmap buffer)
3434 (let ((ses--list-orig-buffer
3435 (if (buffer-live-p buffer) buffer)))
3436 (ses-list-named-cells named-cell-hashmap)))
3437 named-cell-hashmap ses--list-orig-buffer)
3438 (called-interactively-p 'interactive))
3440 (save-excursion
3441 (with-help-window (help-buffer)
3442 (if (= 0 (hash-table-count named-cell-hashmap))
3443 (princ "No cell was renamed.")
3445 (maphash (lambda (key val)
3446 (princ key)
3447 (princ " for ")
3448 (prin1 (ses-create-cell-symbol (car val) (cdr val)))
3450 named-cell-hashmap))
3451 (with-current-buffer standard-output
3452 (buffer-string)))))))
3455 ;;----------------------------------------------------------------------------
3456 ;; Other user commands
3457 ;;----------------------------------------------------------------------------
3459 (defun ses-unset-header-row ()
3460 "Select the default header row."
3461 (interactive)
3462 (ses-set-header-row 0))
3464 (defun ses-set-header-row (row)
3465 "Set the ROW to display in the header-line.
3466 With a numerical prefix arg, use that row.
3467 With no prefix arg, use the current row.
3469 The top row is row 1. Selecting row 0 displays the default header row."
3470 (interactive
3471 (list (if (numberp current-prefix-arg) current-prefix-arg
3472 (let ((currow (1+ (car (ses-sym-rowcol ses--curcell)))))
3473 (if current-prefix-arg
3474 (read-number "Header row: " currow)
3475 currow)))))
3476 (if (or (< row 0) (> row ses--numrows))
3477 (error "Invalid header-row"))
3478 (ses-begin-change)
3479 (let ((oldval ses--header-row))
3480 (let (buffer-undo-list)
3481 (ses-set-parameter 'ses--header-row row))
3482 (push `(apply ses-set-header-row ,oldval) buffer-undo-list))
3483 (ses-reset-header-string))
3485 (defun ses-mark-row ()
3486 "Mark the entirety of current row as a range."
3487 (interactive)
3488 (ses-check-curcell 'range)
3489 (let ((row (car (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell)))))
3490 (push-mark)
3491 (ses-goto-print (1+ row) 0)
3492 (push-mark (point) nil t)
3493 (ses-goto-print row 0)))
3495 (defun ses-mark-column ()
3496 "Mark the entirety of current column as a range."
3497 (interactive)
3498 (ses-check-curcell 'range)
3499 (let ((col (cdr (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell))))
3500 (row 0))
3501 (push-mark)
3502 (ses-goto-print (1- ses--numrows) col)
3503 (forward-char 1)
3504 (push-mark (point) nil t)
3505 (while (eq '*skip* (ses-cell-value row col))
3506 ;;Skip over initial cells in column that can't be selected
3507 (setq row (1+ row)))
3508 (ses-goto-print row col)))
3510 (defun ses-end-of-line ()
3511 "Move point to last cell on line."
3512 (interactive)
3513 (ses-check-curcell 'end 'range)
3514 (when ses--curcell ; Otherwise we're at the bottom row, which is empty
3515 ; anyway.
3516 (let ((col (1- ses--numcols))
3517 row rowcol)
3518 (if (symbolp ses--curcell)
3519 ;; Single cell.
3520 (setq row (car (ses-sym-rowcol ses--curcell)))
3521 ;; Range --- use whichever end of the range the point is at.
3522 (setq rowcol (ses-sym-rowcol (if (< (point) (mark))
3523 (car ses--curcell)
3524 (cdr ses--curcell))))
3525 ;; If range already includes the last cell in a row, point is actually
3526 ;; in the following row.
3527 (if (<= (cdr rowcol) (1- col))
3528 (setq row (car rowcol))
3529 (setq row (1+ (car rowcol)))
3530 (if (= row ses--numrows)
3531 ;;Already at end - can't go anywhere
3532 (setq col 0))))
3533 (when (< row ses--numrows) ; Otherwise it's a range that includes last cell.
3534 (while (eq (ses-cell-value row col) '*skip*)
3535 ;; Back to beginning of multi-column cell.
3536 (setq col (1- col)))
3537 (ses-goto-print row col)))))
3539 (defun ses-renarrow-buffer ()
3540 "Narrow the buffer so only the print area is visible.
3542 (interactive)
3543 (setq ses--deferred-narrow t))
3545 (defun ses-sort-column (sorter &optional reverse)
3546 "Sort the range by a specified column.
3547 With prefix, sorts in REVERSE order."
3549 (ses-check-curcell 'needrange)
3550 (let ((min (ses-sym-rowcol (car ses--curcell)))
3551 (max (ses-sym-rowcol (cdr ses--curcell))))
3552 (let ((minrow (car min))
3553 (mincol (cdr min))
3554 (maxrow (car max))
3555 (maxcol (cdr max))
3556 keys extracts end)
3557 (setq sorter (cdr (ses-sym-rowcol (intern (concat sorter "1")))))
3558 (or (and sorter (>= sorter mincol) (<= sorter maxcol))
3559 (error "Invalid sort column"))
3560 ;;Get key columns and sort them
3561 (dotimes (x (- maxrow minrow -1))
3562 (ses-goto-print (+ minrow x) sorter)
3563 (setq end (next-single-property-change (point) 'cursor-intangible))
3564 (push (cons (buffer-substring-no-properties (point) end)
3565 (+ minrow x))
3566 keys))
3567 (setq keys (sort keys #'(lambda (x y) (string< (car x) (car y)))))
3568 ;;Extract the lines in reverse sorted order
3569 (or reverse
3570 (setq keys (nreverse keys)))
3571 (dolist (x keys)
3572 (ses-goto-print (cdr x) (1+ maxcol))
3573 (setq end (point))
3574 (ses-goto-print (cdr x) mincol)
3575 (push (ses-copy-region (point) end) extracts))
3576 (deactivate-mark)
3577 ;;Paste the lines sequentially
3578 (dotimes (x (- maxrow minrow -1))
3579 (ses-goto-print (+ minrow x) mincol)
3580 (ses-set-curcell)
3581 (ses-yank-cells (pop extracts) nil)))))
3583 (defun ses-sort-column-click (event reverse)
3584 "Mouse version of `ses-sort-column'."
3586 (setq event (event-end event))
3587 (select-window (posn-window event))
3588 (setq event (car (posn-col-row event))) ; Click column.
3589 (let ((col 0))
3590 (while (and (< col ses--numcols) (> event (ses-col-width col)))
3591 (setq event (- event (ses-col-width col) 1)
3592 col (1+ col)))
3593 (if (>= col ses--numcols)
3594 (ding)
3595 (ses-sort-column (ses-column-letter col) reverse))))
3597 (defun ses-insert-range ()
3598 "Insert into minibuffer the list of cells currently highlighted in the
3599 spreadsheet."
3600 (interactive "*")
3601 (let (x)
3602 (with-current-buffer (window-buffer minibuffer-scroll-window)
3603 (ses-command-hook) ; For ses-coverage.
3604 (ses-check-curcell 'needrange)
3605 (setq x (cdr (macroexpand `(ses-range ,(car ses--curcell)
3606 ,(cdr ses--curcell))))))
3607 (insert (substring (prin1-to-string (nreverse x)) 1 -1))))
3609 (defun ses-insert-ses-range ()
3611 highlighted range in the spreadsheet."
3612 (interactive "*")
3613 (let (x)
3614 (with-current-buffer (window-buffer minibuffer-scroll-window)
3615 (ses-command-hook) ; For ses-coverage.
3616 (ses-check-curcell 'needrange)
3617 (setq x (format "(ses-range %S %S)"
3618 (car ses--curcell)
3619 (cdr ses--curcell))))
3620 (insert x)))
3622 (defun ses-insert-range-click (event)
3623 "Mouse version of `ses-insert-range'."
3624 (interactive "*e")
3625 (mouse-set-point event)
3626 (ses-insert-range))
3628 (defun ses-insert-ses-range-click (event)
3629 "Mouse version of `ses-insert-ses-range'."
3630 (interactive "*e")
3631 (mouse-set-point event)
3632 (ses-insert-ses-range))
3634 (defun ses-replace-name-in-formula (formula old-name new-name)
3635 (let ((new-formula formula))
3636 (cond
3637 ((eq (car-safe formula) 'quote))
3638 ((symbolp formula)
3639 (if (eq formula old-name)
3640 (setq new-formula new-name)))
3641 ((consp formula)
3642 (while formula
3643 (let ((elt (car-safe formula)))
3644 (cond
3645 ((consp elt)
3646 (setcar formula (ses-replace-name-in-formula elt old-name new-name)))
3647 ((and (symbolp elt)
3648 (eq (car-safe formula) old-name))
3649 (setcar formula new-name))))
3650 (setq formula (cdr formula)))))
3651 new-formula))
3653 (defun ses-rename-cell (new-name &optional cell)
3654 "Rename current cell."
3655 (interactive "*SEnter new name: ")
3656 (or
3657 (and (local-variable-p new-name)
3658 (ses-is-cell-sym-p new-name)
3659 (error "Already a cell name"))
3660 (and (boundp new-name)
3661 (null (yes-or-no-p
3662 (format-message
3663 "`%S' is already bound outside this buffer, continue? "
3664 new-name)))
3665 (error "Already a bound cell name")))
3666 (let* (curcell
3667 (sym (if (ses-cell-p cell)
3668 (ses-cell-symbol cell)
3669 (setq cell nil
3670 curcell t)
3671 (ses-check-curcell)
3672 ses--curcell))
3673 (rowcol (ses-sym-rowcol sym))
3674 (row (car rowcol))
3675 (col (cdr rowcol))
3676 new-rowcol old-name old-value)
3677 (setq cell (or cell (ses-get-cell row col))
3678 old-name (ses-cell-symbol cell)
3679 old-value (symbol-value old-name)
3680 new-rowcol (ses-decode-cell-symbol (symbol-name new-name)))
3681 ;; when ses-rename-cell is called interactively, then 'sym' is the
3682 ;; 'cursor-intangible' property of text at cursor position, while
3683 ;; 'old-name' is the symbol stored in array cell at coordinate
3684 ;; 'rowcol' corresponding to 'ses-cell' property of symbol
3685 ;; 'sym'. Both must be the same.
3686 (unless (eq sym old-name)
3687 (error "Spreadsheet is broken, both symbols %S and %S refering to cell (%d,%d)" sym old-name row col))
3688 (if new-rowcol
3689 ;; the new name is of A1 type, so we test that the coordinate
3690 ;; inferred from new name
3691 (if (equal new-rowcol rowcol)
3692 (put new-name 'ses-cell rowcol)
3693 (error "Not a valid name for this cell location"))
3694 (setq ses--named-cell-hashmap
3695 (or ses--named-cell-hashmap (make-hash-table :test 'eq)))
3696 (put new-name 'ses-cell :ses-named)
3697 (puthash new-name rowcol ses--named-cell-hashmap))
3698 (push `(ses-rename-cell ,old-name ,cell) buffer-undo-list)
3699 (cl-pushnew rowcol ses--deferred-write :test #'equal)
3700 ;; Replace name by new name in formula of cells refering to renamed cell.
3701 (dolist (ref (ses-cell-references cell))
3702 (let* ((x (ses-sym-rowcol ref))
3703 (xcell (ses-get-cell (car x) (cdr x))))
3704 (cl-pushnew x ses--deferred-write :test #'equal)
3705 (setf (ses-cell-formula xcell)
3706 (ses-replace-name-in-formula
3707 (ses-cell-formula xcell)
3708 old-name
3709 new-name))))
3710 ;; Replace name by new name in reference list of cells to which renamed
3711 ;; cell refers to.
3712 (dolist (ref (ses-formula-references (ses-cell-formula cell)))
3713 (let* ((x (ses-sym-rowcol ref))
3714 (xcell (ses-get-cell (car x) (cdr x))))
3715 (cl-pushnew x ses--deferred-write :test #'equal)
3716 (setf (ses-cell-references xcell)
3717 (cons new-name (delq old-name
3718 (ses-cell-references xcell))))))
3719 (set (make-local-variable new-name) (symbol-value sym))
3720 (setf (ses-cell--symbol cell) new-name)
3721 ;; set new name to value
3722 (set new-name old-value)
3723 ;; Unbind old name
3724 (if (eq (get old-name 'ses-cell) :ses-named)
3725 (ses--unbind-cell-name old-name)
3726 (kill-local-variable old-name))
3727 (and curcell (setq ses--curcell new-name))
3728 (save-excursion
3729 (or curcell (ses-goto-print row col))
3730 (let* ((pos (point))
3731 (inhibit-read-only t)
3732 (end (next-single-property-change pos 'cursor-intangible)))
3733 (put-text-property pos end 'cursor-intangible new-name)))
3734 ;; Update the cell name in the mode-line.
3735 (force-mode-line-update)))
3737 (defun ses-refresh-local-printer (name _compiled-value) ;FIXME: unused arg?
3738 "Refresh printout for all cells which use printer NAME.
3739 NAME should be the name of a locally defined printer.
3740 Uses the value COMPILED-VALUE for this printer."
3741 (message "Refreshing cells using printer %S" name)
3742 (let (new-print)
3743 (dotimes (row ses--numrows)
3744 (dotimes (col ses--numcols)
3745 (let ((cell-printer (ses-cell-printer row col)))
3746 (when (eq cell-printer name)
3747 (unless new-print
3748 (setq new-print t)
3749 (ses-begin-change))
3750 (ses-print-cell row col)))))))
3753 (defun ses-define-local-printer (name definition)
3754 "Define a local printer with name NAME and definition DEFINITION.
3756 NAME shall be a symbol. Use TAB to complete over existing local
3757 printer names.
3759 DEFINITION shall be either a string formatter, e.g.:
3763 or a lambda expression, e.g. for formatting in ISO format dates
3764 created with a '(calcFunc-date YEAR MONTH DAY)' formula:
3766 (lambda (x)
3767 (cond
3769 ((eq (car-safe x) 'date)
3771 (math-format-date x)))
3772 (t (ses-center-span val ?# 'ses-prin1))))
3774 If NAME is already used to name a local printer function, then
3775 the current definition is proposed as default value, and the
3776 function is redefined."
3777 (interactive
3778 (let (name def already-defined-names)
3779 (maphash (lambda (key _val) (push (symbol-name key) already-defined-names))
3780 ses--local-printer-hashmap)
3781 (setq name (completing-read "Enter printer name: " already-defined-names))
3782 (when (string= name "")
3783 (error "Invalid printer name"))
3784 (setq name (intern name))
3785 (let* ((cur-printer (gethash name ses--local-printer-hashmap))
3786 (default (and cur-printer (ses--locprn-def cur-printer))))
3787 (setq def (ses-read-printer (format "Enter definition of printer %S: " name)
3788 default)))
3789 (list name def)))
3791 (let* ((cur-printer (gethash name ses--local-printer-hashmap))
3792 (default (and cur-printer (ses--locprn-def cur-printer)))
3793 create-printer)
3794 (cond
3795 ;; cancelled operation => do nothing
3796 ((eq definition t))
3797 ;; no change => do nothing
3798 ((and cur-printer (equal definition default)))
3799 ;; re-defined printer
3800 (cur-printer
3801 (setq create-printer 0)
3802 (setf (ses--locprn-def cur-printer) definition)
3803 (ses-refresh-local-printer
3804 name
3805 (setf (ses--locprn-compiled cur-printer)
3806 (ses-local-printer-compile definition))))
3807 ;; new definition
3808 (t
3809 (setq create-printer 1)
3810 (puthash name
3811 (setq cur-printer
3812 (ses-make-local-printer-info definition))
3813 ses--local-printer-hashmap)))
3814 (when create-printer
3815 (let ((printer-def-text
3816 (concat
3817 "(ses-local-printer "
3818 (symbol-name name)
3819 " "
3820 (prin1-to-string (ses--locprn-def cur-printer))
3821 ")")))
3822 (save-excursion
3823 (ses-goto-data ses--numrows
3824 (ses--locprn-number cur-printer))
3825 (let ((inhibit-read-only t))
3826 ;; Special undo since it's outside the narrowed buffer.
3827 (let (buffer-undo-list)
3828 (if (= create-printer 0)
3829 (delete-region (point) (line-end-position))
3831 (backward-char))
3832 (insert printer-def-text)
3833 (when (= create-printer 1)
3834 (ses-file-format-extend-parameter-list 3)
3835 (ses-set-parameter 'ses--numlocprn
3836 (1+ ses--numlocprn))))))))))
3838 (defsubst ses-define-if-new-local-printer (name def)
3839 "Same as function `ses-define-if-new-local-printer', except
3840 that the definition occurs only when the local printer does not
3841 already exists.
3843 Function `ses-define-if-new-local-printer' is not interactive; it
3844 is intended for mode hooks to add local printers automatically."
3845 (unless (gethash name ses--local-printer-hashmap)
3846 (ses-define-local-printer name def)))
3848 ;;----------------------------------------------------------------------------
3849 ;; Checking formulas for safety
3850 ;;----------------------------------------------------------------------------
3852 (defun ses-safe-printer (printer)
3853 "Return PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
3854 (if (or (stringp printer)
3855 (stringp (car-safe printer))
3856 (not printer)
3857 (and (symbolp printer) (gethash printer ses--local-printer-hashmap))
3858 (ses-warn-unsafe printer 'unsafep-function))
3859 printer
3860 'ses-unsafe))
3862 (defun ses-safe-formula (formula)
3863 "Return FORMULA if safe, or the substitute formula *unsafe* otherwise."
3864 (if (ses-warn-unsafe formula 'unsafep)
3865 formula
3866 `(ses-unsafe ',formula)))
3868 (defun ses-warn-unsafe (formula checker)
3869 "Apply CHECKER to FORMULA.
3870 If result is non-nil, asks user for confirmation about FORMULA,
3871 which might be unsafe. Returns t if formula is safe or user allows
3872 execution anyway. Always returns t if `safe-functions' is t."
3873 (if (eq safe-functions t)
3874 t
3875 (setq checker (funcall checker formula))
3876 (if (not checker)
3877 t
3879 formula checker)))))
3882 ;;----------------------------------------------------------------------------
3883 ;; Standard formulas
3884 ;;----------------------------------------------------------------------------
3886 (defun ses--clean-! (&rest x)
3887 "Clean by `delq' list X from any occurrence of nil or `*skip*'."
3888 (delq nil (delq '*skip* x)))
3890 (defun ses--clean-_ (x y)
3891 "Clean list X by replacing by Y any occurrence of nil or `*skip*'.
3893 This will change X by making `setcar' on its cons cells."
3894 (let ((ret x) ret-elt)
3895 (while ret
3896 (setq ret-elt (car ret))
3897 (when (memq ret-elt '(nil *skip*))
3898 (setcar ret y))
3899 (setq ret (cdr ret))))
3900 x)
3902 (defmacro ses-range (from to &rest rest)
3903 "Expand to a list of cell-symbols for the range going from
3904 FROM up to TO. The range automatically expands to include any
3905 new row or column inserted into its middle. The SES library code
3906 specifically looks for the symbol `ses-range', so don't create an
3907 alias for this macro!
3909 By passing in REST some flags one can configure the way the range
3910 is read and how it is formatted.
3912 In the sequel we assume that cells A1, B1, A2 B2 have respective values
3913 1 2 3 and 4.
3915 Readout direction is specified by a `>v', `>^', `<v', `<^',
3916 `v>', `v<', `^>', `^<' flag. For historical reasons, in absence
3917 of such a flag, a default direction of `^<' is assumed. This
3918 way `(ses-range A1 B2 ^>)' will evaluate to `(1 3 2 4)',
3919 while `(ses-range A1 B2 >^)' will evaluate to (3 4 1 2).
3921 If the range is one row, then `>' can be used as a shorthand to
3922 `>v' or `>^', and `<' to `<v' or `<^'.
3924 If the range is one column, then `v' can be used as a shorthand to
3925 `v>' or `v<', and `^' to `^>' or `v<'.
3927 A `!' flag will remove all cells whose value is nil or `*skip*'.
3929 A `_' flag will replace nil or `*skip*' by the value following
3930 the `_' flag. If the `_' flag is the last argument, then they are
3931 replaced by integer 0.
3933 A `*', `*1' or `*2' flag will vectorize the range in the sense of
3934 Calc. See info node `(Calc) Top'. Flag `*' will output either a
3935 vector or a matrix depending on the number of rows, `*1' will
3936 flatten the result to a one row vector, and `*2' will make a
3937 matrix whatever the number of rows.
3939 Warning: interaction with Calc is experimental and may produce
3940 confusing results if you are not aware of Calc data format.
3941 Use `math-format-value' as a printer for Calc objects."
3942 (let (result-row
3943 result
3944 (prev-row -1)
3945 (reorient-x nil)
3946 (reorient-y nil)
3947 transpose vectorize
3948 (clean 'list))
3949 (ses-dorange (cons from to)
3950 (when (/= prev-row row)
3951 (push result-row result)
3952 (setq result-row nil))
3953 (push (ses-cell-symbol row col) result-row)
3954 (setq prev-row row))
3955 (push result-row result)
3956 (while rest
3957 (let ((x (pop rest)))
3958 (pcase x
3959 (`>v (setq transpose nil reorient-x nil reorient-y nil))
3960 (`>^ (setq transpose nil reorient-x nil reorient-y t))
3961 (`<^ (setq transpose nil reorient-x t reorient-y t))
3962 (`<v (setq transpose nil reorient-x t reorient-y nil))
3963 (`v> (setq transpose t reorient-x nil reorient-y t))
3964 (`^> (setq transpose t reorient-x nil reorient-y nil))
3965 (`^< (setq transpose t reorient-x t reorient-y nil))
3966 (`v< (setq transpose t reorient-x t reorient-y t))
3967 ((or `* `*2 `*1) (setq vectorize x))
3968 (`! (setq clean 'ses--clean-!))
3969 (`_ (setq clean `(lambda (&rest x)
3970 (ses--clean-_ x ,(if rest (pop rest) 0)))))
3971 (_
3972 (cond
3973 ; shorthands one row
3974 ((and (null (cddr result)) (memq x '(> <)))
3975 (push (intern (concat (symbol-name x) "v")) rest))
3976 ; shorthands one col
3977 ((and (null (cdar result)) (memq x '(v ^)))
3978 (push (intern (concat (symbol-name x) ">")) rest))
3979 (t (error "Unexpected flag `%S' in ses-range" x)))))))
3980 (if reorient-y
3981 (setcdr (last result 2) nil)
3982 (setq result (cdr (nreverse result))))
3983 (unless reorient-x
3984 (setq result (mapcar #'nreverse result)))
3985 (when transpose
3986 (let ((ret (mapcar (lambda (x) (list x)) (pop result))) iter)
3987 (while result
3988 (setq iter ret)
3989 (dolist (elt (pop result))
3990 (setcar iter (cons elt (car iter)))
3991 (setq iter (cdr iter))))
3992 (setq result ret)))
3994 (cl-flet ((vectorize-*1
3995 (clean result)
3996 (cons clean (cons (quote 'vec) (apply #'append result))))
3997 (vectorize-*2
3998 (clean result)
3999 (cons clean (cons (quote 'vec)
4000 (mapcar (lambda (x)
4001 (cons clean (cons (quote 'vec) x)))
4002 result)))))
4003 (pcase vectorize
4004 (`nil (cons clean (apply #'append result)))
4005 (`*1 (vectorize-*1 clean result))
4006 (`*2 (vectorize-*2 clean result))
4007 (`* (funcall (if (cdr result)
4008 #'vectorize-*2
4009 #'vectorize-*1)
4010 clean result))))))
4012 (defun ses-delete-blanks (&rest args)
4013 "Return ARGS reversed, with the blank elements (nil and *skip*) removed."
4014 (let (result)
4015 (dolist (cur args)
4016 (unless (memq cur '(nil *skip*))
4017 (push cur result)))
4018 result))
4020 (defun ses+ (&rest args)
4021 "Compute the sum of the arguments, ignoring blanks."
4022 (apply #'+ (apply #'ses-delete-blanks args)))
4024 (defun ses-average (list)
4025 "Computes the sum of the numbers in LIST, divided by their length. Blanks
4026 are ignored. Result is always floating-point, even if all args are integers."
4027 (setq list (apply #'ses-delete-blanks list))
4028 (/ (float (apply #'+ list)) (length list)))
4030 (defmacro ses-select (fromrange test torange)
4031 "Select cells in FROMRANGE that are `equal' to TEST.
4032 For each match, return the corresponding cell from TORANGE.
4033 The ranges are macroexpanded but not evaluated so they should be
4034 either (ses-range BEG END) or (list ...). The TEST is evaluated."
4035 (setq fromrange (cdr (macroexpand fromrange))
4036 torange (cdr (macroexpand torange))
4037 test (eval test t))
4038 (or (= (length fromrange) (length torange))
4039 (error "ses-select: Ranges not same length"))
4040 (let (result)
4041 (dolist (x fromrange)
4042 (if (equal test (symbol-value x))
4043 (push (car torange) result))
4044 (setq torange (cdr torange)))
4045 (cons 'list result)))
4047 ;;All standard formulas are safe
4048 (dolist (x '(ses-cell-value ses-range ses-delete-blanks ses+ ses-average
4049 ses-select))
4050 (put x 'side-effect-free t))
4053 ;;----------------------------------------------------------------------------
4054 ;; Standard print functions
4055 ;;----------------------------------------------------------------------------
4057 (defun ses-center (value &optional span fill printer)
4058 "Print VALUE, centered within column.
4059 FILL is the fill character for centering (default = space).
4060 SPAN indicates how many additional rightward columns to include
4061 in width (default = 0).
4062 PRINTER is the printer to use for printing the value, default is the
4063 column printer if any, or the spreadsheet the spreadsheet default
4064 printer otherwise."
4065 (setq printer (or printer (ses-col-printer ses--col) ses--default-printer))
4066 (let ((width (ses-col-width ses--col))
4067 half)
4068 (or fill (setq fill ?\s))
4069 (or span (setq span 0))
4070 (setq value (ses-call-printer printer value))
4071 (dotimes (x span)
4072 (setq width (+ width 1 (ses-col-width (+ ses--col span (- x))))))
4073 ;; Set column width.
4074 (setq width (- width (string-width value)))
4075 (if (<= width 0)
4076 value ; Too large for field, anyway.
4077 (setq half (make-string (/ width 2) fill))
4078 (concat half value half
4079 (if (> (% width 2) 0) (char-to-string fill))))))
4081 (defun ses-center-span (value &optional fill printer)
4082 "Print VALUE, centered within the span that starts in the current column
4083 and continues until the next nonblank column.
4084 FILL specifies the fill character (default = space)."
4085 (let ((end (1+ ses--col)))
4086 (while (and (< end ses--numcols)
4087 (memq (ses-cell-value ses--row end) '(nil *skip*)))
4088 (setq end (1+ end)))
4089 (ses-center value (- end ses--col 1) fill printer)))
4091 (defun ses-dashfill (value &optional span printer)
4092 "Print VALUE centered using dashes.
4093 SPAN indicates how many rightward columns to include in width (default = 0)."
4094 (ses-center value span ?- printer))
4096 (defun ses-dashfill-span (value &optional printer)
4097 "Print VALUE, centered using dashes within the span that starts in the
4098 current column and continues until the next nonblank column."
4099 (ses-center-span value ?- printer))
4101 (defun ses-tildefill-span (value &optional printer)
4102 "Print VALUE, centered using tildes within the span that starts in the
4103 current column and continues until the next nonblank column."
4104 (ses-center-span value ?~ printer))
4106 (defun ses-prin1 (value)
4107 "Shorthand for '(prin1-to-string VALUE t)'.
4108 Useful to handle the default behavior in custom lambda based
4109 printer functions."
4110 (prin1-to-string value t))
4112 (defun ses-unsafe (_value)
4113 "Substitute for an unsafe formula or printer."
4114 (error "Unsafe formula or printer"))
4116 ;;All standard printers are safe, including ses-unsafe!
4117 (dolist (x (cons 'ses-unsafe ses-standard-printer-functions))
4118 (put x 'side-effect-free t))
4120 (defun ses-unload-function ()
4121 "Unload the Simple Emacs Spreadsheet."
4122 (advice-remove 'yank #'ses--advice-yank)
4123 (advice-remove 'copy-region-as-kill #'ses--advice-copy-region-as-kill)
4124 ;; Continue standard unloading.
4125 nil)
4127 (provide 'ses)
4129 ;;; ses.el ends here