;;; 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: Jonathan Yavner <jyavner@member.fsf.org>
-;; Keywords: spreadsheet
+;; Maintainer: Vincent Belaïche <vincentb1@users.sourceforge.net>
+;; Keywords: spreadsheet Dijkstra
;; This file is part of GNU Emacs.
;;; To-do list:
+;; * split (catch 'cycle ...) call back into one or more functions
;; * 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.
;; * Left-margin column for row number.
;; * Move a row by dragging its number in the left-margin.
+;;; Cycle detection
+
+;; Cycles used to be detected by stationarity of ses--deferred-recalc. This was
+;; working fine in most cases, however failed in some cases of several path
+;; racing together.
+;;
+;; 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
+;; update id is ses--Dijkstra-attempt-nb. In case there is a cycle the cycle
+;; length diverge to infinite so it will exceed ses--Dijkstra-weight-bound at
+;; some point of time that allows detection. Otherwise it converges to the
+;; longest path length in the update tree.
+
;;; Code:
(require 'unsafep)
+(eval-when-compile (require 'cl))
;;----------------------------------------------------------------------------
(defalias 'ses-mode-print-map
(let ((keys '([backtab] backward-char
[tab] ses-forward-or-insert
- "\C-i" ses-forward-or-insert ;Needed for ses-coverage.el?
+ "\C-i" ses-forward-or-insert ; Needed for ses-coverage.el?
"\M-o" ses-insert-column
"\C-o" ses-insert-row
"\C-m" ses-edit-cell
"Initial contents for the file-trailer area at the bottom of the file.")
(defconst ses-initial-file-contents
- (concat " \n" ;One blank cell in print area
+ (concat " \n" ; One blank cell in print area.
ses-print-data-boundary
- "(ses-cell A1 nil nil nil nil)\n" ;One blank cell in data area
- "\n" ;End-of-row terminator for the one row in data area
+ "(ses-cell A1 nil nil nil nil)\n" ; One blank cell in data area.
+ "\n" ; End-of-row terminator for the one row in data area.
"(ses-column-widths [7])\n"
"(ses-column-printers [nil])\n"
"(ses-default-printer \"%.7g\")\n"
(eval-and-compile
(defconst ses-localvars
- '(ses--blank-line ses--cells ses--col-printers ses--col-widths ses--curcell
- ses--curcell-overlay ses--default-printer ses--deferred-narrow
- ses--deferred-recalc ses--deferred-write ses--file-format
- ses--header-hscroll ses--header-row ses--header-string ses--linewidth
- ses--numcols ses--numrows ses--symbolic-formulas ses--data-marker
- ses--params-marker
- ;;Global variables that we override
+ '(ses--blank-line ses--cells ses--col-printers
+ ses--col-widths ses--curcell ses--curcell-overlay
+ ses--default-printer
+ ses--deferred-narrow ses--deferred-recalc
+ ses--deferred-write ses--file-format
+ (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
+ ;; Global variables that we override
mode-line-process next-line-add-newlines transient-mark-mode)
- "Buffer-local variables used by SES."))
+ "Buffer-local variables used by SES.")
-;;When compiling, create all the buffer locals and give them values
-(eval-when-compile
+(defun ses-set-localvars ()
+ "Set buffer-local and initialize some SES variables."
(dolist (x ses-localvars)
- (make-local-variable x)
- (set x nil)))
+ (cond
+ ((symbolp x)
+ (set (make-local-variable x) nil))
+ ((consp x)
+ (set (make-local-variable (car x)) (cdr x)))
+ (t (error "Unexpected elements `%S' in list `ses-localvars'" x))))))
+
+(eval-when-compile ; silence compiler
+ (ses-set-localvars))
-;;;This variable is documented as being permitted in file-locals:
+;;; This variable is documented as being permitted in file-locals:
(put 'ses--symbolic-formulas 'safe-local-variable 'consp)
(defconst ses-paramlines-plist
(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
;; 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))
+(defsubst ses-make-cell (&optional symbol formula printer references
+ property-list)
+ (vector symbol formula printer references property-list))
(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))
+(put 'ses-cell-symbol 'safe-function t)
(defmacro ses-cell-formula (row &optional col)
"From a CELL or a pair (ROW,COL), get the function that computes its value."
functions refer to its value."
`(aref ,(if col `(ses-get-cell ,row ,col) row) 3))
+(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
+ ;; list needs to be scanned only when the property does not exist for that
+ ;; cell.
+ (let* ((plist (aref cell 4))
+ (ret (plist-member plist property-name)))
+ (if ret
+ ;; Property was found.
+ (let ((val (cadr ret)))
+ (if (eq ret plist)
+ ;; Property found is already in the first position, so just return
+ ;; its value.
+ val
+ ;; Property is not in the first position, the following will move it
+ ;; there before returning its value.
+ (let ((next (cddr ret)))
+ (if next
+ (progn
+ (setcdr ret (cdr next))
+ (setcar ret (car next)))
+ (setcdr (last plist 1) nil)))
+ (aset cell 4
+ `(,property-name ,val ,@plist))
+ val)))))
+
+(defmacro ses-cell-property-get (property-name row &optional 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
+interest."
+ (declare (debug t))
+ `(ses-cell-property-get-fun
+ ,property-name
+ ,(if col `(ses-get-cell ,row ,col) row)))
+
+(defun ses-cell-property-delq-fun (property-name cell)
+ (let ((ret (plist-get (aref cell 4) property-name)))
+ (if ret
+ (setcdr ret (cddr ret)))))
+
+(defun ses-cell-property-set-fun (property-name property-val cell)
+ (let* ((plist (aref cell 4))
+ (ret (plist-member plist property-name)))
+ (if ret
+ (setcar (cdr ret) property-val)
+ (aset cell 4 `(,property-name ,property-val ,@plist)))))
+
+(defmacro ses-cell-property-set (property-name property-value row &optional col)
+ "From a CELL or a pair (ROW,COL), set the property value of
+the corresponding cell with name PROPERTY-NAME to PROPERTY-VALUE."
+ (if property-value
+ `(ses-cell-property-set-fun ,property-name ,property-value
+ ,(if col `(ses-get-cell ,row ,col) row))
+ `(ses-cell-property-delq-fun ,property-name
+ ,(if col `(ses-get-cell ,row ,col) row))))
+
+(defun ses-cell-property-pop-fun (property-name cell)
+ (let* ((plist (aref cell 4))
+ (ret (plist-member plist property-name)))
+ (if ret
+ (prog1 (cadr ret)
+ (let ((next (cddr ret)))
+ (if next
+ (progn
+ (setcdr ret (cdr next))
+ (setcar ret (car next)))
+ (if (eq plist ret)
+ (aset cell 4 nil)
+ (setcdr (last plist 2) nil))))))))
+
+
+(defmacro ses-cell-property-pop (property-name row &optional col)
+ "From a CELL or a pair (ROW,COL), get and remove the property value of
+the corresponding cell with name PROPERTY-NAME."
+ `(ses-cell-property-pop-fun ,property-name
+ ,(if col `(ses-get-cell ,row ,col) row)))
+
+(defun ses-cell-property-get-handle-fun (property-name cell)
+ (let* ((plist (aref cell 4))
+ (ret (plist-member plist property-name)))
+ (if ret
+ (if (eq ret plist)
+ (cdr ret)
+ (let ((val (cadr ret))
+ (next (cddr ret)))
+ (if next
+ (progn
+ (setcdr ret (cdr next))
+ (setcar ret (car next)))
+ (setcdr (last plist 2) nil))
+ (setq ret (cons val plist))
+ (aset cell 4 (cons property-name ret))
+ ret))
+ (setq ret (cons nil plist))
+ (aset cell 4 (cons property-name ret))
+ ret)))
+
+(defmacro ses-cell-property-get-handle (property-name row &optional col)
+ "From a CELL or a pair (ROW,COL), get a cons cell whose car is
+the property value of the corresponding cell property with name
+PROPERTY-NAME."
+ `(ses-cell-property-get-handle-fun ,property-name
+ ,(if col `(ses-get-cell ,row ,col) row)))
+
+
+(defalias 'ses-cell-property-handle-car 'car)
+(defalias 'ses-cell-property-handle-setcar 'setcar)
+
(defmacro ses-cell-value (row &optional col)
"From a CELL or a pair (ROW,COL), get the current value for that cell."
`(symbol-value (ses-cell-symbol ,row ,col)))
`(aref ses--col-printers ,col))
(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."
+ "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)))
(defmacro ses-cell (sym value formula printer references)
(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)))
0-25 become A-Z; 26-701 become AA-ZZ, and so on."
(let ((units (char-to-string (+ ?A (% col 26)))))
(if (< col 26)
- units
+ units
(concat (ses-column-letter (1- (/ col 26))) units))))
(defun ses-create-cell-symbol (row col)
(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)
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))
(ses-aset-with-undo cell elt val)))
(if change
(add-to-list 'ses--deferred-write (cons row col))))
- nil) ;Make coverage-tester happy
+ 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
(ses-formula-record formula)
(ses-set-cell row col 'formula formula))))
+
+(defun ses-repair-cell-reference-all ()
+ "Repair cell reference and warn if there was some reference corruption."
+ (interactive "*")
+ (let (errors)
+ ;; Step 1, reset :ses-repair-reference cell property in the whole sheet.
+ (dotimes (row ses--numrows)
+ (dotimes (col ses--numcols)
+ (let ((references (ses-cell-property-pop :ses-repair-reference
+ row col)))
+ (when references
+ (push (list
+ (ses-cell-symbol row col)
+ :corrupt-property
+ references) errors)))))
+
+ ;; Step 2, build new.
+ (dotimes (row ses--numrows)
+ (dotimes (col ses--numcols)
+ (let* ((cell (ses-get-cell row col))
+ (sym (ses-cell-symbol cell))
+ (formula (ses-cell-formula cell))
+ (new-ref (ses-formula-references formula)))
+ (dolist (ref new-ref)
+ (let* ((rowcol (ses-sym-rowcol ref))
+ (h (ses-cell-property-get-handle :ses-repair-reference
+ (car rowcol) (cdr rowcol))))
+ (unless (memq ref (ses-cell-property-handle-car h))
+ (ses-cell-property-handle-setcar
+ h
+ (cons sym
+ (ses-cell-property-handle-car h)))))))))
+
+ ;; Step 3, overwrite with check.
+ (dotimes (row ses--numrows)
+ (dotimes (col ses--numcols)
+ (let* ((cell (ses-get-cell row col))
+ (irrelevant (ses-cell-references cell))
+ (new-ref (ses-cell-property-pop :ses-repair-reference cell))
+ missing)
+ (dolist (ref new-ref)
+ (if (memq ref irrelevant)
+ (setq irrelevant (delq ref irrelevant))
+ (push ref missing)))
+ (ses-set-cell row col 'references new-ref)
+ (when (or missing irrelevant)
+ (push `( ,(ses-cell-symbol cell)
+ ,@(and missing (list :missing missing))
+ ,@(and irrelevant (list :irrelevant irrelevant)))
+ errors)))))
+ (if errors
+ (warn "----------------------------------------------------------------
+Some references were corrupted.
+
+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
+
+* property `:corrupt-property' means that
+ property `:ses-repair-reference' of cell CELL was initially non
+ nil,
+
+* property `:missing' is a list of missing references
+
+* property `:irrelevant' is a list of non needed references
+
+%S" errors)
+ (message "No reference corruption found"))))
+
(defun ses-calculate-cell (row col force)
"Calculate and print the value for cell (ROW,COL) using the cell's formula
function and print functions, if any. Result is nil for normal operation, or
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)
+ cycle-error formula-error printer-error)
(let ((oldval (ses-cell-value cell))
(formula (ses-cell-formula cell))
- newval)
+ newval
+ this-cell-Dijkstra-attempt-h
+ this-cell-Dijkstra-attempt
+ this-cell-Dijkstra-attempt+1
+ ref-cell-Dijkstra-attempt-h
+ ref-cell-Dijkstra-attempt
+ ref-rowcol)
(when (eq (car-safe formula) 'ses-safe-formula)
(setq formula (ses-safe-formula (cadr formula)))
(ses-set-cell row col 'formula formula))
(condition-case sig
(setq newval (eval formula))
(error
+ ;; Variable `sig' can't be nil.
+ (nconc sig (list (ses-cell-symbol cell)))
(setq formula-error sig
newval '*error*)))
(if (and (not newval) (eq oldval '*skip*))
- ;;Don't lose the *skip* - previous field spans this one
+ ;; Don't lose the *skip* --- previous field spans this one.
(setq newval '*skip*))
- (when (or force (not (eq newval oldval)))
- (add-to-list 'ses--deferred-write (cons row col)) ;In case force=t
- (ses-set-cell row col 'value newval)
- (dolist (ref (ses-cell-references cell))
- (add-to-list 'ses--deferred-recalc ref))))
+ (catch 'cycle
+ (when (or force (not (eq newval oldval)))
+ (add-to-list 'ses--deferred-write (cons row col)) ; In case force=t.
+ (setq this-cell-Dijkstra-attempt-h
+ (ses-cell-property-get-handle :ses-Dijkstra-attempt cell);
+ this-cell-Dijkstra-attempt
+ (ses-cell-property-handle-car this-cell-Dijkstra-attempt-h))
+ (if (null this-cell-Dijkstra-attempt)
+ (ses-cell-property-handle-setcar
+ this-cell-Dijkstra-attempt-h
+ (setq this-cell-Dijkstra-attempt
+ (cons ses--Dijkstra-attempt-nb 0)))
+ (unless (= ses--Dijkstra-attempt-nb
+ (car this-cell-Dijkstra-attempt))
+ (setcar this-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb)
+ (setcdr this-cell-Dijkstra-attempt 0)))
+ (setq this-cell-Dijkstra-attempt+1
+ (1+ (cdr this-cell-Dijkstra-attempt)))
+ (ses-set-cell row col 'value newval)
+ (dolist (ref (ses-cell-references cell))
+ (add-to-list 'ses--deferred-recalc ref)
+ (setq ref-rowcol (ses-sym-rowcol ref)
+ ref-cell-Dijkstra-attempt-h
+ (ses-cell-property-get-handle
+ :ses-Dijkstra-attempt
+ (car ref-rowcol) (cdr ref-rowcol))
+ ref-cell-Dijkstra-attempt
+ (ses-cell-property-handle-car ref-cell-Dijkstra-attempt-h))
+
+ (if (null ref-cell-Dijkstra-attempt)
+ (ses-cell-property-handle-setcar
+ ref-cell-Dijkstra-attempt-h
+ (setq ref-cell-Dijkstra-attempt
+ (cons ses--Dijkstra-attempt-nb
+ this-cell-Dijkstra-attempt+1)))
+ (if (= (car ref-cell-Dijkstra-attempt) ses--Dijkstra-attempt-nb)
+ (setcdr ref-cell-Dijkstra-attempt
+ (max (cdr ref-cell-Dijkstra-attempt)
+ this-cell-Dijkstra-attempt+1))
+ (setcar ref-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb)
+ (setcdr ref-cell-Dijkstra-attempt
+ this-cell-Dijkstra-attempt+1)))
+
+ (when (> this-cell-Dijkstra-attempt+1 ses--Dijkstra-weight-bound)
+ ;; Update print of this cell.
+ (throw 'cycle (setq formula-error
+ `(error ,(format "Found cycle on cells %S"
+ (ses-cell-symbol cell)))
+ cycle-error formula-error)))))))
(setq printer-error (ses-print-cell row col))
- (or formula-error printer-error)))
+ (or
+ (and cycle-error
+ (error (error-message-string cycle-error)))
+ formula-error printer-error)))
(defun ses-clear-cell (row col)
"Delete formula and printer for cell (ROW,COL)."
(ses-set-cell row col 'printer nil)
(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."
+ :type 'boolean
+ :group 'ses)
+
(defun ses-update-cells (list &optional force)
"Recalculate cells in LIST, checking for dependency loops. Prints
progress messages every second. Dependent cells are not recalculated
(let ((ses--deferred-recalc list)
(nextlist list)
(pos (point))
- curlist prevlist rowcol formula)
+ curlist prevlist this-sym this-rowcol formula)
(with-temp-message " "
- (while (and ses--deferred-recalc (not (equal nextlist prevlist)))
- ;;In each loop, recalculate cells that refer only to other cells that
- ;;have already been recalculated or aren't in the recalculation
- ;;region. Repeat until all cells have been processed or until the
- ;;set of cells being worked on stops changing.
+ (while ses--deferred-recalc
+ ;; In each loop, recalculate cells that refer only to other cells that
+ ;; have already been recalculated or aren't in the recalculation region.
+ ;; Repeat until all cells have been processed or until the set of cells
+ ;; being worked on stops changing.
(if prevlist
(message "Recalculating... (%d cells left)"
(length ses--deferred-recalc)))
ses--deferred-recalc nil
prevlist nextlist)
(while curlist
- (setq rowcol (ses-sym-rowcol (car curlist))
- formula (ses-cell-formula (car rowcol) (cdr rowcol)))
+ ;; this-sym has to be popped from curlist *BEFORE* the check, and not
+ ;; after because of the case of cells referring to themselves.
+ (setq this-sym (pop curlist)
+ this-rowcol (ses-sym-rowcol this-sym)
+ formula (ses-cell-formula (car this-rowcol)
+ (cdr this-rowcol)))
(or (catch 'ref
(dolist (ref (ses-formula-references formula))
- (when (or (memq ref curlist)
- (memq ref ses--deferred-recalc))
- ;;This cell refers to another that isn't done yet
- (add-to-list 'ses--deferred-recalc (car curlist))
- (throw 'ref t))))
- ;;ses-update-cells is called from post-command-hook, so
- ;;inhibit-quit is implicitly bound to t.
+ (if (and ses-self-reference-early-detection (eq ref this-sym))
+ (error "Cycle found: cell %S is self-referring" this-sym)
+ (when (or (memq ref curlist)
+ (memq ref ses--deferred-recalc))
+ ;; This cell refers to another that isn't done yet
+ (add-to-list 'ses--deferred-recalc this-sym)
+ (throw 'ref t)))))
+ ;; ses-update-cells is called from post-command-hook, so
+ ;; inhibit-quit is implicitly bound to t.
(when quit-flag
- ;;Abort the recalculation. User will probably undo now.
+ ;; Abort the recalculation. User will probably undo now.
(error "Quit"))
- (ses-calculate-cell (car rowcol) (cdr rowcol) force))
- (setq curlist (cdr curlist)))
+ (ses-calculate-cell (car this-rowcol) (cdr this-rowcol) force)))
(dolist (ref ses--deferred-recalc)
- (add-to-list 'nextlist ref))
- (setq nextlist (sort (copy-sequence nextlist) 'string<))
- (if (equal nextlist prevlist)
- ;;We'll go around the loop one more time.
- (add-to-list 'nextlist t)))
+ (add-to-list 'nextlist ref)))
(when ses--deferred-recalc
- ;;Just couldn't finish these
+ ;; Just couldn't finish these.
(dolist (x ses--deferred-recalc)
- (let ((rowcol (ses-sym-rowcol x)))
- (ses-set-cell (car rowcol) (cdr rowcol) 'value '*error*)
- (1value (ses-print-cell (car rowcol) (cdr rowcol)))))
+ (let ((this-rowcol (ses-sym-rowcol x)))
+ (ses-set-cell (car this-rowcol) (cdr this-rowcol) 'value '*error*)
+ (1value (ses-print-cell (car this-rowcol) (cdr this-rowcol)))))
(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.
+ ;; Can't use save-excursion here: if the cell under point is updated,
+ ;; 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
-;;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)
(n 0))
(goto-char (point-min))
(forward-line row)
- ;; calculate column position
+ ;; Calculate column position.
(dotimes (c col)
(setq n (+ n (ses-col-width c) 1)))
- ;; move to the position
+ ;; Move to the position.
(and (> n (move-to-column n))
(eolp)
- ;; move point to the bol of next line (for TAB at the last cell)
+ ;; Move point to the bol of next line (for TAB at the last cell).
(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
(= (region-beginning) (region-end)))
- ;;Single cell
+ ;; Single cell.
(setq ses--curcell (get-text-property (point) 'intangible))
- ;;Range
+ ;; Range.
(let ((bcell (get-text-property (region-beginning) 'intangible))
(ecell (get-text-property (1- (region-end)) 'intangible)))
(when (= (region-end) ses--data-marker)
- ;;Correct for overflow
+ ;; Correct for overflow.
(setq ecell (get-text-property (- (region-end) 2) 'intangible)))
(setq ses--curcell (if (and bcell ecell)
(cons bcell ecell)
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
+ ;; curcell recalculation was postponed, but user typed ahead.
(ses-set-curcell))
(cond
((not ses--curcell)
(printer (ses-cell-printer cell))
(maxcol (1+ col))
text sig startpos x)
- ;;Create the string to print
+ ;; Create the string to print.
(cond
((eq value '*skip*)
- ;;Don't print anything
+ ;; Don't print anything.
(throw 'ses-print-cell nil))
((eq value '*error*)
(setq text (make-string (ses-col-width col) ?#)))
(t
- ;;Deferred safety-check on printer
+ ;; Deferred safety-check on printer.
(if (eq (car-safe printer) 'ses-safe-printer)
(ses-set-cell row col 'printer
(setq printer (ses-safe-printer (cadr printer)))))
- ;;Print the value
+ ;; Print the value.
(setq text (ses-call-printer (or printer
(ses-col-printer col)
ses--default-printer)
value))
(if (consp ses-call-printer-return)
- ;;Printer returned an error
+ ;; Printer returned an error.
(setq sig ses-call-printer-return))))
- ;;Adjust print width to match column width
+ ;; Adjust print width to match column width.
(let ((width (ses-col-width col))
(len (string-width text)))
(cond
((< len width)
- ;;Fill field to length with spaces
+ ;; Fill field to length with spaces.
(setq len (make-string (- width len) ?\s)
text (if (eq ses-call-printer-return t)
(concat text len)
(concat len text))))
((> len width)
- ;;Spill over into following cells, if possible
+ ;; Spill over into following cells, if possible.
(let ((maxwidth width))
(while (and (> len maxwidth)
(< maxcol ses--numcols)
(or (not (setq x (ses-cell-value row maxcol)))
(eq x '*skip*)))
(unless x
- ;;Set this cell to '*skip* so it won't overwrite our spillover
+ ;; Set this cell to '*skip* so it won't overwrite our spillover.
(ses-set-cell row maxcol 'value '*skip*))
(setq maxwidth (+ maxwidth (ses-col-width maxcol) 1)
maxcol (1+ maxcol)))
(if (<= len maxwidth)
- ;;Fill to complete width of all the fields spanned
+ ;; Fill to complete width of all the fields spanned.
(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
+ ;; 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))
(cond
((stringp value)
(substring text (match-end 0)))))
(t
(setq text (make-string maxwidth ?#)))))))))
- ;;Substitute question marks for tabs and newlines. Newlines are
- ;;used as row-separators; tabs could confuse the reimport logic.
+ ;; Substitute question marks for tabs and newlines. Newlines are used as
+ ;; row-separators; tabs could confuse the reimport logic.
(setq text (replace-regexp-in-string "[\t\n]" "?" text))
(ses-goto-print row col)
(setq startpos (point))
- ;;Install the printed result. This is not interruptible.
+ ;; Install the printed result. This is not interruptible.
(let ((inhibit-read-only t)
(inhibit-quit t))
(let ((inhibit-point-motion-hooks t))
(move-to-column (+ (current-column)
(string-width text)))
(1+ (point)))))
- ;;We use concat instead of inserting separate strings in order to
- ;;reduce the number of cells in the undo list.
+ ;; We use concat instead of inserting separate strings in order to
+ ;; reduce the number of cells in the undo list.
(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 inherit from surrounding text?)
+ ;; 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 unpropertized strings actually
+ ;; inherit from surrounding text?)
(set-text-properties 0 (length x) nil x)
(insert-and-inherit x)
(put-text-property startpos (point) 'intangible
(ses-cell-symbol cell))
(when (and (zerop row) (zerop col))
- ;;Reconstruct special beginning-of-buffer attributes
+ ;; Reconstruct special beginning-of-buffer attributes.
(put-text-property (point-min) (point) 'keymap 'ses-mode-print-map)
(put-text-property (point-min) (point) 'read-only 'ses)
(put-text-property (point-min) (1+ (point-min)) 'front-sticky t)))
(if (= row (1- ses--header-row))
- ;;This line is part of the header - force recalc
+ ;; This line is part of the header --- force recalc.
(ses-reset-header-string))
- ;;If this cell (or a preceding one on the line) previously spilled over
- ;;and has gotten shorter, redraw following cells on line recursively.
+ ;; If this cell (or a preceding one on the line) previously spilled over
+ ;; and has gotten shorter, redraw following cells on line recursively.
(when (and (< maxcol ses--numcols)
(eq (ses-cell-value row maxcol) '*skip*))
(ses-set-cell row maxcol 'value nil)
(ses-print-cell row maxcol))
- ;;Return to start of cell
+ ;; Return to start of cell.
(goto-char startpos)
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
printer signaled one (and \"%s\" is used as the default printer), else nil."
(setq ses-call-printer-return nil)
- (unless value
- (setq value ""))
(condition-case signal
(cond
((stringp printer)
- (format printer value))
+ (if value
+ (format printer value)
+ ""))
((stringp (car-safe printer))
(setq ses-call-printer-return t)
- (format (car printer) value))
+ (if value
+ (format (car printer) value)
+ ""))
(t
- (setq value (funcall printer value))
+ (setq value (funcall printer (or value "")))
(if (stringp value)
value
(or (stringp (car-safe value))
(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)))
(ses-set-with-undo 'ses--linewidth (+ ses--linewidth change))
- ;;ses-set-with-undo always returns t for strings.
+ ;; ses-set-with-undo always returns t for strings.
(1value (ses-set-with-undo 'ses--blank-line
(concat (make-string ses--linewidth ?\s) "\n")))
(dotimes (row ses--numrows)
(ses-goto-print row col)
(when at-end
- ;;Insert new columns before newline
+ ;; Insert new columns before newline.
(let ((inhibit-point-motion-hooks t))
(backward-char 1)))
(if blank
(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
is one of the symbols ses--col-widths, ses--col-printers,
ses--default-printer, ses--numrows, or ses--numcols."
(ses-widen)
- (let ((inhibit-point-motion-hooks t)) ;In case intangible attrs are wrong
+ (let ((inhibit-point-motion-hooks t)) ; In case intangible attrs are wrong.
(if col
- ;;It's a cell
+ ;; It's a cell.
(progn
(goto-char ses--data-marker)
(forward-line (+ 1 (* def (1+ ses--numcols)) col)))
- ;;Convert def-symbol to offset
+ ;; Convert def-symbol to offset.
(setq def (plist-get ses-paramlines-plist def))
(or def (signal 'args-out-of-range nil))
(goto-char ses--params-marker)
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.
+ ;; We call ses-goto-data early, using the old values of numrows and numcols
+ ;; in case one of them is being changed.
(ses-goto-data def)
(let ((inhibit-read-only t)
(fmt (plist-get '(ses--col-widths "(ses-column-widths %S)"
(aset (symbol-value def) elem value))
(setq oldval (symbol-value def))
(set def value))
- ;;Special undo since it's outside the narrowed buffer
+ ;; Special undo since it's outside the narrowed buffer.
(let (buffer-undo-list)
(delete-region (point) (line-end-position))
(insert (format fmt (symbol-value def))))
(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
-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."
- (if (atom formula)
- (if (ses-sym-rowcol formula)
- ;;Entire formula is one symbol
- (add-to-list 'result-so-far formula)
- ) ;;Ignore other atoms
- (dolist (cur formula)
- (cond
- ((ses-sym-rowcol cur)
- ;;Save this reference
- (add-to-list 'result-so-far cur))
- ((eq (car-safe cur) 'ses-range)
- ;;All symbols in range are referenced
- (dolist (x (cdr (macroexpand cur)))
- (add-to-list 'result-so-far x)))
- ((and (consp cur) (not (eq (car cur) 'quote)))
- ;;Recursive call for subformulas
- (setq result-so-far (ses-formula-references cur result-so-far)))
- (t
- ;;Ignore other stuff
- ))))
- result-so-far)
+ "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."
+ (if (ses-sym-rowcol formula)
+ ;;Entire formula is one symbol
+ (add-to-list 'result-so-far formula)
+ (if (consp formula)
+ (cond
+ ((eq (car formula) 'ses-range)
+ (dolist (cur
+ (cdr (funcall 'macroexpand
+ (list 'ses-range (nth 1 formula)
+ (nth 2 formula)))))
+ (add-to-list 'result-so-far cur)))
+ ((null (eq (car formula) 'quote))
+ ;;Recursive call for subformulas
+ (dolist (cur formula)
+ (setq result-so-far (ses-formula-references cur result-so-far))))
+ (t
+ ;;Ignore other stuff
+ ))
+ ;; other type of atom are ignored
+ ))
+ 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
(if (setq rowcol (ses-sym-rowcol formula))
(ses-relocate-symbol formula rowcol
startrow startcol rowincr colincr)
- formula) ;Pass through as-is
+ formula) ; Pass through as-is.
(dolist (cur formula)
(setq rowcol (ses-sym-rowcol cur))
(cond
startrow startcol rowincr colincr))
(if cur
(push cur result)
- ;;Reference to a deleted cell. Set a flag in ses-relocate-return.
- ;;don't change the flag if it's already 'range, since range
- ;;implies 'delete.
+ ;; Reference to a deleted cell. Set a flag in ses-relocate-return.
+ ;; don't change the flag if it's already 'range, since range implies
+ ;; 'delete.
(unless ses-relocate-return
(setq ses-relocate-return 'delete))))
((eq (car-safe cur) 'ses-range)
(if cur
(push cur result)))
((or (atom cur) (eq (car cur) 'quote))
- ;;Constants pass through unchanged
+ ;; Constants pass through unchanged.
(push cur result))
(t
- ;;Recursively copy and alter subformulas
+ ;; Recursively copy and alter subformulas.
(push (ses-relocate-formula cur startrow startcol
rowincr colincr)
result))))
field)
(cond
((and (not min) (not max))
- (setq range nil)) ;;The entire range is deleted
+ (setq range nil)) ; The entire range is deleted.
((zerop colincr)
- ;;Inserting or deleting rows
+ ;; Inserting or deleting rows.
(setq field 'car)
(if (not min)
- ;;Chopped off beginning of range
+ ;; Chopped off beginning of range.
(setq min (ses-create-cell-symbol startrow (cdr minrowcol))
ses-relocate-return 'range))
(if (not max)
(if (> rowincr 0)
- ;;Trying to insert a nonexistent row
+ ;; Trying to insert a nonexistent row.
(setq max (ses-create-cell-symbol (1- ses--numrows)
(cdr minrowcol)))
- ;;End of range is being deleted
+ ;; End of range is being deleted.
(setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol))
ses-relocate-return 'range))
(and (> rowincr 0)
(= (car maxrowcol) (1- startrow))
(= (cdr minrowcol) (cdr maxrowcol))
- ;;Insert after ending row of vertical range - include it
+ ;; Insert after ending row of vertical range --- include it.
(setq max (ses-create-cell-symbol (+ startrow rowincr -1)
(cdr maxrowcol))))))
(t
- ;;Inserting or deleting columns
+ ;; Inserting or deleting columns.
(setq field 'cdr)
(if (not min)
- ;;Chopped off beginning of range
+ ;; Chopped off beginning of range.
(setq min (ses-create-cell-symbol (car minrowcol) startcol)
ses-relocate-return 'range))
(if (not max)
(if (> colincr 0)
- ;;Trying to insert a nonexistent column
+ ;; Trying to insert a nonexistent column.
(setq max (ses-create-cell-symbol (car maxrowcol)
(1- ses--numcols)))
- ;;End of range is being deleted
+ ;; End of range is being deleted.
(setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol))
ses-relocate-return 'range))
(and (> colincr 0)
(= (cdr maxrowcol) (1- startcol))
(= (car minrowcol) (car maxrowcol))
- ;;Insert after ending column of horizontal range - include it
+ ;; Insert after ending column of horizontal range --- include it.
(setq max (ses-create-cell-symbol (car maxrowcol)
(+ startcol colincr -1)))))))
(when range
(funcall field minrowcol))
(- (funcall field (ses-sym-rowcol max))
(funcall field (ses-sym-rowcol min))))
- ;;This range has changed size
+ ;; This range has changed size.
(setq ses-relocate-return 'range))
- (list 'ses-range min max))))
+ `(ses-range ,min ,max ,@(cdddr range)))))
(defun ses-relocate-all (minrow mincol rowincr colincr)
"Alter all cell values, symbols, formulas, and reference-lists to relocate
(let (reform)
(let (mycell newval)
(dotimes-with-progress-reporter
- (row ses--numrows) "Relocating formulas..."
+ (row ses--numrows) "Relocating formulas..."
(dotimes (col ses--numcols)
(setq ses-relocate-return nil
mycell (ses-get-cell row col)
minrow mincol rowincr colincr))
(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
- ;;inserted or deleted in the middle of the range.
+ ;; This cell contains a (ses-range X Y) where a cell has been
+ ;; inserted or deleted in the middle of the range.
(push (cons row col) reform))
(if ses-relocate-return
- ;;This cell referred to a cell that's been deleted or is no
- ;;longer part of the range. We can't fix that now because
- ;;reference lists cells have been partially updated.
+ ;; This cell referred to a cell that's been deleted or is no
+ ;; longer part of the range. We can't fix that now because
+ ;; reference lists cells have been partially updated.
(add-to-list 'ses--deferred-recalc
(ses-create-cell-symbol row col)))
(setq newval (ses-relocate-formula (ses-cell-references mycell)
(and (>= row minrow) (>= col mincol)
(ses-set-cell row col 'symbol
(ses-create-cell-symbol row col))))))
- ;;Relocate the cell values
+ ;; Relocate the cell values.
(let (oldval myrow mycol xrow xcol)
(cond
((and (<= rowincr 0) (<= colincr 0))
- ;;Deletion of rows and/or columns
+ ;; Deletion of rows and/or columns.
(dotimes-with-progress-reporter
- (row (- ses--numrows minrow)) "Relocating variables..."
+ (row (- ses--numrows minrow)) "Relocating variables..."
(setq myrow (+ row minrow))
(dotimes (col (- ses--numcols mincol))
(setq mycol (+ col mincol)
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
+ ;; 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))))
((and (wholenump rowincr) (wholenump colincr))
- ;;Insertion of rows and/or columns. Run the loop backwards.
+ ;; Insertion of rows and/or columns. Run the loop backwards.
(let ((disty (1- ses--numrows))
(distx (1- ses--numcols))
myrow mycol)
xrow (- myrow rowincr)
xcol (- mycol colincr))
(if (or (< xrow minrow) (< xcol mincol))
- ;;Newly-inserted value
+ ;; Newly-inserted value.
(setq oldval nil)
- ;;Transfer old value
+ ;; Transfer old value.
(setq oldval (ses-cell-value xrow xcol)))
(ses-set-cell myrow mycol 'value oldval)))
- t)) ;Make testcover happy by returning non-nil here
+ t)) ; Make testcover happy by returning non-nil here.
(t
(error "ROWINCR and COLINCR must have the same sign"))))
- ;;Reconstruct reference lists for cells that contain ses-ranges that
- ;;have changed size.
+ ;; Reconstruct reference lists for cells that contain ses-ranges that have
+ ;; changed size.
(when reform
(message "Fixing ses-ranges...")
(let (row col)
(defun ses-set-with-undo (sym newval)
"Like set, but undoable. Result is t if value has changed."
- ;;We try to avoid adding redundant entries to the undo list, but this is
- ;;unavoidable for strings because equal ignores text properties and there's
- ;;no easy way to get the whole property list to see if it's different!
+ ;; We try to avoid adding redundant entries to the undo list, but this is
+ ;; unavoidable for strings because equal ignores text properties and there's
+ ;; no easy way to get the whole property list to see if it's different!
(unless (and (boundp sym)
(equal (symbol-value sym) newval)
(not (stringp newval)))
(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
+ (when (1value (boundp sym)) ; Always bound, except after a programming error.
(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"
+ "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)
+ (push `(apply ses-aset-with-undo ,array ,idx
+ ,(aref array idx)) buffer-undo-list)
(aset array idx newval)
t))
;;----------------------------------------------------------------------------
(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
+ ;; Read our global parameters, which should be a 3-element list.
(goto-char (point-max))
(search-backward ";; Local Variables:\n" nil t)
(backward-list 1)
ses--numrows (cadr params)
ses--numcols (nth 2 params))
(when (= ses--file-format 1)
- (let (buffer-undo-list) ;This is not undoable
+ (let (buffer-undo-list) ; This is not undoable.
(ses-goto-data 'ses--header-row)
(insert "(ses-header-row 0)\n")
(ses-set-parameter 'ses--file-format 2)
(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
+ ;; Initialize cell array.
(setq ses--cells (make-vector ses--numrows nil))
(dotimes (row ses--numrows)
(aset ses--cells row (make-vector ses--numcols nil))))
- ;;Skip over print area, which we assume is correct
+ ;; Skip over print area, which we assume is correct.
(goto-char (point-min))
(forward-line ses--numrows)
(or (looking-at ses-print-data-boundary)
(forward-char 1)
(setq ses--data-marker (point-marker))
(forward-char (1- (length ses-print-data-boundary)))
- ;;Initialize printer and symbol lists
+ ;; Initialize printer and symbol lists.
(mapc 'ses-printer-record ses-standard-printer-functions)
(setq ses--symbolic-formulas nil)
- ;;Load cell definitions
+ ;; Load cell definitions.
(dotimes (row ses--numrows)
(dotimes (col ses--numcols)
(let* ((x (read (current-buffer)))
(eval x)))
(or (looking-at "\n\n")
(error "Missing blank line between rows")))
- ;;Load global parameters
+ ;; Load global parameters.
(let ((widths (read (current-buffer)))
(n1 (char-after (point)))
(printers (read (current-buffer)))
(1value (eval def-printer))
(1value (eval printers))
(1value (eval head-row)))
- ;;Should be back at global-params
+ ;; Should be back at global-params.
(forward-char 1)
(or (looking-at (replace-regexp-in-string "1" "[0-9]+"
ses-initial-global-parameters))
(error "Problem with column-defs or global-params"))
- ;;Check for overall newline count in definitions area
+ ;; Check for overall newline count in definitions area.
(forward-line 3)
(let ((start (point)))
(ses-goto-data 'ses--numrows)
(inhibit-point-motion-hooks t)
(was-modified (buffer-modified-p))
pos sym)
- (ses-goto-data 0 0) ;;Include marker between print-area and data-area
- (set-text-properties (point) (point-max) nil) ;Delete garbage props
+ (ses-goto-data 0 0) ; Include marker between print-area and data-area.
+ (set-text-properties (point) (point-max) nil) ; Delete garbage props.
(mapc 'delete-overlay (overlays-in (point-min) (point-max)))
- ;;The print area is read-only (except for our special commands) and uses a
- ;;special keymap.
+ ;; The print area is read-only (except for our special commands) and uses a
+ ;; special keymap.
(put-text-property (point-min) (1- (point)) 'read-only 'ses)
(put-text-property (point-min) (1- (point)) 'keymap 'ses-mode-print-map)
- ;;For the beginning of the buffer, we want the read-only and keymap
- ;;attributes to be inherited from the first character
+ ;; For the beginning of the buffer, we want the read-only and keymap
+ ;; attributes to be inherited from the first character.
(put-text-property (point-min) (1+ (point-min)) 'front-sticky t)
- ;;Create intangible properties, which also indicate which cell the text
- ;;came from.
+ ;; Create intangible properties, which also indicate which cell the text
+ ;; came from.
(dotimes-with-progress-reporter (row ses--numrows) "Finding cells..."
(dotimes (col ses--numcols)
(setq pos end
sym (ses-cell-symbol row col))
- ;;Include skipped cells following this one
+ ;; Include skipped cells following this one.
(while (and (< col (1- ses--numcols))
(eq (ses-cell-value row (1+ col)) '*skip*))
(setq end (+ end (ses-col-width col) 1)
(forward-char)
(point))))
(put-text-property pos end 'intangible sym)))
- ;;Adding these properties did not actually alter the text
+ ;; Adding these properties did not actually alter the text.
(unless was-modified
(restore-buffer-modified-p nil)
(buffer-disable-undo)
(buffer-enable-undo)))
- ;;Create the underlining overlay. It's impossible for (point) to be 2,
- ;;because column A must be at least 1 column wide.
+ ;; Create the underlining overlay. It's impossible for (point) to be 2,
+ ;; because column A must be at least 1 column wide.
(setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min))))
(overlay-put ses--curcell-overlay 'face 'underline))
Delete overlays, remove special text properties."
(widen)
(let ((inhibit-read-only t)
- ;; When reverting, hide the buffer name, otherwise Emacs will ask
- ;; the user "the file is modified, do you really want to make
- ;; modifications to this buffer", where the "modifications" refer to
- ;; the irrelevant set-text-properties below.
- (buffer-file-name nil)
+ ;; When reverting, hide the buffer name, otherwise Emacs will ask the
+ ;; user "the file is modified, do you really want to make modifications
+ ;; to this buffer", where the "modifications" refer to the irrelevant
+ ;; set-text-properties below.
+ (buffer-file-name nil)
(was-modified (buffer-modified-p)))
- ;;Delete read-only, keymap, and intangible properties
+ ;; Delete read-only, keymap, and intangible properties.
(set-text-properties (point-min) (point-max) nil)
- ;;Delete overlay
+ ;; Delete overlay.
(mapc 'delete-overlay (overlays-in (point-min) (point-max)))
(unless was-modified
(restore-buffer-modified-p nil))))
(unless (and (boundp 'ses--deferred-narrow)
(eq ses--deferred-narrow 'ses-mode))
(kill-all-local-variables)
- (mapc 'make-local-variable ses-localvars)
+ (ses-set-localvars)
(setq major-mode 'ses-mode
mode-name "SES"
next-line-add-newlines nil
truncate-lines t
- ;;SES deliberately puts lots of trailing whitespace in its buffer
+ ;; SES deliberately puts lots of trailing whitespace in its buffer.
show-trailing-whitespace nil
- ;;Cell ranges do not work reasonably without this
+ ;; Cell ranges do not work reasonably without this.
transient-mark-mode t
- ;;not to use tab characters for safe
- ;;(tabs may do bad for column calculation)
+ ;; Not to use tab characters for safe (tabs may do bad for column
+ ;; calculation).
indent-tabs-mode nil)
(1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t))
(1value (add-hook 'before-revert-hook 'ses-cleanup nil t))
- (setq ses--curcell nil
- ses--deferred-recalc nil
- ses--deferred-write nil
- ses--header-hscroll -1 ;Flag for "initial recalc needed"
- header-line-format '(:eval (progn
+ (setq header-line-format '(:eval (progn
(when (/= (window-hscroll)
ses--header-hscroll)
- ;;Reset ses--header-hscroll first, to
- ;;avoid recursion problems when
- ;;debugging ses-create-header-string
+ ;; Reset ses--header-hscroll first,
+ ;; to avoid recursion problems when
+ ;; debugging ses-create-header-string
(setq ses--header-hscroll
(window-hscroll))
(ses-create-header-string))
(was-modified (buffer-modified-p)))
(save-excursion
(if was-empty
- ;;Initialize buffer to contain one cell, for now
+ ;; Initialize buffer to contain one cell, for now.
(insert ses-initial-file-contents))
(ses-load)
(ses-setup))
(when was-empty
- (unless (equal ses-initial-default-printer (1value ses--default-printer))
+ (unless (equal ses-initial-default-printer
+ (1value ses--default-printer))
(1value (ses-read-default-printer ses-initial-default-printer)))
(unless (= ses-initial-column-width (1value (ses-col-width 0)))
(1value (ses-set-column-width 0 ses-initial-column-width)))
(buffer-enable-undo)
(goto-char (point-min))))
(use-local-map ses-mode-map)
- ;;Set the deferred narrowing flag (we can't narrow until after
- ;;after-find-file completes). If .ses is on the auto-load alist and the
- ;;file has "mode: ses", our ses-mode function will be called twice! Use
- ;;a special flag to detect this (will be reset by ses-command-hook).
- ;;For find-alternate-file, post-command-hook doesn't get run for some
- ;;reason, so use an idle timer to make sure.
+ ;; Set the deferred narrowing flag (we can't narrow until after
+ ;; after-find-file completes). If .ses is on the auto-load alist and the
+ ;; file has "mode: ses", our ses-mode function will be called twice! Use a
+ ;; special flag to detect this (will be reset by ses-command-hook). For
+ ;; find-alternate-file, post-command-hook doesn't get run for some reason,
+ ;; so use an idle timer to make sure.
(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)
writes that have been deferred. If buffer-narrowing has been deferred,
narrows the buffer now."
(condition-case err
- (when (eq major-mode 'ses-mode) ;Otherwise, not our buffer anymore
+ (when (eq major-mode 'ses-mode) ; Otherwise, not our buffer anymore.
(when ses--deferred-recalc
- ;;We reset the deferred list before starting on the recalc -- in case
- ;;of error, we don't want to retry the recalc after every keystroke!
+ ;; We reset the deferred list before starting on the recalc --- in
+ ;; case of error, we don't want to retry the recalc after every
+ ;; keystroke!
+ (ses-initialize-Dijkstra-attempt)
(let ((old ses--deferred-recalc))
(setq ses--deferred-recalc nil)
(ses-update-cells old)))
(when ses--deferred-write
- ;;We don't reset the deferred list before starting -- the most
- ;;likely error is keyboard-quit, and we do want to keep trying
- ;;these writes after a quit.
+ ;; We don't reset the deferred list before starting --- the most
+ ;; likely error is keyboard-quit, and we do want to keep trying these
+ ;; writes after a quit.
(ses-write-cells)
(push '(apply ses-widen) buffer-undo-list))
(when ses--deferred-narrow
- ;;We're not allowed to narrow the buffer until after-find-file has
- ;;read the local variables at the end of the file. Now it's safe to
- ;;do the narrowing.
+ ;; We're not allowed to narrow the buffer until after-find-file has
+ ;; read the local variables at the end of the file. Now it's safe to
+ ;; do the narrowing.
(narrow-to-region (point-min) ses--data-marker)
(setq ses--deferred-narrow nil))
- ;;Update the modeline
+ ;; Update the modeline.
(let ((oldcell ses--curcell))
(ses-set-curcell)
(unless (eq ses--curcell oldcell)
"-"
(symbol-name (cdr ses--curcell))))))
(force-mode-line-update)))
- ;;Use underline overlay for single-cells only, turn off otherwise
+ ;; Use underline overlay for single-cells only, turn off otherwise.
(if (listp ses--curcell)
(move-overlay ses--curcell-overlay 2 2)
(let ((next (next-single-property-change (point) 'intangible)))
(move-overlay ses--curcell-overlay (point) (1- next))))
(when (not (pos-visible-in-window-p))
- ;;Scrolling will happen later
+ ;; Scrolling will happen later.
(run-with-idle-timer 0.01 nil 'ses-command-hook)
(setq ses--curcell t)))
- ;;Prevent errors in this post-command-hook from silently erasing the hook!
+ ;; Prevent errors in this post-command-hook from silently erasing the hook!
(error
(unless executing-kbd-macro
(ding))
(message "%s" (error-message-string err))))
- nil) ;Make coverage-tester happy
+ nil) ; Make coverage-tester happy.
(defun ses-create-header-string ()
"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
+ ;; Leave room for the left-side fringe and scrollbar.
(push (propertize " " 'display '((space :align-to 0))) result)
(dotimes (col ses--numcols)
(setq width (ses-col-width col)
totwidth (+ totwidth width 1))
(if (= totwidth 1)
- ;;Scrolled so intercolumn space is leftmost
+ ;; Scrolled so intercolumn space is leftmost.
(push " " result))
(when (> totwidth 1)
(if (> ses--header-row 0)
'display `((space :align-to ,(1- totwidth)))
'face ses-box-prop)
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!
+ ;; 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))))
result)))
(if (> ses--header-row 0)
(search-forward ses-print-data-boundary)
(backward-char (length ses-print-data-boundary))
(delete-region (point-min) (point))
- ;;Insert all blank lines before printing anything, so ses-print-cell can
- ;;find the data area when inserting or deleting *skip* values for cells
+ ;; Insert all blank lines before printing anything, so ses-print-cell can
+ ;; find the data area when inserting or deleting *skip* values for cells.
(dotimes (row ses--numrows)
(insert-and-inherit ses--blank-line))
(dotimes-with-progress-reporter (row ses--numrows) "Reprinting..."
(if (eq (ses-cell-value row 0) '*skip*)
- ;;Column deletion left a dangling skip
+ ;; Column deletion left a dangling skip.
(ses-set-cell row 0 'value nil))
(dotimes (col ses--numcols)
(ses-print-cell row col))
(beginning-of-line 2))
(ses-jump-safe startcell)))
+(defun ses-initialize-Dijkstra-attempt ()
+ (setq ses--Dijkstra-attempt-nb (1+ ses--Dijkstra-attempt-nb)
+ ses--Dijkstra-weight-bound (* ses--numrows ses--numcols)))
+
(defun ses-recalculate-cell ()
"Recalculate and reprint the current cell or range.
(interactive "*")
(ses-check-curcell 'range)
(ses-begin-change)
- (let (sig)
+ (ses-initialize-Dijkstra-attempt)
+ (let (sig cur-rowcol)
(setq ses-start-time (float-time))
(if (atom ses--curcell)
- (setq sig (ses-sym-rowcol ses--curcell)
- sig (ses-calculate-cell (car sig) (cdr sig) t))
- ;;First, recalculate all cells that don't refer to other cells and
- ;;produce a list of cells with references.
+ (when
+ (setq cur-rowcol (ses-sym-rowcol ses--curcell)
+ sig (progn
+ (ses-cell-property-set :ses-Dijkstra-attempt
+ (cons ses--Dijkstra-attempt-nb 0)
+ (car cur-rowcol) (cdr cur-rowcol) )
+ (ses-calculate-cell (car cur-rowcol) (cdr cur-rowcol) t)))
+ (nconc sig (list (ses-cell-symbol (car cur-rowcol)
+ (cdr cur-rowcol)))))
+ ;; First, recalculate all cells that don't refer to other cells and
+ ;; produce a list of cells with references.
(ses-dorange ses--curcell
(ses-time-check "Recalculating... %s" '(ses-cell-symbol row col))
(condition-case nil
(progn
- ;;The t causes an error if the cell has references.
- ;;If no references, the t will be the result value.
+ ;; The t causes an error if the cell has references. If no
+ ;; references, the t will be the result value.
(1value (ses-formula-references (ses-cell-formula row col) t))
- (setq sig (ses-calculate-cell row col t)))
+ (ses-cell-property-set :ses-Dijkstra-attempt
+ (cons ses--Dijkstra-attempt-nb 0)
+ row col)
+ (when (setq sig (ses-calculate-cell row col t))
+ (nconc sig (list (ses-cell-symbol row col)))))
(wrong-type-argument
- ;;The formula contains a reference
+ ;; The formula contains a reference.
(add-to-list 'ses--deferred-recalc (ses-cell-symbol row col))))))
- ;;Do the update now, so we can force recalculation
+ ;; Do the update now, so we can force recalculation.
(let ((x ses--deferred-recalc))
(setq ses--deferred-recalc nil)
(condition-case hold
(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))
(col (cdr rowcol)))
(when (and (< col (1- ses--numcols)) ;;Last column can't spill over, anyway
(eq (ses-cell-value row (1+ col)) '*skip*))
- ;;This cell has spill-over. We'll momentarily pretend the following
- ;;cell has a `t' in it.
+ ;; This cell has spill-over. We'll momentarily pretend the following cell
+ ;; has a `t' in it.
(eval `(let ((,(ses-cell-symbol row (1+ col)) t))
(ses-print-cell row col)))
- ;;Now remove the *skip*. ses-print-cell is always nil here
+ ;; Now remove the *skip*. ses-print-cell is always nil here.
(ses-set-cell row (1+ col) 'value nil)
(1value (ses-print-cell row (1+ col))))))
(let (x yrow ycol)
;;Delete old reference lists
(dotimes-with-progress-reporter
- (row ses--numrows) "Deleting references..."
+ (row ses--numrows) "Deleting references..."
(dotimes (col ses--numcols)
(ses-set-cell row col 'references nil)))
;;Create new reference lists
(dotimes-with-progress-reporter
- (row ses--numrows) "Computing references..."
+ (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)
(ses-set-cell yrow ycol 'references
(cons (ses-cell-symbol row col)
(ses-cell-references yrow ycol)))))))
- ;;Delete everything and reconstruct basic data area
+ ;; Delete everything and reconstruct basic data area.
(ses-widen)
(let ((inhibit-read-only t))
(goto-char (point-max))
(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
+ ;; Buffer is quite screwed up --- can't even save the user-specified
+ ;; locals.
(delete-region (point-min) (point-max))
(insert ses-initial-file-trailer)
(goto-char (point-min)))
- ;;Create a blank display area
+ ;; Create a blank display area.
(dotimes (row ses--numrows)
(insert ses--blank-line))
(insert ses-print-data-boundary)
(backward-char (1- (length ses-print-data-boundary)))
(setq ses--data-marker (point-marker))
(forward-char (1- (length ses-print-data-boundary)))
- ;;Placeholders for cell data
+ ;; Placeholders for cell data.
(insert (make-string (* ses--numrows (1+ ses--numcols)) ?\n))
- ;;Placeholders for col-widths, col-printers, default-printer, header-row
+ ;; Placeholders for col-widths, col-printers, default-printer, header-row.
(insert "\n\n\n\n")
(insert ses-initial-global-parameters)
(backward-char (1- (length ses-initial-global-parameters)))
(setq initial (format "'%S" (cadr formula)))
(setq initial (prin1-to-string formula)))
(if (stringp formula)
- ;;Position cursor inside close-quote
+ ;; Position cursor inside close-quote.
(setq initial (cons initial (length initial))))
(list row col
(read-from-minibuffer (format "Cell %s: " ses--curcell)
initial
ses-mode-edit-map
- t ;Convert to Lisp object
+ t ; Convert to Lisp object.
'ses-read-cell-history)))))
(when (ses-warn-unsafe newval 'unsafep)
(ses-begin-change)
(cons (if (equal initial "\"") "\"\""
(if (equal initial "(") "()" initial)) 2)
ses-mode-edit-map
- t ;Convert to Lisp object
+ t ; Convert to Lisp object.
'ses-read-cell-history
(prin1-to-string (if (eq (car-safe curval) 'ses-safe-formula)
(cadr curval)
curval))))))
(when (ses-edit-cell row col newval)
- (ses-command-hook) ;Update cell widths before movement
+ (ses-command-hook) ; Update cell widths before movement.
(dolist (x ses-after-entry-functions)
(funcall x 1))))
(list (car rowcol)
(cdr rowcol)
(if (string= newval "")
- nil ;Don't create zero-length symbols!
+ nil ; Don't create zero-length symbols!
(list 'quote (intern newval))))))
(when (ses-edit-cell row col symb)
- (ses-command-hook) ;Update cell widths before movement
+ (ses-command-hook) ; Update cell widths before movement.
(dolist (x ses-after-entry-functions)
(funcall x 1))))
(ses-check-curcell 'end)
(ses-begin-change)
(dotimes (x count)
- (backward-char 1) ;Will signal 'beginning-of-buffer if appropriate
+ (backward-char 1) ; Will signal 'beginning-of-buffer if appropriate.
(ses-set-curcell)
(let ((rowcol (ses-sym-rowcol ses--curcell)))
(ses-clear-cell (car rowcol) (cdr rowcol))))))
(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 "")
(substring prompt 0 -2)
default)))
(let ((new (read-from-minibuffer prompt
- nil ;Initial contents
+ nil ; Initial contents.
ses-mode-edit-map
- t ;Evaluate the result
+ t ; Evaluate the result.
'ses-read-printer-history
(prin1-to-string default))))
(if (equal new default)
- ;;User changed mind, decided not to change printer
+ ;; User changed mind, decided not to change printer.
(setq new t)
(ses-printer-validate new)
(or (not new)
(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-relocate-all)
(ses-goto-data row col)
(insert ?\n))
- ;;Insert column width and printer
+ ;; Insert column width and printer.
(setq widths (ses-vector-insert widths col width)
printers (ses-vector-insert printers col printer)))
(ses-set-parameter 'ses--col-widths widths)
(ses-reprint-all t)
(when (or (> (length (ses-call-printer printer)) 0)
(> (length (ses-call-printer ses--default-printer)) 0))
- ;;Either column printer or global printer inserts some constant text
- ;;Reprint the new columns to insert that text.
+ ;; Either column printer or global printer inserts some constant text.
+ ;; Reprint the new columns to insert that text.
(dotimes (x ses--numrows)
(dotimes (y count)
- ;Always nil here - this is a blank column
+ ;; Always nil here --- this is a blank column.
(1value (ses-print-cell-new-width x (+ y col))))))
(ses-setup)))
(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))
inserts a new row if at bottom of print area. Repeat COUNT times."
(interactive "p")
(ses-check-curcell 'end)
- (setq deactivate-mark t) ;Doesn't combine well with ranges
+ (setq deactivate-mark t) ; Doesn't combine well with ranges.
(dotimes (x count)
(ses-set-curcell)
(if (not ses--curcell)
- (progn ;At bottom of print area
+ (progn ; At bottom of print area.
(barf-if-buffer-read-only)
(ses-insert-row 1))
(let ((col (cdr (ses-sym-rowcol ses--curcell))))
(when (/= 32
(char-before (next-single-property-change (point)
'intangible)))
- ;;We're already in last nonskipped cell on line. Need to create a
- ;;new column.
+ ;; We're already in last nonskipped cell on line. Need to create a
+ ;; new column.
(barf-if-buffer-read-only)
(ses-insert-column (- count x)
ses--numcols
(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)
(read-from-minibuffer (format "Column %s width [currently %d]: "
(ses-column-letter col)
(ses-col-width col))
- nil ;No initial contents
- nil ;No override keymap
- t ;Convert to Lisp object
- nil ;No history
+ nil ; No initial contents.
+ nil ; No override keymap.
+ t ; Convert to Lisp object.
+ nil ; No history.
(number-to-string
- (ses-col-width col))))))) ;Default value
+ (ses-col-width col))))))) ; Default value.
(if (< newwidth 1)
(error "Invalid column width"))
(ses-begin-change)
(if (not (and (eq major-mode '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
+ ad-do-it ; Normal copy-region-as-kill.
(kill-new (ses-copy-region beg end))
(if transient-mark-mode
(setq deactivate-mark t))
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', so we have to use subterfuge.
+ ;; For some reason, the text-read-only error is not caught by `delete-region',
+ ;; so we have to use subterfuge.
(let ((buffer-read-only t))
(1value (condition-case x
(noreturn (funcall (lookup-key (current-global-map)
(this-command-keys))
beg end))
- (buffer-read-only nil)))) ;The expected error
- ;;Because the buffer was marked read-only, the kill command turned itself
- ;;into a copy. Now we clear the cells or signal the error. First we
- ;;check whether the buffer really is read-only.
+ (buffer-read-only nil)))) ; The expected error.
+ ;; Because the buffer was marked read-only, the kill command turned itself
+ ;; into a copy. Now we clear the cells or signal the error. First we check
+ ;; whether the buffer really is read-only.
(barf-if-buffer-read-only)
(ses-begin-change)
(ses-dorange ses--curcell
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
as symbols."
(if (not (and (eq major-mode 'ses-mode)
(eq (get-text-property (point) 'keymap) 'ses-mode-print-map)))
- ad-do-it ;Normal non-SES yank
+ ad-do-it ; Normal non-SES yank.
(ses-check-curcell 'end)
(push-mark (point))
(let ((text (current-kill (cond
text
0
(if (memq (aref text (1- (length text))) '(?\t ?\n))
- ;;Just one cell - delete final tab or newline
+ ;; Just one cell --- delete final tab or newline.
(1- (length text)))
arg)))
(if (consp arg)
(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
pos (next-single-property-change pos 'ses text)
x (ses-sym-rowcol (car last)))
(if (not last)
- ;;Newline - all remaining cells on row are skipped
+ ;; Newline --- all remaining cells on row are skipped.
(setq x (cons (- myrow rowincr) (+ needcols colincr -1))
last (list nil nil nil)
pos (1- pos)))
(if (/= (car x) (- myrow rowincr))
(error "Cell row error"))
(if (< (- mycol colincr) (cdr x))
- ;;Some columns were skipped
+ ;; Some columns were skipped.
(let ((oldcol mycol))
(while (< (- mycol colincr) (cdr x))
(ses-clear-cell myrow mycol)
(setq col (1+ col)
mycol (1+ mycol)))
- (ses-print-cell myrow (1- oldcol)))) ;;This inserts *skip*
- (when (car last) ;Skip this for *skip* cells
+ (ses-print-cell myrow (1- oldcol)))) ;; This inserts *skip*.
+ (when (car last) ; Skip this for *skip* cells.
(setq x (nth 2 last))
(unless (equal x (ses-cell-printer myrow mycol))
(or (not x)
(error (cons nil from)))))
(cond
((< (cdr val) (or to (length text)))
- ;;Invalid sexp - leave it as a string
+ ;; Invalid sexp --- leave it as a string.
(setq val (substring text from to)))
((and (car val) (symbolp (car val)))
(if (consp arg)
- (setq val (list 'quote (car val))) ;Keep symbol
- (setq val (substring text from to)))) ;Treat symbol as text
+ (setq val (list 'quote (car val))) ; Keep symbol.
+ (setq val (substring text from to)))) ; Treat symbol as text.
(t
(setq val (car val))))
(let ((row (car rowcol))
(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))))
"Move point to last cell on line."
(interactive)
(ses-check-curcell 'end 'range)
- (when ses--curcell ;Otherwise we're at the bottom row, which is empty anyway
+ (when ses--curcell ; Otherwise we're at the bottom row, which is empty
+ ; anyway.
(let ((col (1- ses--numcols))
row rowcol)
(if (symbolp ses--curcell)
- ;;Single cell
+ ;; Single cell.
(setq row (car (ses-sym-rowcol ses--curcell)))
- ;;Range - use whichever end of the range the point is at
+ ;; Range --- use whichever end of the range the point is at.
(setq rowcol (ses-sym-rowcol (if (< (point) (mark))
(car ses--curcell)
(cdr ses--curcell))))
- ;;If range already includes the last cell in a row, point is actually
- ;;in the following row
+ ;; If range already includes the last cell in a row, point is actually
+ ;; in the following row.
(if (<= (cdr rowcol) (1- col))
(setq row (car rowcol))
(setq row (1+ (car rowcol)))
(if (= row ses--numrows)
;;Already at end - can't go anywhere
(setq col 0))))
- (when (< row ses--numrows) ;Otherwise it's a range that includes last cell
+ (when (< row ses--numrows) ; Otherwise it's a range that includes last cell.
(while (eq (ses-cell-value row col) '*skip*)
- ;;Back to beginning of multi-column cell
+ ;; Back to beginning of multi-column cell.
(setq col (1- col)))
(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)))
(interactive "*e\nP")
(setq event (event-end event))
(select-window (posn-window event))
- (setq event (car (posn-col-row event))) ;Click column
+ (setq event (car (posn-col-row event))) ; Click column.
(let ((col 0))
(while (and (< col ses--numcols) (> event (ses-col-width col)))
(setq event (- event (ses-col-width col) 1)
(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)
(with-current-buffer (window-buffer minibuffer-scroll-window)
- (ses-command-hook) ;For ses-coverage
+ (ses-command-hook) ; For ses-coverage.
(ses-check-curcell 'needrange)
(setq x (cdr (macroexpand `(ses-range ,(car ses--curcell)
,(cdr ses--curcell))))))
(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)
(with-current-buffer (window-buffer minibuffer-scroll-window)
- (ses-command-hook) ;For ses-coverage
+ (ses-command-hook) ; For ses-coverage.
(ses-check-curcell 'needrange)
(setq x (format "(ses-range %S %S)"
(car ses--curcell)
;;----------------------------------------------------------------------------
(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))
;; Standard formulas
;;----------------------------------------------------------------------------
-(defmacro ses-range (from to)
- "Expands to a list of cell-symbols for the range. 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
-alias for this macro!"
- (let (result)
+(defun ses--clean-! (&rest x)
+ "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."
+ (let ((ret x) ret-elt)
+ (while ret
+ (setq ret-elt (car ret))
+ (when (memq ret-elt '(nil *skip*))
+ (setcar ret y))
+ (setq ret (cdr ret))))
+ x)
+
+(defmacro ses-range (from to &rest rest)
+ "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
+alias for this macro!
+
+By passing in REST some flags one can configure the way the range
+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.
+
+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
+way `(ses-range A1 B2 ^>)' will evaluate to `(1 3 2 4)',
+while `(ses-range A1 B2 >^)' will evaluate to (3 4 1 2).
+
+If the range is one row, then `>' can be used as a shorthand to
+`>v' or `>^', and `<' to `<v' or `<^'.
+
+If the range is one column, then `v' can be used as a shorthand to
+`v>' or `v<', and `^' to `^>' or `v<'.
+
+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
+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
+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 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)
+ (reorient-x nil)
+ (reorient-y nil)
+ transpose vectorize
+ (clean 'list))
(ses-dorange (cons from to)
- (push (ses-cell-symbol row col) result))
- (cons 'list result)))
+ (when (/= prev-row row)
+ (push result-row result)
+ (setq result-row nil))
+ (push (ses-cell-symbol row col) result-row)
+ (setq prev-row row))
+ (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
+ (cond
+ ; shorthands one row
+ ((and (null (cddr result)) (memq x '(> <)))
+ (push (intern (concat (symbol-name x) "v")) rest))
+ ; shorthands one col
+ ((and (null (cdar result)) (memq x '(v ^)))
+ (push (intern (concat (symbol-name x) ">")) rest))
+ (t (error "Unexpected flag `%S' in ses-range" x)))))))
+ (if reorient-y
+ (setcdr (last result 2) nil)
+ (setq result (cdr (nreverse result))))
+ (unless reorient-x
+ (setq result (mapcar 'nreverse result)))
+ (when transpose
+ (let ((ret (mapcar (lambda (x) (list x)) (pop result))) iter)
+ (while result
+ (setq iter ret)
+ (dolist (elt (pop result))
+ (setcar iter (cons elt (car iter)))
+ (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)))))))
(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))
;; Standard print functions
;;----------------------------------------------------------------------------
-;;These functions use the variables 'row' and 'col' that are
-;;dynamically bound by ses-print-cell. We define these variables at
-;;compile-time to make the compiler happy.
-(eval-when-compile
- (dolist (x '(row col))
- (make-local-variable x)
- (set x nil)))
+;; These functions use the variables 'row' and 'col' that are dynamically bound
+;; by ses-print-cell. We define these variables at compile-time to make the
+;; compiler happy.
+(defvar row)
+(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)
(setq value (ses-call-printer printer value))
(dotimes (x span)
(setq width (+ width 1 (ses-col-width (+ col span (- x))))))
- ;; set column width
+ ;; Set column width.
(setq width (- width (string-width value)))
(if (<= width 0)
- value ;Too large for field, anyway
+ value ; Too large for field, anyway.
(setq half (make-string (/ width 2) fill))
(concat half value half
(if (> (% width 2) 0) (char-to-string fill))))))
(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!
(dolist (fun '(copy-region-as-kill yank))
(ad-remove-advice fun 'around (intern (concat "ses-" (symbol-name fun))))
(ad-update fun))
- (save-current-buffer
- (dolist (buf (buffer-list))
- (set-buffer buf)
- (when (eq major-mode 'ses-mode)
- (funcall (or (default-value 'major-mode) 'fundamental-mode)))))
;; continue standard unloading
nil)
HCoop / bpt / emacs.git / blobdiff