;;; ses.el -- Simple Emacs Spreadsheet -*- coding: utf-8 -*-
-;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2012 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Maintainer: Vincent Belaïche <vincentb1@users.sourceforge.net>
;;; 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--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.")
"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
(make-local-variable sym)))))
(defun ses-create-cell-variable (sym row col)
- "Create a buffer-local variable for cell with symbol
-SYM at position ROW COL. Return nil in case of failure."
+ "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)
(put sym 'ses-cell (cons row col))))
(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))
(defcustom ses-self-reference-early-detection nil
"True if cycle detection is early for cells that refer to themselves."
+ :version "24.1"
:type 'boolean
:group 'ses)
;; 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))
(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
;; 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)
(setq formula (cdr formula))))
new-formula))
-(defun ses-rename-cell (new-name)
+(defun ses-rename-cell (new-name &optional cell)
"Rename current cell."
(interactive "*SEnter new name: ")
- (ses-check-curcell)
- (or
- (and (local-variable-p new-name)
- (ses-sym-rowcol 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* ((rowcol (ses-sym-rowcol ses--curcell))
- (cell (ses-get-cell (car rowcol) (cdr rowcol))))
- (dolist (reference (ses-cell-references (car rowcol) (cdr rowcol)))
- (let* ((rowcol (ses-sym-rowcol reference))
- (cell (ses-get-cell (car rowcol) (cdr rowcol))))
- (ses-cell-set-formula (car rowcol)
- (cdr rowcol)
- (ses-replace-name-in-formula
- (ses-cell-formula cell)
- ses--curcell
- new-name))))
+ (and (local-variable-p new-name)
+ (ses-sym-rowcol new-name)
+ ;; this test is needed because ses-cell property of deleted cells
+ ;; is not deleted in case of subsequent undo
+ (memq new-name ses--renamed-cell-symb-list)
+ (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* ((sym (if (ses-cell-p cell)
+ (ses-cell-symbol cell)
+ (setq cell nil)
+ (ses-check-curcell)
+ ses--curcell))
+ (rowcol (ses-sym-rowcol sym))
+ (row (car rowcol))
+ (col (cdr rowcol)))
+ (setq cell (or cell (ses-get-cell row col)))
+ (push `(ses-rename-cell ,(ses-cell-symbol cell) ,cell) buffer-undo-list)
(put new-name 'ses-cell rowcol)
- (set new-name (symbol-value ses--curcell))
+ ;; 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)
- (put ses--curcell 'ses-cell nil)
- (makunbound ses--curcell)
- (setq ses--curcell new-name)
+ (put sym 'ses-cell nil)
+ (makunbound sym)
+ (setq sym new-name)
(let* ((pos (point))
(inhibit-read-only t)
(col (current-column))
(if (eolp)
(+ pos (ses-col-width col) 1)
(point)))))
- (put-text-property pos end 'intangible new-name))) )
-
+ (put-text-property pos end 'intangible new-name))
+ ;; update mode line
+ (setq mode-line-process (list " cell "
+ (symbol-name sym)))
+ (force-mode-line-update)))
;;----------------------------------------------------------------------------
;; Checking formulas for safety
(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."