;;; ses.el -- Simple Emacs Spreadsheet -*- coding: utf-8 -*-
-;; Copyright (C) 2002-2012 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>
;;; Code:
(require 'unsafep)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;----------------------------------------------------------------------------
"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
;; 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)
- ;; 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* ((rowcol (ses-sym-rowcol ses--curcell))
- (cell (ses-get-cell (car rowcol) (cdr rowcol))))
+ (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)
- (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))))
+ ;; 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 ses--curcell))
+ (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."