X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e9c8c8e7e6520459bfa9a7b4c4a9f4e35abfeaea..1eedd2f11f54db9ccc9a9b6cae639f65750b8baf:/lisp/ses.el diff --git a/lisp/ses.el b/lisp/ses.el index a5cc6bf657..e4124de9fb 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -1,6 +1,6 @@ -;;; ses.el -- Simple Emacs Spreadsheet +;;; ses.el -- Simple Emacs Spreadsheet -*- coding: utf-8 -*- -;; Copyright (C) 2002,03,04 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Author: Jonathan Yavner ;; Maintainer: Jonathan Yavner @@ -20,10 +20,13 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: ;;; To-do list: + ;; * Use $ or … for truncated fields ;; * Add command to make a range of columns be temporarily invisible. ;; * Allow paste of one cell to a range of cells -- copy formula to each. @@ -35,15 +38,18 @@ ;; * Left-margin column for row number. ;; * Move a row by dragging its number in the left-margin. + +;;; Code: + (require 'unsafep) -;;;---------------------------------------------------------------------------- -;;;; User-customizable variables -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; User-customizable variables +;;---------------------------------------------------------------------------- (defgroup ses nil - "Simple Emacs Spreadsheet" + "Simple Emacs Spreadsheet." :group 'applications :prefix "ses-" :version "21.1") @@ -66,8 +72,9 @@ function)) (defcustom ses-after-entry-functions '(forward-char) - "Things to do after entering a value into a cell. An abnormal hook that -usually runs a cursor-movement function. Each function is called with ARG=1." + "Things to do after entering a value into a cell. +An abnormal hook that usually runs a cursor-movement function. +Each function is called with ARG=1." :group 'ses :type 'hook :options '(forward-char backward-char next-line previous-line)) @@ -78,9 +85,9 @@ usually runs a cursor-movement function. Each function is called with ARG=1." :type 'hook) -;;;---------------------------------------------------------------------------- -;;;; Global variables and constants -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Global variables and constants +;;---------------------------------------------------------------------------- (defvar ses-read-cell-history nil "List of formulas that have been typed in.") @@ -92,7 +99,7 @@ usually runs a cursor-movement function. Each function is called with ARG=1." "Context menu when mouse-3 is used on the header-line in an SES buffer." '("SES header row" ["Set current row" ses-set-header-row t] - ["Unset row" ses-unset-header-row (> header-row 0)])) + ["Unset row" ses-unset-header-row (> ses--header-row 0)])) (defconst ses-mode-map (let ((keys `("\C-c\M-\C-l" ses-reconstruct-all @@ -208,14 +215,14 @@ usually runs a cursor-movement function. Each function is called with ARG=1." map)) (defconst ses-print-data-boundary "\n\014\n" - "Marker string denoting the boundary between print area and data area") + "Marker string denoting the boundary between print area and data area.") (defconst ses-initial-global-parameters "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n" - "Initial contents for the three-element list at the bottom of the data area") + "Initial contents for the three-element list at the bottom of the data area.") (defconst ses-initial-file-trailer - ";;; Local Variables:\n;;; mode: ses\n;;; End:\n" + ";; Local Variables:\n;; mode: ses\n;; End:\n" "Initial contents for the file-trailer area at the bottom of the file.") (defconst ses-initial-file-contents @@ -231,10 +238,6 @@ usually runs a cursor-movement function. Each function is called with ARG=1." ses-initial-file-trailer) "The initial contents of an empty spreadsheet.") -(defconst ses-cell-size 4 - "A cell consists of a SYMBOL, a FORMULA, a PRINTER-function, and a list of -REFERENCES.") - (defconst ses-paramlines-plist '(ses--col-widths 2 ses--col-printers 3 ses--default-printer 4 ses--header-row 5 ses--file-format 8 ses--numrows 9 @@ -271,13 +274,13 @@ default printer and then modify its output.") (set x nil))) -;;; -;;; "Side-effect variables". They are set in one function, altered in -;;; another as a side effect, then read back by the first, as a way of -;;; passing back more than one value. These declarations are just to make -;;; the compiler happy, and to conform to standard Emacs-Lisp practice (I -;;; think the make-local-variable trick above is cleaner). -;;; +;; +;; "Side-effect variables". They are set in one function, altered in +;; another as a side effect, then read back by the first, as a way of +;; passing back more than one value. These declarations are just to make +;; the compiler happy, and to conform to standard Emacs-Lisp practice (I +;; think the make-local-variable trick above is cleaner). +;; (defvar ses-relocate-return nil "Set by `ses-relocate-formula' and `ses-relocate-range', read by @@ -296,14 +299,19 @@ encountered an error during printing. Nil otherwise.") when to emit a progress message.") -;;;---------------------------------------------------------------------------- -;;;; Macros -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Macros +;;---------------------------------------------------------------------------- (defmacro ses-get-cell (row col) "Return the cell structure that stores information about cell (ROW,COL)." `(aref (aref ses--cells ,row) ,col)) +;; We might want to use defstruct here, but cells are explicitly used as +;; arrays in ses-set-cell, so we'd need to fix this first. --Stef +(defsubst ses-make-cell (&optional symbol formula printer references) + (vector symbol formula printer references)) + (defmacro ses-cell-symbol (row &optional col) "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value. (0,0) => A1." `(aref ,(if col `(ses-get-cell ,row ,col) row) 0)) @@ -355,7 +363,7 @@ PRINTER are deferred until first use." (setq printer `(ses-safe-printer ,printer))) (aset (aref ses--cells (car rowcol)) (cdr rowcol) - (vector sym formula printer references))) + (ses-make-cell sym formula printer references))) (set sym value) sym) @@ -368,7 +376,7 @@ macro to prevent propagate-on-load viruses." ;;print area (excluding the terminating newline) (setq ses--col-widths widths ses--linewidth (apply '+ -1 (mapcar '1+ widths)) - ses--blank-line (concat (make-string ses--linewidth ? ) "\n")) + ses--blank-line (concat (make-string ses--linewidth ?\s) "\n")) t) (defmacro ses-column-printers (printers) @@ -397,26 +405,6 @@ for safety. This is a macro to prevent propagate-on-load viruses." (setq ses--header-row row) t) -(defmacro ses-dotimes-msg (spec msg &rest body) - "(ses-dotimes-msg (VAR LIMIT) MSG BODY...): Like `dotimes', but -a message is emitted using MSG every second or so during the loop." - (let ((msgvar (make-symbol "msg")) - (limitvar (make-symbol "limit")) - (var (car spec)) - (limit (cadr spec))) - `(let ((,limitvar ,limit) - (,msgvar ,msg)) - (setq ses-start-time (float-time)) - (message ,msgvar) - (setq ,msgvar (concat ,msgvar " (%d%%)")) - (dotimes (,var ,limitvar) - (ses-time-check ,msgvar '(/ (* ,var 100) ,limitvar)) - ,@body) - (message nil)))) - -(put 'ses-dotimes-msg 'lisp-indent-function 2) -(def-edebug-spec ses-dotimes-msg ((symbolp form) form body)) - (defmacro ses-dorange (curcell &rest body) "Execute BODY repeatedly, with the variables `row' and `col' set to each cell in the range specified by CURCELL. The range is available in the @@ -455,9 +443,9 @@ the same value." form) -;;;---------------------------------------------------------------------------- -;;;; Utility functions -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Utility functions +;;---------------------------------------------------------------------------- (defun ses-vector-insert (array idx new) "Create a new vector which is one larger than ARRAY and has NEW inserted @@ -527,7 +515,7 @@ for this spreadsheet." (defun ses-create-cell-variable-range (minrow maxrow mincol maxcol) "Create buffer-local variables for cells. This is undoable." - (push `(ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) + (push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) buffer-undo-list) (let (sym xrow xcol) (dotimes (row (1+ (- maxrow minrow))) @@ -538,9 +526,9 @@ for this spreadsheet." (put sym 'ses-cell (cons xrow xcol)) (make-local-variable sym))))) -;;;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. +;;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. (defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol) "Destroy buffer-local variables for cells. This is undoable." (let (sym) @@ -548,16 +536,16 @@ for this spreadsheet." (dotimes (col (1+ (- maxcol mincol))) (setq sym (ses-create-cell-symbol (+ row minrow) (+ col mincol))) (if (boundp sym) - (push `(ses-set-with-undo ,sym ,(symbol-value sym)) + (push `(apply ses-set-with-undo ,sym ,(symbol-value sym)) buffer-undo-list)) (kill-local-variable sym)))) - (push `(ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) + (push `(apply ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) buffer-undo-list)) (defun ses-reset-header-string () "Flags the header string for update. Upon undo, the header string will be updated again." - (push '(ses-reset-header-string) buffer-undo-list) + (push '(apply ses-reset-header-string) buffer-undo-list) (setq ses--header-hscroll -1)) ;;Split this code off into a function to avoid coverage-testing difficulties @@ -570,9 +558,9 @@ and (eval ARG) and reset `ses-start-time' to the current time." nil) -;;;---------------------------------------------------------------------------- -;;;; The cells -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; The cells +;;---------------------------------------------------------------------------- (defun ses-set-cell (row col field val) "Install VAL as the contents for field FIELD (named by a quoted symbol) of @@ -634,8 +622,7 @@ processing for the current keystroke, unless the new value is the same as the old and FORCE is nil." (let ((cell (ses-get-cell row col)) formula-error printer-error) - (let ((symbol (ses-cell-symbol cell)) - (oldval (ses-cell-value cell)) + (let ((oldval (ses-cell-value cell)) (formula (ses-cell-formula cell)) newval) (if (eq (car-safe formula) 'ses-safe-formula) @@ -717,17 +704,17 @@ if the cell's value is unchanged if FORCE is nil." (goto-char pos))) -;;;---------------------------------------------------------------------------- -;;;; The print area -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; The print area +;;---------------------------------------------------------------------------- (defun ses-in-print-area () "Returns t if point is in print area of spreadsheet." (eq (get-text-property (point) 'keymap) 'ses-mode-print-map)) -;;;We turn off point-motion-hooks and explicitly position the cursor, in case -;;;the intangible properties have gotten screwed up (e.g., when -;;;ses-goto-print is called during a recursive ses-print-cell). +;;We turn off point-motion-hooks and explicitly position the cursor, in case +;;the intangible properties have gotten screwed up (e.g., when +;;ses-goto-print is called during a recursive ses-print-cell). (defun ses-goto-print (row col) "Move point to print area for cell (ROW,COL)." (let ((inhibit-point-motion-hooks t)) @@ -772,11 +759,11 @@ argument is 'range. A single cell is appropriate unless some argument is (error "Need a range")))) (defun ses-print-cell (row col) - "Format and print the value of cell (ROW,COL) to the print area, using the -cell's printer function. If the cell's new print form is too wide, it will -spill over into the following cell, but will not run off the end of the row -or overwrite the next non-nil field. Result is nil for normal operation, or -the error signal if the printer function failed and the cell was formatted + "Format and print the value of cell (ROW,COL) to the print area. +Use the cell's printer function. If the cell's new print form is too wide, +it will spill over into the following cell, but will not run off the end of the +row or overwrite the next non-nil field. Result is nil for normal operation, +or the error signal if the printer function failed and the cell was formatted with \"%s\". If the cell's value is *skip*, nothing is printed because the preceding cell has spilled over." (catch 'ses-print-cell @@ -811,7 +798,7 @@ preceding cell has spilled over." (cond ((< len width) ;;Fill field to length with spaces - (setq len (make-string (- width len) ? ) + (setq len (make-string (- width len) ?\s) text (if (eq ses-call-printer-return t) (concat text len) (concat len text)))) @@ -829,7 +816,7 @@ preceding cell has spilled over." maxcol (1+ maxcol))) (if (<= len maxwidth) ;;Fill to complete width of all the fields spanned - (setq text (concat text (make-string (- maxwidth len) ? ))) + (setq text (concat text (make-string (- maxwidth len) ?\s))) ;;Not enough room to end of line or next non-nil field. Truncate ;;if string or decimal; otherwise fill with error indicator (setq sig `(error "Too wide" ,text)) @@ -891,7 +878,7 @@ preceding cell has spilled over." lambda of one argument) on VALUE. Result is the 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 -printer signalled one (and \"%s\" is used as the default printer), else nil." +printer signaled one (and \"%s\" is used as the default printer), else nil." (setq ses-call-printer-return nil) (unless value (setq value "")) @@ -919,12 +906,12 @@ printer signalled one (and \"%s\" is used as the default printer), else nil." COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind inhibit-quit to t." (let ((inhibit-read-only t) - (blank (if (> change 0) (make-string change ? ))) + (blank (if (> change 0) (make-string change ?\s))) (at-end (= col ses--numcols))) (ses-set-with-undo 'ses--linewidth (+ ses--linewidth change)) ;;ses-set-with-undo always returns t for strings. (1value (ses-set-with-undo 'ses--blank-line - (concat (make-string ses--linewidth ? ) "\n"))) + (concat (make-string ses--linewidth ?\s) "\n"))) (dotimes (row ses--numrows) (ses-goto-print row col) (when at-end @@ -948,16 +935,18 @@ cell (ROW,COL) has changed." (ses-print-cell (car rowcol) (cdr rowcol))))) -;;;---------------------------------------------------------------------------- -;;;; The data area -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; The data area +;;---------------------------------------------------------------------------- + +(defun ses-narrowed-p () (/= (- (point-max) (point-min)) (buffer-size))) (defun ses-goto-data (def &optional col) "Move point to data area for (DEF,COL). If DEF is a row number, COL is the column number for a data cell -- otherwise DEF is one of the symbols ses--col-widths, ses--col-printers, ses--default-printer, ses--numrows, or ses--numcols." - (if (< (point-max) (buffer-size)) + (if (ses-narrowed-p) (setq ses--deferred-narrow t)) (widen) (let ((inhibit-point-motion-hooks t)) ;In case intangible attrs are wrong @@ -971,10 +960,9 @@ ses--default-printer, ses--numrows, or ses--numcols." (forward-line (+ (* ses--numrows (+ ses--numcols 2)) def))))) (defun ses-set-parameter (def value &optional elem) - "Sets parameter DEF to VALUE (with undo) and writes the value to the data -area. See `ses-goto-data' for meaning of DEF. Newlines in the data -are escaped. If ELEM is specified, it is the array subscript within DEF to -be set to VALUE." + "Set parameter DEF to VALUE (with undo) and write the value to the data area. +See `ses-goto-data' for meaning of DEF. Newlines in the data are escaped. +If ELEM is specified, it is the array subscript within DEF to be set to VALUE." (save-excursion ;;We call ses-goto-data early, using the old values of numrows and ;;numcols in case one of them is being changed. @@ -983,7 +971,7 @@ be set to VALUE." (ses-aset-with-undo (symbol-value def) elem value) (ses-set-with-undo def value)) (let ((inhibit-read-only t) - (fmt (plist-get '(ses--column-widths "(ses-column-widths %S)" + (fmt (plist-get '(ses--col-widths "(ses-column-widths %S)" ses--col-printers "(ses-column-printers %S)" ses--default-printer "(ses-default-printer %S)" ses--header-row "(ses-header-row %S)" @@ -995,8 +983,8 @@ be set to VALUE." (insert (format fmt (symbol-value def)))))) (defun ses-write-cells () - "`ses--deferred-write' is a list of (ROW,COL) for cells to be written from -buffer-local variables to data area. Newlines in the data are escaped." + "Write cells in `ses--deferred-write' from local variables to data area. +Newlines in the data are escaped." (let* ((inhibit-read-only t) (print-escape-newlines t) rowcol row col cell sym formula printer text) @@ -1041,9 +1029,9 @@ buffer-local variables to data area. Newlines in the data are escaped." (message " ")))) -;;;---------------------------------------------------------------------------- -;;;; Formula relocation -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Formula relocation +;;---------------------------------------------------------------------------- (defun ses-formula-references (formula &optional result-so-far) "Produce a list of symbols for cells that this formula's value @@ -1210,7 +1198,8 @@ the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR to each symbol." (let (reform) (let (mycell newval) - (ses-dotimes-msg (row ses--numrows) "Relocating formulas..." + (dotimes-with-progress-reporter + (row ses--numrows) "Relocating formulas..." (dotimes (col ses--numcols) (setq ses-relocate-return nil mycell (ses-get-cell row col) @@ -1238,7 +1227,8 @@ to each symbol." (cond ((and (<= rowincr 0) (<= colincr 0)) ;;Deletion of rows and/or columns - (ses-dotimes-msg (row (- ses--numrows minrow)) "Relocating variables..." + (dotimes-with-progress-reporter + (row (- ses--numrows minrow)) "Relocating variables..." (setq myrow (+ row minrow)) (dotimes (col (- ses--numcols mincol)) (setq mycol (+ col mincol) @@ -1254,7 +1244,8 @@ to each symbol." (let ((disty (1- ses--numrows)) (distx (1- ses--numcols)) myrow mycol) - (ses-dotimes-msg (row (- ses--numrows minrow)) "Relocating variables..." + (dotimes-with-progress-reporter + (row (- ses--numrows minrow)) "Relocating variables..." (setq myrow (- disty row)) (dotimes (col (- ses--numcols mincol)) (setq mycol (- distx col) @@ -1284,42 +1275,29 @@ to each symbol." (message nil)))) -;;;---------------------------------------------------------------------------- -;;;; Undo control -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Undo control +;;---------------------------------------------------------------------------- + +;; This should be unnecessary, because the feature is now built in. (defadvice undo-more (around ses-undo-more activate preactivate) - "Define a meaning for conses in buffer-undo-list whose car is a symbol -other than t or nil. To undo these, apply the car--a function--to the -cdr--its arglist." - (let ((ses-count (ad-get-arg 0))) - (catch 'undo - (dolist (ses-x pending-undo-list) - (unless ses-x - ;;End of undo boundary - (setq ses-count (1- ses-count)) - (if (<= ses-count 0) - ;;We've seen enough boundaries - stop undoing - (throw 'undo nil))) - (and (consp ses-x) (symbolp (car ses-x)) (fboundp (car ses-x)) - ;;Undo using apply - (apply (car ses-x) (cdr ses-x))))) - (if (not (eq major-mode 'ses-mode)) + "For SES mode, allow undo outside of narrowed buffer range." + (if (not (eq major-mode 'ses-mode)) + ad-do-it + ;;Here is some extra code for SES mode. + (setq ses--deferred-narrow + (or ses--deferred-narrow (ses-narrowed-p))) + (widen) + (condition-case x ad-do-it - ;;Here is some extra code for SES mode. - (setq ses--deferred-narrow - (or ses--deferred-narrow (< (point-max) (buffer-size)))) - (widen) - (condition-case x - ad-do-it - (error - ;;Restore narrow if appropriate - (ses-command-hook) - (signal (car x) (cdr x))))))) + (error + ;;Restore narrow if appropriate + (ses-command-hook) + (signal (car x) (cdr x)))))) (defun ses-begin-change () - "For undo, remember current buffer-position before we start changing hidden -stuff." + "For undo, remember point before we start changing hidden stuff." (let ((inhibit-read-only t)) (insert-and-inherit "X") (delete-region (1- (point)) (point)))) @@ -1333,8 +1311,8 @@ stuff." (equal (symbol-value sym) newval) (not (stringp newval))) (push (if (boundp sym) - `(ses-set-with-undo ,sym ,(symbol-value sym)) - `(ses-unset-with-undo ,sym)) + `(apply ses-set-with-undo ,sym ,(symbol-value sym)) + `(apply ses-unset-with-undo ,sym)) buffer-undo-list) (set sym newval) t)) @@ -1342,20 +1320,20 @@ stuff." (defun ses-unset-with-undo (sym) "Set SYM to be unbound. This is undoable." (when (1value (boundp sym)) ;;Always bound, except after a programming error - (push `(ses-set-with-undo ,sym ,(symbol-value sym)) buffer-undo-list) + (push `(apply ses-set-with-undo ,sym ,(symbol-value sym)) buffer-undo-list) (makunbound sym))) (defun ses-aset-with-undo (array idx newval) "Like aset, but undoable. Result is t if element has changed" (unless (equal (aref array idx) newval) - (push `(ses-aset-with-undo ,array ,idx ,(aref array idx)) buffer-undo-list) + (push `(apply ses-aset-with-undo ,array ,idx ,(aref array idx)) buffer-undo-list) (aset array idx newval) t)) -;;;---------------------------------------------------------------------------- -;;;; Startup for major mode -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Startup for major mode +;;---------------------------------------------------------------------------- (defun ses-load () "Parse the current buffer and sets up buffer-local variables. Does not @@ -1363,10 +1341,9 @@ execute cell formulas or print functions." (widen) ;;Read our global parameters, which should be a 3-element list (goto-char (point-max)) - (search-backward ";;; Local Variables:\n" nil t) + (search-backward ";; Local Variables:\n" nil t) (backward-list 1) - (let ((params (condition-case nil (read (current-buffer)) (error nil))) - sym) + (let ((params (condition-case nil (read (current-buffer)) (error nil)))) (or (and (= (safe-length params) 3) (numberp (car params)) (numberp (cadr params)) @@ -1384,7 +1361,7 @@ execute cell formulas or print functions." (ses-set-parameter 'ses--file-format 2) (message "Upgrading from SES-1 file format"))) (or (= ses--file-format 2) - (error "This file needs a newer version of the SES library code.")) + (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)) @@ -1468,7 +1445,7 @@ Narrows the buffer to show only the print area. Gives it `read-only' and (put-text-property (point-min) (1+ (point-min)) 'front-sticky t) ;;Create intangible properties, which also indicate which cell the text ;;came from. - (ses-dotimes-msg (row ses--numrows) "Finding cells..." + (dotimes-with-progress-reporter (row ses--numrows) "Finding cells..." (dotimes (col ses--numcols) (setq pos end sym (ses-cell-symbol row col)) @@ -1481,7 +1458,7 @@ Narrows the buffer to show only the print area. Gives it `read-only' and (put-text-property pos end 'intangible sym))) ;;Adding these properties did not actually alter the text (unless was-modified - (set-buffer-modified-p nil) + (restore-buffer-modified-p nil) (buffer-disable-undo) (buffer-enable-undo))) ;;Create the underlining overlay. It's impossible for (point) to be 2, @@ -1494,8 +1471,7 @@ Narrows the buffer to show only the print area. Gives it `read-only' and overlay, remove special text properties." (widen) (let ((inhibit-read-only t) - (was-modified (buffer-modified-p)) - end) + (was-modified (buffer-modified-p))) ;;Delete read-only, keymap, and intangible properties (set-text-properties (point-min) (point-max) nil) ;;Delete overlay @@ -1576,7 +1552,7 @@ These are active only in the minibuffer, when entering or editing a formula: (setq ses--deferred-narrow 'ses-mode) (1value (add-hook 'post-command-hook 'ses-command-hook nil t)) (run-with-idle-timer 0.01 nil 'ses-command-hook) - (run-hooks 'ses-mode-hook))) + (run-mode-hooks 'ses-mode-hook))) (put 'ses-mode 'mode-class 'special) @@ -1639,50 +1615,37 @@ narrows the buffer now." (message (error-message-string err)))) nil) ;Make coverage-tester happy -(defun ses-header-string-left-offset () - "Number of characters in left fringe and left scrollbar (if any)." - (let ((left-fringe (round (or (frame-parameter nil 'left-fringe) 0) - (frame-char-width))) - (left-scrollbar (if (not (eq (frame-parameter nil - 'vertical-scroll-bars) - 'left)) - 0 - (let ((x (frame-parameter nil 'scroll-bar-width))) - ;;Non-toolkil bar is always 14 pixels? - (unless x (setq x 14)) - ;;Always round up - (ceiling x (frame-char-width)))))) - (+ left-fringe left-scrollbar))) - (defun ses-create-header-string () - "Sets up `ses--header-string' as the buffer's header line, based on the -current set of columns and window-scroll position." - (let* ((left-offset (ses-header-string-left-offset)) - (totwidth (- left-offset (window-hscroll))) - result width result x) + "Set up `ses--header-string' as the buffer's header line. +Based on the current set of columns and `window-hscroll' position." + (let ((totwidth (- (window-hscroll))) + result width x) ;;Leave room for the left-side fringe and scrollbar - (push (make-string left-offset ? ) result) + (push (propertize " " 'display '((space :align-to 0))) result) (dotimes (col ses--numcols) (setq width (ses-col-width col) totwidth (+ totwidth width 1)) - (if (= totwidth (+ left-offset 1)) + (if (= totwidth 1) ;;Scrolled so intercolumn space is leftmost (push " " result)) - (when (> totwidth (+ left-offset 1)) + (when (> totwidth 1) (if (> ses--header-row 0) (save-excursion (ses-goto-print (1- ses--header-row) col) (setq x (buffer-substring-no-properties (point) (+ (point) width))) - (if (>= width (- totwidth left-offset)) - (setq x (substring x (- width totwidth left-offset -1)))) - (push (propertize x 'face ses-box-prop) result)) - (setq x (ses-column-letter col)) + ;; Strip trailing space. + (if (string-match "[ \t]+\\'" x) + (setq x (substring x 0 (match-beginning 0)))) + ;; Cut off excess text. + (if (>= (length x) totwidth) + (setq x (substring x 0 (- totwidth -1))))) + (setq x (ses-column-letter col))) (push (propertize x 'face ses-box-prop) result) - (push (propertize (make-string (- width (length x)) ?.) + (push (propertize "." 'display `((space :align-to ,(1- totwidth))) 'face ses-box-prop) - result)) + result) ;;Allow the following space to be squished to make room for the 3-D box ;;Coverage test ignores properties, thinks this is always a space! (push (1value (propertize " " 'display `((space :align-to ,totwidth)))) @@ -1694,9 +1657,9 @@ current set of columns and window-scroll position." (setq ses--header-string (apply 'concat (nreverse result))))) -;;;---------------------------------------------------------------------------- -;;;; Redisplay and recalculation -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Redisplay and recalculation +;;---------------------------------------------------------------------------- (defun ses-jump (sym) "Move point to cell SYM." @@ -1731,7 +1694,7 @@ print area if NONARROW is nil." ;;find the data area when inserting or deleting *skip* values for cells (dotimes (row ses--numrows) (insert-and-inherit ses--blank-line)) - (ses-dotimes-msg (row ses--numrows) "Reprinting..." + (dotimes-with-progress-reporter (row ses--numrows) "Reprinting..." (if (eq (ses-cell-value row 0) '*skip*) ;;Column deletion left a dangling skip (ses-set-cell row 0 'value nil)) @@ -1814,13 +1777,15 @@ cells." (interactive "*") (ses-begin-change) ;;Reconstruct reference lists. - (let (refs x yrow ycol) + (let (x yrow ycol) ;;Delete old reference lists - (ses-dotimes-msg (row ses--numrows) "Deleting references..." + (dotimes-with-progress-reporter + (row ses--numrows) "Deleting references..." (dotimes (col ses--numcols) (ses-set-cell row col 'references nil))) ;;Create new reference lists - (ses-dotimes-msg (row ses--numrows) "Computing references..." + (dotimes-with-progress-reporter + (row ses--numrows) "Computing references..." (dotimes (col ses--numcols) (dolist (ref (ses-formula-references (ses-cell-formula row col))) (setq x (ses-sym-rowcol ref) @@ -1830,12 +1795,12 @@ cells." (cons (ses-cell-symbol row col) (ses-cell-references yrow ycol))))))) ;;Delete everything and reconstruct basic data area - (if (< (point-max) (buffer-size)) + (if (ses-narrowed-p) (setq ses--deferred-narrow t)) (widen) (let ((inhibit-read-only t)) (goto-char (point-max)) - (if (search-backward ";;; Local Variables:\n" nil t) + (if (search-backward ";; Local Variables:\n" nil t) (delete-region (point-min) (point)) ;;Buffer is quite screwed up - can't even save the user-specified locals (delete-region (point-min) (point-max)) @@ -1862,9 +1827,9 @@ cells." (goto-char (point-min))) -;;;---------------------------------------------------------------------------- -;;;; Input of cell formulas -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Input of cell formulas +;;---------------------------------------------------------------------------- (defun ses-edit-cell (row col newval) "Display current cell contents in minibuffer, for editing. Returns nil if @@ -1968,9 +1933,9 @@ cells." (ses-clear-cell (car rowcol) (cdr rowcol)))))) -;;;---------------------------------------------------------------------------- -;;;; Input of cell-printer functions -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Input of cell-printer functions +;;---------------------------------------------------------------------------- (defun ses-read-printer (prompt default) "Common code for `ses-read-cell-printer', `ses-read-column-printer', and `ses-read-default-printer'. @@ -2009,7 +1974,7 @@ latter two cases, the function's result should be either a string (will be right-justified) or a list of one string (will be left-justified)." (interactive (let ((default t) - prompt x) + x) (ses-check-curcell 'range) ;;Default is none if not all cells in range have same printer (catch 'ses-read-cell-printer @@ -2059,9 +2024,9 @@ right-justified) or a list of one string (will be left-justified)." (ses-reprint-all t))) -;;;---------------------------------------------------------------------------- -;;;; Spreadsheet size adjustments -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Spreadsheet size adjustments +;;---------------------------------------------------------------------------- (defun ses-insert-row (count) "Insert a new row before the current one. With prefix, insert COUNT rows @@ -2080,14 +2045,14 @@ before current one." (ses-set-parameter 'ses--numrows (+ ses--numrows count)) ;;Insert each row (ses-goto-print row 0) - (ses-dotimes-msg (x count) "Inserting row..." + (dotimes-with-progress-reporter (x count) "Inserting row..." ;;Create a row of empty cells. The `symbol' fields will be set by ;;the call to ses-relocate-all. (setq newrow (make-vector ses--numcols nil)) (dotimes (col ses--numcols) - (aset newrow col (make-vector ses-cell-size nil))) + (aset newrow col (ses-make-cell))) (setq ses--cells (ses-vector-insert ses--cells row newrow)) - (push `(ses-vector-delete ses--cells ,row 1) buffer-undo-list) + (push `(apply ses-vector-delete ses--cells ,row 1) buffer-undo-list) (insert ses--blank-line)) ;;Insert empty lines in cell data area (will be replaced by ;;ses-relocate-all) @@ -2122,8 +2087,7 @@ current one." (or (> count 0) (signal 'args-out-of-range nil)) (let ((inhibit-quit t) (inhibit-read-only t) - (row (car (ses-sym-rowcol ses--curcell))) - pos) + (row (car (ses-sym-rowcol ses--curcell)))) (setq count (min count (- ses--numrows row))) (ses-begin-change) (ses-set-parameter 'ses--numrows (- ses--numrows count)) @@ -2149,10 +2113,10 @@ current one." (ses-jump-safe ses--curcell)) (defun ses-insert-column (count &optional col width printer) - "Insert a new column before COL (default is the current one). With prefix, -insert COUNT columns before current one. If COL is specified, the new -column(s) get the specified WIDTH and PRINTER (otherwise they're taken from -the current column)." + "Insert a new column before COL (default is the current one). +With prefix, insert COUNT columns before current one. +If COL is specified, the new column(s) get the specified WIDTH and PRINTER +\(otherwise they're taken from the current column)." (interactive "*p") (ses-check-curcell) (or (> count 0) (signal 'args-out-of-range nil)) @@ -2170,7 +2134,7 @@ the current column)." (ses-create-cell-variable-range 0 (1- ses--numrows) ses--numcols (+ ses--numcols count -1)) ;;Insert each column. - (ses-dotimes-msg (x count) "Inserting column..." + (dotimes-with-progress-reporter (x count) "Inserting column..." ;;Create a column of empty cells. The `symbol' fields will be set by ;;the call to ses-relocate-all. (ses-adjust-print-width col (1+ width)) @@ -2181,8 +2145,7 @@ the current column)." (setq has-skip t)) (ses-aset-with-undo ses--cells row (ses-vector-insert (aref ses--cells row) - col - (make-vector ses-cell-size nil))) + col (ses-make-cell))) ;;Insert empty lines in cell data area (will be replaced by ;;ses-relocate-all) (ses-goto-data row col) @@ -2217,7 +2180,7 @@ from the current one." (inhibit-read-only t) (rowcol (ses-sym-rowcol ses--curcell)) (width 0) - new col origrow has-skip) + col origrow has-skip) (setq origrow (car rowcol) col (cdr rowcol) count (min count (- ses--numcols col))) @@ -2229,7 +2192,7 @@ from the current one." (ses-begin-change) (ses-set-parameter 'ses--numcols (- ses--numcols count)) (ses-adjust-print-width col (- width)) - (ses-dotimes-msg (row ses--numrows) "Deleting column..." + (dotimes-with-progress-reporter (row ses--numrows) "Deleting column..." ;;Delete lines from cell data area (ses-goto-data row col) (ses-delete-line count) @@ -2320,9 +2283,9 @@ inserts a new row if at bottom of print area. Repeat COUNT times." (ses-print-cell-new-width row col)))) -;;;---------------------------------------------------------------------------- -;;;; Cut and paste, import and export -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Cut and paste, import and export +;;---------------------------------------------------------------------------- (defadvice copy-region-as-kill (around ses-copy-region-as-kill activate preactivate) @@ -2340,7 +2303,10 @@ hard to override how mouse-1 works." (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 - (kill-new (ses-copy-region beg end)))) + (kill-new (ses-copy-region beg end)) + (if transient-mark-mode + (setq deactivate-mark t)) + nil)) (defun ses-copy-region (beg end) "Treat the region as rectangular. Convert the intangible attributes to @@ -2475,7 +2441,7 @@ formulas are to be inserted without relocation." (colincr (- (cdr rowcol) (cdr first))) (pos 0) myrow mycol x) - (ses-dotimes-msg (row needrows) "Yanking..." + (dotimes-with-progress-reporter (row needrows) "Yanking..." (setq myrow (+ row (car rowcol))) (dotimes (col needcols) (setq mycol (+ col (cdr rowcol)) @@ -2654,9 +2620,9 @@ WANT-FORMULAS is non-nil. Newlines and tabs in the export text are escaped." (kill-new result))) -;;;---------------------------------------------------------------------------- -;;;; Other user commands -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Other user commands +;;---------------------------------------------------------------------------- (defun ses-unset-header-row () "Select the default header row." @@ -2829,9 +2795,9 @@ highlighted range in the spreadsheet." (ses-insert-ses-range)) -;;;---------------------------------------------------------------------------- -;;;; Checking formulas for safety -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Checking formulas for safety +;;---------------------------------------------------------------------------- (defun ses-safe-printer (printer) "Returns PRINTER if safe, or the substitute printer `ses-unsafe' otherwise." @@ -2862,9 +2828,9 @@ is safe or user allows execution anyway. Always returns t if formula checker))))) -;;;---------------------------------------------------------------------------- -;;;; Standard formulas -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Standard formulas +;;---------------------------------------------------------------------------- (defmacro ses-range (from to) "Expands to a list of cell-symbols for the range. The range automatically @@ -2880,8 +2846,8 @@ alias for this macro!" "Return ARGS reversed, with the blank elements (nil and *skip*) removed." (let (result) (dolist (cur args) - (and cur (not (eq cur '*skip*)) - (push cur result))) + (unless (memq cur '(nil *skip*)) + (push cur result))) result)) (defun ses+ (&rest args) @@ -2916,9 +2882,9 @@ TEST is evaluated." (put x 'side-effect-free t)) -;;;---------------------------------------------------------------------------- -;;;; Standard print functions -;;;---------------------------------------------------------------------------- +;;---------------------------------------------------------------------------- +;; Standard print functions +;;---------------------------------------------------------------------------- ;;These functions use the variables 'row' and 'col' that are ;;dynamically bound by ses-print-cell. We define these varables at @@ -2935,7 +2901,7 @@ columns to include in width (default = 0)." (let ((printer (or (ses-col-printer col) ses--default-printer)) (width (ses-col-width col)) half) - (or fill (setq fill ? )) + (or fill (setq fill ?\s)) (or span (setq span 0)) (setq value (ses-call-printer printer value)) (dotimes (x span) @@ -2982,5 +2948,5 @@ current column and continues until the next nonblank column." (provide 'ses) -;;; arch-tag: 88c1ccf0-4293-4824-8c5d-0757b52217f3 -;; ses.el ends here. +;; arch-tag: 88c1ccf0-4293-4824-8c5d-0757b52217f3 +;;; ses.el ends here