;;; ses.el -- Simple Emacs Spreadsheet -*- coding: utf-8 -*-
-;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2013 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Maintainer: Vincent Belaïche <vincentb1@users.sourceforge.net>
;; working fine in most cases, however failed in some cases of several path
;; racing together.
;;
-;; The current algorithm is based on Dijksta algorithm. The ``cycle length'' is
+;; The current algorithm is based on Dijkstra's algorithm. The cycle length is
;; stored in some cell property. In order not to reset in all cells such
;; property at each update, the cycle length is stored in this property along
;; with some update attempt id that is incremented at each update. The current
;;; Code:
(require 'unsafep)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;----------------------------------------------------------------------------
(defgroup ses nil
"Simple Emacs Spreadsheet."
+ :tag "SES"
:group 'applications
:prefix "ses-"
:version "21.1")
ses--default-printer
ses--deferred-narrow ses--deferred-recalc
ses--deferred-write ses--file-format
+ ses--named-cell-hashmap
(ses--header-hscroll . -1) ; Flag for "initial recalc needed"
ses--header-row ses--header-string ses--linewidth
ses--numcols ses--numrows ses--symbolic-formulas
ses--data-marker ses--params-marker (ses--Dijkstra-attempt-nb . 0)
ses--Dijkstra-weight-bound
+ ;; This list is useful to speed-up clean-up of symbols when
+ ;; an area containing renamed cell is deleted.
+ ses--renamed-cell-symb-list
;; Global variables that we override
mode-line-process next-line-add-newlines transient-mark-mode)
"Buffer-local variables used by SES.")
(defvar ses-call-printer-return nil
"Set to t if last cell printer invoked by `ses-call-printer' requested
-left-justification of the result. Set to error-signal if ses-call-printer
+left-justification of the result. Set to error-signal if `ses-call-printer'
encountered an error during printing. Otherwise nil.")
(defvar ses-start-time nil
"From a CELL or a pair (ROW,COL), get the function that computes its value."
`(aref ,(if col `(ses-get-cell ,row ,col) row) 1))
+(defmacro ses-cell-formula-aset (cell formula)
+ "From a CELL set the function that computes its value."
+ `(aset ,cell 1 ,formula))
+
(defmacro ses-cell-printer (row &optional col)
"From a CELL or a pair (ROW,COL), get the function that prints its value."
`(aref ,(if col `(ses-get-cell ,row ,col) row) 2))
functions refer to its value."
`(aref ,(if col `(ses-get-cell ,row ,col) row) 3))
+(defmacro ses-cell-references-aset (cell references)
+ "From a CELL set the list REFERENCES of symbols for cells the
+function of which refer to its value."
+ `(aset ,cell 3 ,references))
+
+(defun ses-cell-p (cell)
+ "Return non `nil' is CELL is a cell of current buffer."
+ (and (vectorp cell)
+ (= (length cell) 5)
+ (eq cell (let ((rowcol (ses-sym-rowcol (ses-cell-symbol cell))))
+ (and (consp rowcol)
+ (ses-get-cell (car rowcol) (cdr rowcol)))))))
+
(defun ses-cell-property-get-fun (property-name cell)
;; To speed up property fetching, each time a property is found it is placed
;; in the first position. This way, after the first get, the full property
val)))))
(defmacro ses-cell-property-get (property-name row &optional col)
- "Get property named PROPERTY-NAME From a CELL or a pair (ROW,COL).
+ "Get property named PROPERTY-NAME from a CELL or a pair (ROW,COL).
When COL is omitted, CELL=ROW is a cell object. When COL is
present ROW and COL are the integer coordinates of the cell of
(defmacro ses-sym-rowcol (sym)
"From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0). Result
is nil if SYM is not a symbol that names a cell."
- `(and (symbolp ,sym) (get ,sym 'ses-cell)))
+ `(let ((rc (and (symbolp ,sym) (get ,sym 'ses-cell))))
+ (if (eq rc :ses-named)
+ (gethash ,sym ses--named-cell-hashmap)
+ rc)))
+
+(defun ses-is-cell-sym-p (sym)
+ "Check whether SYM point at a cell of this spread sheet."
+ (let ((rowcol (get sym 'ses-cell)))
+ (and rowcol
+ (if (eq rowcol :ses-named)
+ (and ses--named-cell-hashmap (gethash sym ses--named-cell-hashmap))
+ (and (< (car rowcol) ses--numrows)
+ (< (cdr rowcol) ses--numcols)
+ (eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym))))))
(defmacro ses-cell (sym value formula printer references)
"Load a cell SYM from the spreadsheet file. Does not recompute VALUE from
(delete-region pos (point))))
(defun ses-printer-validate (printer)
- "Signals an error if PRINTER is not a valid SES cell printer."
+ "Signal an error if PRINTER is not a valid SES cell printer."
(or (not printer)
(stringp printer)
(functionp printer)
(add-to-list 'ses-read-printer-history (prin1-to-string printer))))
(defun ses-formula-record (formula)
- "If FORMULA is of the form 'symbol, adds it to the list of symbolic formulas
+ "If FORMULA is of the form 'symbol, add it to the list of symbolic formulas
for this spreadsheet."
(when (and (eq (car-safe formula) 'quote)
(symbolp (cadr formula)))
"Produce a symbol that names the cell (ROW,COL). (0,0) => 'A1."
(intern (concat (ses-column-letter col) (number-to-string (1+ row)))))
+(defun ses-decode-cell-symbol (str)
+ "Decode a symbol \"A1\" => (0,0). Returns `nil' if STR is not a
+ canonical cell name. Does not save match data."
+ (let (case-fold-search)
+ (and (string-match "\\`\\([A-Z]+\\)\\([0-9]+\\)\\'" str)
+ (let* ((col-str (match-string-no-properties 1 str))
+ (col 0)
+ (col-offset 0)
+ (col-base 1)
+ (col-idx (1- (length col-str)))
+ (row (1- (string-to-number (match-string-no-properties 2 str)))))
+ (and (>= row 0)
+ (progn
+ (while
+ (progn
+ (setq col (+ col (* (- (aref col-str col-idx) ?A) col-base))
+ col-base (* col-base 26)
+ col-idx (1- col-idx))
+ (and (>= col-idx 0)
+ (setq col (+ col col-base)))))
+ (cons row col)))))))
+
(defun ses-create-cell-variable-range (minrow maxrow mincol maxcol)
"Create buffer-local variables for cells. This is undoable."
(push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
(put sym 'ses-cell (cons xrow xcol))
(make-local-variable sym)))))
+(defun ses-create-cell-variable (sym row col)
+ "Create a buffer-local variable `SYM' for cell at position (ROW, COL).
+
+SYM is the symbol for that variable, ROW and COL are integers for
+row and column of the cell, with numbering starting from 0.
+
+Return nil in case of failure."
+ (unless (local-variable-p sym)
+ (make-local-variable sym)
+ (if (let (case-fold-search) (string-match "\\`[A-Z]+[0-9]+\\'" (symbol-name sym)))
+ (put sym 'ses-cell (cons row col))
+ (put sym 'ses-cell :ses-named)
+ (setq ses--named-cell-hashmap (or ses--named-cell-hashmap (make-hash-table :test 'eq)))
+ (puthash sym (cons row col) ses--named-cell-hashmap))))
+
;; We do not delete the ses-cell properties for the cell-variables, in
;; case a formula that refers to this cell is in the kill-ring and is
;; later pasted back in.
(let (sym)
(dotimes (row (1+ (- maxrow minrow)))
(dotimes (col (1+ (- maxcol mincol)))
- (setq sym (ses-create-cell-symbol (+ row minrow) (+ col mincol)))
+ (let ((xrow (+ row minrow)) (xcol (+ col mincol)))
+ (setq sym (if (and (< xrow ses--numrows) (< xcol ses--numcols))
+ (ses-cell-symbol xrow xcol)
+ (ses-create-cell-symbol xrow xcol))))
(if (boundp sym)
(push `(apply ses-set-with-undo ,sym ,(symbol-value sym))
buffer-undo-list))
buffer-undo-list))
(defun ses-reset-header-string ()
- "Flags the header string for update. Upon undo, the header string will be
+ "Flag the header string for update. Upon undo, the header string will be
updated again."
(push '(apply ses-reset-header-string) buffer-undo-list)
(setq ses--header-hscroll -1))
nil) ; Make coverage-tester happy.
(defun ses-cell-set-formula (row col formula)
- "Store a new formula for (ROW . COL) and enqueues the cell for
+ "Store a new formula for (ROW . COL) and enqueue the cell for
recalculation via `post-command-hook'. Updates the reference lists for the
cells that this cell refers to. Does not update cell value or reprint the
cell. To avoid inconsistencies, this function is not interruptible, which
errors)))))
(if errors
(warn "----------------------------------------------------------------
-Some reference where corrupted.
+Some references were corrupted.
-The following is a list of where each element ELT is such
+The following is a list where each element ELT is such
that (car ELT) is the reference of cell CELL with corruption,
and (cdr ELT) is a property list where
(ses-cell-set-formula row col nil))
(defcustom ses-self-reference-early-detection nil
- "True if cycle detection is early for cells that refer to
-themselves."
+ "True if cycle detection is early for cells that refer to themselves."
+ :version "24.1"
:type 'boolean
:group 'ses)
(error "Circular references: %s" ses--deferred-recalc))
(message " "))
;; Can't use save-excursion here: if the cell under point is updated,
- ;; save-excusion's marker will move past the cell.
+ ;; save-excursion's marker will move past the cell.
(goto-char pos)))
;;----------------------------------------------------------------------------
(defun ses-in-print-area ()
- "Returns t if point is in print area of spreadsheet."
+ "Return t if point is in print area of spreadsheet."
(<= (point) ses--data-marker))
;; We turn off point-motion-hooks and explicitly position the cursor, in case
(forward-char))))
(defun ses-set-curcell ()
- "Sets `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a
+ "Set `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a
region, or nil if cursor is not at a cell."
(if (or (not mark-active)
deactivate-mark
nil)
(defun ses-check-curcell (&rest args)
- "Signal an error if ses--curcell is inappropriate. The end marker is
-appropriate if some argument is 'end. A range is appropriate if some
-argument is 'range. A single cell is appropriate unless some argument is
-'needrange."
+ "Signal an error if `ses--curcell' is inappropriate.
+The end marker is appropriate if some argument is 'end.
+A range is appropriate if some argument is 'range.
+A single cell is appropriate unless some argument is 'needrange."
(if (eq ses--curcell t)
;; curcell recalculation was postponed, but user typed ahead.
(ses-set-curcell))
(setq x (concat text (if (< maxcol ses--numcols) " " "\n")))
;; We use set-text-properties to prevent a wacky print function from
;; inserting rogue properties, and to ensure that the keymap property is
- ;; inherited (is it a bug that only unpropertied strings actually
+ ;; inherited (is it a bug that only unpropertized strings actually
;; inherit from surrounding text?)
(set-text-properties 0 (length x) nil x)
(insert-and-inherit x)
sig)))
(defun ses-call-printer (printer &optional value)
- "Invokes PRINTER (a string or parenthesized string or function-symbol or
+ "Invoke PRINTER (a string or parenthesized string or function-symbol or
lambda of one argument) on VALUE. Result is the printed cell as a string.
The variable `ses-call-printer-return' is set to t if the printer used
parenthesis to request left-justification, or the error-signal if the
(defun ses-adjust-print-width (col change)
"Insert CHANGE spaces in front of column COL, or at end of line if
COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind
-inhibit-quit to t."
+`inhibit-quit' to t."
(let ((inhibit-read-only t)
(blank (if (> change 0) (make-string change ?\s)))
(at-end (= col ses--numcols)))
(delete-char (- change))))))
(defun ses-print-cell-new-width (row col)
- "Same as ses-print-cell, except if the cell's value is *skip*, the preceding
-nonskipped cell is reprinted. This function is used when the width of
-cell (ROW,COL) has changed."
+ "Same as `ses-print-cell', except if the cell's value is *skip*,
+the preceding nonskipped cell is reprinted. This function is used
+when the width of cell (ROW,COL) has changed."
(if (not (eq (ses-cell-value row col) '*skip*))
(ses-print-cell row col)
;;Cell was skipped over - reprint previous
;; The data area
;;----------------------------------------------------------------------------
-(defun ses-narrowed-p () (/= (- (point-max) (point-min)) (buffer-size)))
-
(defun ses-widen ()
"Turn off narrowing, to be reenabled at end of command loop."
- (if (ses-narrowed-p)
+ (if (buffer-narrowed-p)
(setq ses--deferred-narrow t))
(widen))
(setq formula (cadr formula)))
(if (eq (car-safe printer) 'ses-safe-printer)
(setq printer (cadr printer)))
- ;; This is noticably faster than (format "%S %S %S %S %S")
+ ;; This is noticeably faster than (format "%S %S %S %S %S")
(setq text (concat "(ses-cell "
(symbol-name sym)
" "
;;----------------------------------------------------------------------------
(defun ses-formula-references (formula &optional result-so-far)
- "Produce a list of symbols for cells that this formula's value
+ "Produce a list of symbols for cells that this FORMULA's value
refers to. For recursive calls, RESULT-SO-FAR is the list being
constructed, or t to get a wrong-type-argument error when the
first reference is found."
result-so-far)
(defsubst ses-relocate-symbol (sym rowcol startrow startcol rowincr colincr)
- "Relocate one symbol SYM, whichs corresponds to ROWCOL (a cons of ROW and
+ "Relocate one symbol SYM, which corresponds to ROWCOL (a cons of ROW and
COL). Cells starting at (STARTROW,STARTCOL) are being shifted
by (ROWINCR,COLINCR)."
(let ((row (car rowcol))
(defun ses-relocate-formula (formula startrow startcol rowincr colincr)
"Produce a copy of FORMULA where all symbols that refer to cells in row
-STARTROW or above and col STARTCOL or above are altered by adding ROWINCR
-and COLINCR. STARTROW and STARTCOL are 0-based. Example:
+STARTROW or above, and col STARTCOL or above, are altered by adding ROWINCR
+and COLINCR. STARTROW and STARTCOL are 0-based. Example:
(ses-relocate-formula '(+ A1 B2 D3) 1 2 1 -1)
=> (+ A1 B2 C4)
If ROWINCR or COLINCR is negative, references to cells being deleted are
Sets `ses-relocate-return' to 'delete if cell-references were removed."
(let (rowcol result)
(if (or (atom formula) (eq (car formula) 'quote))
- (if (setq rowcol (ses-sym-rowcol formula))
+ (if (and (setq rowcol (ses-sym-rowcol formula))
+ (string-match "\\`[A-Z]+[0-9]+\\'" (symbol-name formula)))
(ses-relocate-symbol formula rowcol
startrow startcol rowincr colincr)
formula) ; Pass through as-is.
(funcall field (ses-sym-rowcol min))))
;; This range has changed size.
(setq ses-relocate-return 'range))
- `(ses-range ,min ,max ,@(cdddr range)))))
+ `(ses-range ,min ,max ,@(cl-cdddr range)))))
(defun ses-relocate-all (minrow mincol rowincr colincr)
"Alter all cell values, symbols, formulas, and reference-lists to relocate
the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR
to each symbol."
(let (reform)
- (let (mycell newval)
+ (let (mycell newval xrow)
(dotimes-with-progress-reporter
(row ses--numrows) "Relocating formulas..."
(dotimes (col ses--numcols)
(setq ses-relocate-return nil
mycell (ses-get-cell row col)
newval (ses-relocate-formula (ses-cell-formula mycell)
- minrow mincol rowincr colincr))
+ minrow mincol rowincr colincr)
+ xrow (- row rowincr))
(ses-set-cell row col 'formula newval)
(if (eq ses-relocate-return 'range)
;; This cell contains a (ses-range X Y) where a cell has been
minrow mincol rowincr colincr))
(ses-set-cell row col 'references newval)
(and (>= row minrow) (>= col mincol)
- (ses-set-cell row col 'symbol
- (ses-create-cell-symbol row col))))))
+ (let ((sym (ses-cell-symbol row col))
+ (xcol (- col colincr)))
+ (if (and
+ sym
+ (>= xrow 0)
+ (>= xcol 0)
+ (null (eq sym
+ (ses-create-cell-symbol xrow xcol))))
+ ;; This is a renamed cell, do not update the cell
+ ;; name, but just update the coordinate property.
+ (put sym 'ses-cell (cons row col))
+ (ses-set-cell row col 'symbol
+ (setq sym (ses-create-cell-symbol row col)))
+ (unless (and (boundp sym) (local-variable-p sym))
+ (set (make-local-variable sym) nil)
+ (put sym 'ses-cell (cons row col)))))) )))
;; Relocate the cell values.
(let (oldval myrow mycol xrow xcol)
(cond
(setq mycol (+ col mincol)
xrow (- myrow rowincr)
xcol (- mycol colincr))
- (if (and (< xrow ses--numrows) (< xcol ses--numcols))
- (setq oldval (ses-cell-value xrow xcol))
- ;; Cell is off the end of the array.
- (setq oldval (symbol-value (ses-create-cell-symbol xrow xcol))))
- (ses-set-cell myrow mycol 'value oldval))))
+ (let ((sym (ses-cell-symbol myrow mycol))
+ (xsym (ses-create-cell-symbol xrow xcol)))
+ ;; Make the value relocation only when if the cell is not
+ ;; a renamed cell. Otherwise this is not needed.
+ (and (eq sym xsym)
+ (ses-set-cell myrow mycol 'value
+ (if (and (< xrow ses--numrows) (< xcol ses--numcols))
+ (ses-cell-value xrow xcol)
+ ;;Cell is off the end of the array
+ (symbol-value xsym))))))))
+
((and (wholenump rowincr) (wholenump colincr))
;; Insertion of rows and/or columns. Run the loop backwards.
(let ((disty (1- ses--numrows))
(makunbound sym)))
(defun ses-aset-with-undo (array idx newval)
- "Like aset, but undoable. Result is t if element has changed"
+ "Like `aset', but undoable.
+Result is t if element has changed."
(unless (equal (aref array idx) newval)
(push `(apply ses-aset-with-undo ,array ,idx
,(aref array idx)) buffer-undo-list)
;;----------------------------------------------------------------------------
(defun ses-load ()
- "Parse the current buffer and sets up buffer-local variables. Does not
-execute cell formulas or print functions."
+ "Parse the current buffer and set up buffer-local variables.
+Does not execute cell formulas or print functions."
(widen)
;; Read our global parameters, which should be a 3-element list.
(goto-char (point-max))
(message "Upgrading from SES-1 file format")))
(or (= ses--file-format 2)
(error "This file needs a newer version of the SES library code"))
- (ses-create-cell-variable-range 0 (1- ses--numrows) 0 (1- ses--numcols))
;; Initialize cell array.
(setq ses--cells (make-vector ses--numrows nil))
(dotimes (row ses--numrows)
(dotimes (row ses--numrows)
(dotimes (col ses--numcols)
(let* ((x (read (current-buffer)))
- (rowcol (ses-sym-rowcol (car-safe (cdr-safe x)))))
+ (sym (car-safe (cdr-safe x))))
(or (and (looking-at "\n")
(eq (car-safe x) 'ses-cell)
- (eq row (car rowcol))
- (eq col (cdr rowcol)))
+ (ses-create-cell-variable sym row col))
(error "Cell-def error"))
(eval x)))
(or (looking-at "\n\n")
;; do the narrowing.
(narrow-to-region (point-min) ses--data-marker)
(setq ses--deferred-narrow nil))
- ;; Update the modeline.
+ ;; Update the mode line.
(let ((oldcell ses--curcell))
(ses-set-curcell)
(unless (eq ses--curcell oldcell)
(ses-jump-safe startcell)))
(defun ses-truncate-cell ()
- "Reprint current cell, but without spillover into any following blank
-cells."
+ "Reprint current cell, but without spillover into any following blank cells."
(interactive "*")
(ses-check-curcell)
(let* ((rowcol (ses-sym-rowcol ses--curcell))
(defun ses-read-printer (prompt default)
"Common code for `ses-read-cell-printer', `ses-read-column-printer', and `ses-read-default-printer'.
-PROMPT should end with \": \". Result is t if operation was cancelled."
+PROMPT should end with \": \". Result is t if operation was canceled."
(barf-if-buffer-read-only)
(if (eq default t)
(setq default "")
(ses-print-cell row col))))
(defun ses-read-column-printer (col newval)
- "Set the printer function for the current column. See
-`ses-read-cell-printer' for input forms."
+ "Set the printer function for the current column.
+See `ses-read-cell-printer' for input forms."
(interactive
(let ((col (cdr (ses-sym-rowcol ses--curcell))))
(ses-check-curcell)
(ses-print-cell row col)))))
(defun ses-read-default-printer (newval)
- "Set the default printer function for cells that have no other. See
-`ses-read-cell-printer' for input forms."
+ "Set the default printer function for cells that have no other.
+See `ses-read-cell-printer' for input forms."
(interactive
(list (ses-read-printer "Default printer: " ses--default-printer)))
(unless (eq newval t)
;;----------------------------------------------------------------------------
(defun ses-insert-row (count)
- "Insert a new row before the current one. With prefix, insert COUNT rows
-before current one."
+ "Insert a new row before the current one.
+With prefix, insert COUNT rows before current one."
(interactive "*p")
(ses-check-curcell 'end)
(or (> count 0) (signal 'args-out-of-range nil))
(ses-goto-print (1- ses--numrows) 0)))
(defun ses-delete-row (count)
- "Delete the current row. With prefix, Deletes COUNT rows starting from the
-current one."
+ "Delete the current row.
+With prefix, deletes COUNT rows starting from the current one."
(interactive "*p")
(ses-check-curcell)
(or (> count 0) (signal 'args-out-of-range nil))
(ses-jump-safe ses--curcell))
(defun ses-delete-column (count)
- "Delete the current column. With prefix, Deletes COUNT columns starting
-from the current one."
+ "Delete the current column.
+With prefix, deletes COUNT columns starting from the current one."
(interactive "*p")
(ses-check-curcell)
(or (> count 0) (signal 'args-out-of-range nil))
(forward-char)))
(defun ses-append-row-jump-first-column ()
- "Insert a new row after current one and jumps to its first column."
+ "Insert a new row after current one and jump to its first column."
(interactive "*")
(ses-check-curcell)
(ses-begin-change)
;; Cut and paste, import and export
;;----------------------------------------------------------------------------
-(defadvice copy-region-as-kill (around ses-copy-region-as-kill
- activate preactivate)
+(defun ses--advice-copy-region-as-kill (crak-fun beg end &rest args)
+ ;; FIXME: Why doesn't it make sense to copy read-only or
+ ;; intangible attributes? They're removed upon yank!
"It doesn't make sense to copy read-only or intangible attributes into the
kill ring. It probably doesn't make sense to copy keymap properties.
We'll assume copying front-sticky properties doesn't make sense, either.
(let ((temp beg))
(setq beg end
end temp)))
- (if (not (and (eq major-mode 'ses-mode)
+ (if (not (and (derived-mode-p 'ses-mode)
(eq (get-text-property beg 'read-only) 'ses)
(eq (get-text-property (1- end) 'read-only) 'ses)))
- ad-do-it ; Normal copy-region-as-kill.
+ (apply crak-fun beg end args) ; Normal copy-region-as-kill.
(kill-new (ses-copy-region beg end))
(if transient-mark-mode
(setq deactivate-mark t))
nil))
+(advice-add 'copy-region-as-kill :around #'ses--advice-copy-region-as-kill)
(defun ses-copy-region (beg end)
"Treat the region as rectangular. Convert the intangible attributes to
line)
(defun ses-kill-override (beg end)
- "Generic override for any commands that kill text. We clear the killed
-cells instead of deleting them."
+ "Generic override for any commands that kill text.
+We clear the killed cells instead of deleting them."
(interactive "r")
(ses-check-curcell 'needrange)
;; For some reason, the text-read-only error is not caught by `delete-region',
(ses-clear-cell row col))
(ses-jump (car ses--curcell)))
-(defadvice yank (around ses-yank activate preactivate)
+(defun ses--advice-yank (yank-fun &optional arg &rest args)
"In SES mode, the yanked text is inserted as cells.
If the text contains 'ses attributes (meaning it went to the kill-ring from a
relative references to neighboring cells. This is best if the formulas
generally refer to other cells within the yanked text. You can use the C-u
prefix to specify insertion without relocation, which is best when the
-formulas refer to cells outsite the yanked text.
+formulas refer to cells outside the yanked text.
When inserting formulas, the text is treated as a string constant if it doesn't
make sense as a sexp or would otherwise be considered a symbol. Use 'sym to
explicitly insert a symbol, or use the C-u prefix to treat all unmarked words
as symbols."
- (if (not (and (eq major-mode 'ses-mode)
+ (if (not (and (derived-mode-p 'ses-mode)
(eq (get-text-property (point) 'keymap) 'ses-mode-print-map)))
- ad-do-it ; Normal non-SES yank.
+ (apply yank-fun arg args) ; Normal non-SES yank.
(ses-check-curcell 'end)
(push-mark (point))
(let ((text (current-kill (cond
arg)))
(if (consp arg)
(exchange-point-and-mark))))
+(advice-add 'yank :around #'ses--advice-yank)
(defun ses-yank-pop (arg)
"Replace just-yanked stretch of killed text with a different stretch.
-This command is allowed only immediately after a `yank' or a `yank-pop', when
-the region contains a stretch of reinserted previously-killed text. We
-replace it with a different stretch of killed text.
+This command is allowed only immediately after a `yank' or a `yank-pop',
+when the region contains a stretch of reinserted previously-killed text.
+We replace it with a different stretch of killed text.
Unlike standard `yank-pop', this function uses `undo' to delete the
previous insertion."
(interactive "*p")
(setq this-command 'yank))
(defun ses-yank-cells (text arg)
- "If the TEXT has a proper set of 'ses attributes, inserts the text as
+ "If the TEXT has a proper set of 'ses attributes, insert the text as
cells, else return nil. The cells are reprinted--the supplied text is
ignored because the column widths, default printer, etc. at yank time might
be different from those at kill-time. ARG is a list to indicate that
(ses-cell-set-formula row col val))))
(defun ses-yank-tsf (text arg)
- "If TEXT contains tabs and/or newlines, treats the tabs as
-column-separators and the newlines as row-separators and inserts the text as
+ "If TEXT contains tabs and/or newlines, treat the tabs as
+column-separators and the newlines as row-separators and insert the text as
cell formulas--else return nil. Treat plain symbols as strings unless ARG
is a list. Ignore a final newline."
(if (or (not (string-match "[\t\n]" text))
t)))
(defun ses-yank-resize (needrows needcols)
- "If this yank will require inserting rows and/or columns, asks for
-confirmation and then inserts them. Result is (row,col) for top left of yank
+ "If this yank will require inserting rows and/or columns, ask for
+confirmation and then insert them. Result is (row,col) for top left of yank
spot, or error signal if user requests cancel."
(ses-begin-change)
(let ((rowcol (if ses--curcell
(ses-export-tab t))
(defun ses-export-tab (want-formulas)
- "Export the current range with tabs between columns and newlines between
-rows. Result is placed in kill ring. The export is values unless
-WANT-FORMULAS is non-nil. Newlines and tabs in the export text are escaped."
+ "Export the current range with tabs between columns and newlines between rows.
+Result is placed in kill ring. The export is values unless WANT-FORMULAS
+is non-nil. Newlines and tabs in the export text are escaped."
(ses-check-curcell 'needrange)
(let ((print-escape-newlines t)
result item)
(ses-reset-header-string))
(defun ses-mark-row ()
- "Marks the entirety of current row as a range."
+ "Mark the entirety of current row as a range."
(interactive)
(ses-check-curcell 'range)
(let ((row (car (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell)))))
(ses-goto-print row 0)))
(defun ses-mark-column ()
- "Marks the entirety of current column as a range."
+ "Mark the entirety of current column as a range."
(interactive)
(ses-check-curcell 'range)
(let ((col (cdr (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell))))
(ses-goto-print row col)))))
(defun ses-renarrow-buffer ()
- "Narrow the buffer so only the print area is visible. Use after \\[widen]."
+ "Narrow the buffer so only the print area is visible.
+Use after \\[widen]."
(interactive)
(setq ses--deferred-narrow t))
(defun ses-sort-column (sorter &optional reverse)
- "Sorts the range by a specified column. With prefix, sorts in
-REVERSE order."
+ "Sort the range by a specified column.
+With prefix, sorts in REVERSE order."
(interactive "*sSort column: \nP")
(ses-check-curcell 'needrange)
(let ((min (ses-sym-rowcol (car ses--curcell)))
(ses-sort-column (ses-column-letter col) reverse))))
(defun ses-insert-range ()
- "Inserts into minibuffer the list of cells currently highlighted in the
+ "Insert into minibuffer the list of cells currently highlighted in the
spreadsheet."
(interactive "*")
(let (x)
(insert (substring (prin1-to-string (nreverse x)) 1 -1))))
(defun ses-insert-ses-range ()
- "Inserts \"(ses-range x y)\" in the minibuffer to represent the currently
+ "Insert \"(ses-range x y)\" in the minibuffer to represent the currently
highlighted range in the spreadsheet."
(interactive "*")
(let (x)
(mouse-set-point event)
(ses-insert-ses-range))
+(defun ses-replace-name-in-formula (formula old-name new-name)
+ (let ((new-formula formula))
+ (unless (and (consp formula)
+ (eq (car-safe formula) 'quote))
+ (while formula
+ (let ((elt (car-safe formula)))
+ (cond
+ ((consp elt)
+ (setcar formula (ses-replace-name-in-formula elt old-name new-name)))
+ ((and (symbolp elt)
+ (eq (car-safe formula) old-name))
+ (setcar formula new-name))))
+ (setq formula (cdr formula))))
+ new-formula))
+
+(defun ses-rename-cell (new-name &optional cell)
+ "Rename current cell."
+ (interactive "*SEnter new name: ")
+ (or
+ (and (local-variable-p new-name)
+ (ses-is-cell-sym-p new-name)
+ (error "Already a cell name"))
+ (and (boundp new-name)
+ (null (yes-or-no-p (format "`%S' is already bound outside this buffer, continue? "
+ new-name)))
+ (error "Already a bound cell name")))
+ (let* (curcell
+ (sym (if (ses-cell-p cell)
+ (ses-cell-symbol cell)
+ (setq cell nil
+ curcell t)
+ (ses-check-curcell)
+ ses--curcell))
+ (rowcol (ses-sym-rowcol sym))
+ (row (car rowcol))
+ (col (cdr rowcol))
+ new-rowcol old-name)
+ (setq cell (or cell (ses-get-cell row col))
+ old-name (ses-cell-symbol cell)
+ new-rowcol (ses-decode-cell-symbol (symbol-name new-name)))
+ (if new-rowcol
+ (if (equal new-rowcol rowcol)
+ (put new-name 'ses-cell rowcol)
+ (error "Not a valid name for this cell location"))
+ (setq ses--named-cell-hashmap (or ses--named-cell-hashmap (make-hash-table :test 'eq)))
+ (put new-name 'ses-cell :ses-named)
+ (puthash new-name rowcol ses--named-cell-hashmap))
+ (push `(ses-rename-cell ,old-name ,cell) buffer-undo-list)
+ ;; replace name by new name in formula of cells refering to renamed cell
+ (dolist (ref (ses-cell-references cell))
+ (let* ((x (ses-sym-rowcol ref))
+ (xcell (ses-get-cell (car x) (cdr x))))
+ (ses-cell-formula-aset xcell
+ (ses-replace-name-in-formula
+ (ses-cell-formula xcell)
+ sym
+ new-name))))
+ ;; replace name by new name in reference list of cells to which renamed cell refers to
+ (dolist (ref (ses-formula-references (ses-cell-formula cell)))
+ (let* ((x (ses-sym-rowcol ref))
+ (xcell (ses-get-cell (car x) (cdr x))))
+ (ses-cell-references-aset xcell
+ (cons new-name (delq sym
+ (ses-cell-references xcell))))))
+ (push new-name ses--renamed-cell-symb-list)
+ (set new-name (symbol-value sym))
+ (aset cell 0 new-name)
+ (makunbound sym)
+ (and curcell (setq ses--curcell new-name))
+ (let* ((pos (point))
+ (inhibit-read-only t)
+ (col (current-column))
+ (end (save-excursion
+ (move-to-column (1+ col))
+ (if (eolp)
+ (+ pos (ses-col-width col) 1)
+ (point)))))
+ (put-text-property pos end 'intangible new-name))
+ ;; update mode line
+ (setq mode-line-process (list " cell "
+ (symbol-name new-name)))
+ (force-mode-line-update)))
;;----------------------------------------------------------------------------
;; Checking formulas for safety
;;----------------------------------------------------------------------------
(defun ses-safe-printer (printer)
- "Returns PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
+ "Return PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
(if (or (stringp printer)
(stringp (car-safe printer))
(not printer)
'ses-unsafe))
(defun ses-safe-formula (formula)
- "Returns FORMULA if safe, or the substitute formula *unsafe* otherwise."
+ "Return FORMULA if safe, or the substitute formula *unsafe* otherwise."
(if (ses-warn-unsafe formula 'unsafep)
formula
`(ses-unsafe ',formula)))
(defun ses-warn-unsafe (formula checker)
- "Applies CHECKER to FORMULA. If result is non-nil, asks user for
-confirmation about FORMULA, which might be unsafe. Returns t if formula
-is safe or user allows execution anyway. Always returns t if
-`safe-functions' is t."
+ "Apply CHECKER to FORMULA.
+If result is non-nil, asks user for confirmation about FORMULA,
+which might be unsafe. Returns t if formula is safe or user allows
+execution anyway. Always returns t if `safe-functions' is t."
(if (eq safe-functions t)
t
(setq checker (funcall checker formula))
;;----------------------------------------------------------------------------
(defun ses--clean-! (&rest x)
- "Clean by delq list X from any occurrence of `nil' or `*skip*'."
+ "Clean by `delq' list X from any occurrence of `nil' or `*skip*'."
(delq nil (delq '*skip* x)))
(defun ses--clean-_ (x y)
"Clean list X by replacing by Y any occurrence of `nil' or `*skip*'.
-This will change X by making setcar on its cons cells."
+This will change X by making `setcar' on its cons cells."
(let ((ret x) ret-elt)
(while ret
(setq ret-elt (car ret))
x)
(defmacro ses-range (from to &rest rest)
- "Expands to a list of cell-symbols for the range going from
+ "Expand to a list of cell-symbols for the range going from
FROM up to TO. The range automatically expands to include any
new row or column inserted into its middle. The SES library code
specifically looks for the symbol `ses-range', so don't create an
is read and how it is formatted.
In the sequel we assume that cells A1, B1, A2 B2 have respective values
-1 2 3 and 4 for examplication.
+1 2 3 and 4.
Readout direction is specified by a `>v', '`>^', `<v', `<^',
-`v>', `v<', `^>', `^<' flag. For historical reasons, in absence
-of such a flag, a default direction of `^<' is assumed. This
+`v>', `v<', `^>', `^<' flag. For historical reasons, in absence
+of such a flag, a default direction of `^<' is assumed. This
way `(ses-range A1 B2 ^>)' will evaluate to `(1 3 2 4)',
while `(ses-range A1 B2 >^)' will evaluate to (3 4 1 2).
A `!' flag will remove all cells whose value is nil or `*skip*'.
A `_' flag will replace nil or `*skip*' by the value following
-the `_' flag. If the `_' flag is the last argument, then they are
+the `_' flag. If the `_' flag is the last argument, then they are
replaced by integer 0.
A `*', `*1' or `*2' flag will vectorize the range in the sense of
-Calc. See info node `(Calc) Top'. Flag `*' will output either a
+Calc. See info node `(Calc) Top'. Flag `*' will output either a
vector or a matrix depending on the number of rows, `*1' will
flatten the result to a one row vector, and `*2' will make a
matrix whatever the number of rows.
-Warning: interaction with Calc is expermimental and may produce
-confusing results if you are not aware of Calc data format. Use
-`math-format-value' as a printer for Calc objects."
+Warning: interaction with Calc is experimental and may produce
+confusing results if you are not aware of Calc data format.
+Use `math-format-value' as a printer for Calc objects."
(let (result-row
result
(prev-row -1)
(push result-row result)
(while rest
(let ((x (pop rest)))
- (case x
- ((>v) (setq transpose nil reorient-x nil reorient-y nil))
- ((>^)(setq transpose nil reorient-x nil reorient-y t))
- ((<^)(setq transpose nil reorient-x t reorient-y t))
- ((<v)(setq transpose nil reorient-x t reorient-y nil))
- ((v>)(setq transpose t reorient-x nil reorient-y t))
- ((^>)(setq transpose t reorient-x nil reorient-y nil))
- ((^<)(setq transpose t reorient-x t reorient-y nil))
- ((v<)(setq transpose t reorient-x t reorient-y t))
- ((* *2 *1) (setq vectorize x))
- ((!) (setq clean 'ses--clean-!))
- ((_) (setq clean `(lambda (&rest x) (ses--clean-_ x ,(if rest (pop rest) 0)))))
- (t
+ (pcase x
+ (`>v (setq transpose nil reorient-x nil reorient-y nil))
+ (`>^ (setq transpose nil reorient-x nil reorient-y t))
+ (`<^ (setq transpose nil reorient-x t reorient-y t))
+ (`<v (setq transpose nil reorient-x t reorient-y nil))
+ (`v> (setq transpose t reorient-x nil reorient-y t))
+ (`^> (setq transpose t reorient-x nil reorient-y nil))
+ (`^< (setq transpose t reorient-x t reorient-y nil))
+ (`v< (setq transpose t reorient-x t reorient-y t))
+ ((or `* `*2 `*1) (setq vectorize x))
+ (`! (setq clean 'ses--clean-!))
+ (`_ (setq clean `(lambda (&rest x)
+ (ses--clean-_ x ,(if rest (pop rest) 0)))))
+ (_
(cond
; shorthands one row
((and (null (cddr result)) (memq x '(> <)))
(setq iter (cdr iter))))
(setq result ret)))
- (flet ((vectorize-*1
- (clean result)
- (cons clean (cons (quote 'vec) (apply 'append result))))
- (vectorize-*2
- (clean result)
- (cons clean (cons (quote 'vec) (mapcar (lambda (x)
- (cons clean (cons (quote 'vec) x)))
- result)))))
- (case vectorize
- ((nil) (cons clean (apply 'append result)))
- ((*1) (vectorize-*1 clean result))
- ((*2) (vectorize-*2 clean result))
- ((*) (if (cdr result)
- (vectorize-*2 clean result)
- (vectorize-*1 clean result)))))))
+ (cl-flet ((vectorize-*1
+ (clean result)
+ (cons clean (cons (quote 'vec) (apply 'append result))))
+ (vectorize-*2
+ (clean result)
+ (cons clean (cons (quote 'vec)
+ (mapcar (lambda (x)
+ (cons clean (cons (quote 'vec) x)))
+ result)))))
+ (pcase vectorize
+ (`nil (cons clean (apply 'append result)))
+ (`*1 (vectorize-*1 clean result))
+ (`*2 (vectorize-*2 clean result))
+ (`* (funcall (if (cdr result)
+ #'vectorize-*2
+ #'vectorize-*1)
+ clean result))))))
(defun ses-delete-blanks (&rest args)
"Return ARGS reversed, with the blank elements (nil and *skip*) removed."
(/ (float (apply '+ list)) (length list)))
(defmacro ses-select (fromrange test torange)
- "Select cells in FROMRANGE that are `equal' to TEST. For each match, return
-the corresponding cell from TORANGE. The ranges are macroexpanded but not
-evaluated so they should be either (ses-range BEG END) or (list ...). The
-TEST is evaluated."
+ "Select cells in FROMRANGE that are `equal' to TEST.
+For each match, return the corresponding cell from TORANGE.
+The ranges are macroexpanded but not evaluated so they should be
+either (ses-range BEG END) or (list ...). The TEST is evaluated."
(setq fromrange (cdr (macroexpand fromrange))
torange (cdr (macroexpand torange))
test (eval test))
(defvar col)
(defun ses-center (value &optional span fill)
- "Print VALUE, centered within column. FILL is the fill character for
-centering (default = space). SPAN indicates how many additional rightward
-columns to include in width (default = 0)."
+ "Print VALUE, centered within column.
+FILL is the fill character for centering (default = space).
+SPAN indicates how many additional rightward columns to include
+in width (default = 0)."
(let ((printer (or (ses-col-printer col) ses--default-printer))
(width (ses-col-width col))
half)
(defun ses-center-span (value &optional fill)
"Print VALUE, centered within the span that starts in the current column
-and continues until the next nonblank column. FILL specifies the fill
-character (default = space)."
+and continues until the next nonblank column.
+FILL specifies the fill character (default = space)."
(let ((end (1+ col)))
(while (and (< end ses--numcols)
(memq (ses-cell-value row end) '(nil *skip*)))
(ses-center value (- end col 1) fill)))
(defun ses-dashfill (value &optional span)
- "Print VALUE centered using dashes. SPAN indicates how many rightward
-columns to include in width (default = 0)."
+ "Print VALUE centered using dashes.
+SPAN indicates how many rightward columns to include in width (default = 0)."
(ses-center value span ?-))
(defun ses-dashfill-span (value)
(ses-center-span value ?~))
(defun ses-unsafe (value)
- "Substitute for an unsafe formula or printer"
+ "Substitute for an unsafe formula or printer."
(error "Unsafe formula or printer"))
;;All standard printers are safe, including ses-unsafe!
(defun ses-unload-function ()
"Unload the Simple Emacs Spreadsheet."
- (dolist (fun '(copy-region-as-kill yank))
- (ad-remove-advice fun 'around (intern (concat "ses-" (symbol-name fun))))
- (ad-update fun))
- ;; continue standard unloading
+ (advice-remove 'yank #'ses--advice-yank)
+ (advice-remove 'copy-region-as-kill #'ses--advice-copy-region-as-kill)
+ ;; Continue standard unloading.
nil)
(provide 'ses)