X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/33017fafd17d722e82a268e9b272f27df261e09d..39a0786e1b37704c54dc1cce142b495856c2b13e:/lisp/ses.el diff --git a/lisp/ses.el b/lisp/ses.el index 876537413c..552c09bb47 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -1,6 +1,6 @@ ;;; 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 ;; Maintainer: Vincent Belaïche @@ -56,7 +56,7 @@ ;;; Code: (require 'unsafep) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;---------------------------------------------------------------------------- @@ -362,6 +362,10 @@ when to emit a progress message.") "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)) @@ -371,6 +375,19 @@ when to emit a progress message.") 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 @@ -1253,11 +1270,9 @@ when the width of cell (ROW,COL) has changed." ;; 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)) @@ -1520,7 +1535,7 @@ if the range was altered." (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 @@ -1933,7 +1948,7 @@ narrows the buffer now." ;; 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) @@ -3193,39 +3208,52 @@ highlighted range in the spreadsheet." (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)) @@ -3234,7 +3262,11 @@ highlighted range in the spreadsheet." (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 @@ -3345,19 +3377,20 @@ Use `math-format-value' as a printer for Calc objects." (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)) - (()(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)) + (` (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 '(> <))) @@ -3380,21 +3413,23 @@ Use `math-format-value' as a printer for Calc objects." (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."