mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-15 10:30:25 -08:00
Make ses-range environment agnostic.
* lisp/ses.el (ses-sym-rowcol): Do not make border effect on interned symbols. (ses-formula-references): Do not use ses-range implementation any longer, as the ses-range is now environnement agnostic, and as such do not expand any longer to a list of symbols. (ses-range): Do not make border effect on interned symbols, and be environment agnostic. As such ses-range macro now expand to a sexp the evaluation of which yields a list of symbol, and no longer to a list of symbol with some function call to make it evaluate to the list of values. * test/lisp/ses-tests.el (ses-expand-range): New test.
This commit is contained in:
Vincent Belaïche
Vincent Belaïche
parent
5a8c993eb3
commit
ab7d6fbe88
2 changed files with 137 additions and 76 deletions
166
lisp/ses.el
166
lisp/ses.el
|
|
@ -463,10 +463,11 @@ functions refer to its value."
|
|||
"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."
|
||||
(declare (debug t))
|
||||
`(let ((rc (and (symbolp ,sym) (get ,sym 'ses-cell))))
|
||||
(if (eq rc :ses-named)
|
||||
(and ses--named-cell-hashmap (gethash ,sym ses--named-cell-hashmap))
|
||||
rc)))
|
||||
(let ((rc (make-symbol "rc")))
|
||||
`(let ((,rc (and (symbolp ,sym) (get ,sym 'ses-cell))))
|
||||
(if (eq ,rc :ses-named)
|
||||
(and ses--named-cell-hashmap (gethash ,sym ses--named-cell-hashmap))
|
||||
,rc))))
|
||||
|
||||
(defun ses-cell-p (cell)
|
||||
"Return non-nil if CELL is a cell of current buffer."
|
||||
|
|
@ -1531,11 +1532,11 @@ first reference is found."
|
|||
(if (consp formula)
|
||||
(cond
|
||||
((eq (car formula) 'ses-range)
|
||||
(dolist (cur
|
||||
(cdr (funcall 'macroexpand
|
||||
(list 'ses-range (nth 1 formula)
|
||||
(nth 2 formula)))))
|
||||
(cl-pushnew cur result-so-far :test #'equal)))
|
||||
;; simplified implementation of ses-range where we output
|
||||
;; symbols rather than values, and when all the flags
|
||||
;; handling is skipped
|
||||
(ses-dorange (cons (nth 1 formula) (nth 2 formula))
|
||||
(cl-pushnew (ses-cell-symbol row col) result-so-far :test #'equal)))
|
||||
((null (eq (car formula) 'quote))
|
||||
;;Recursive call for subformulas
|
||||
(dolist (cur formula)
|
||||
|
|
@ -3986,75 +3987,90 @@ 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)
|
||||
(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)))
|
||||
(pcase x
|
||||
('>v (setq transpose nil reorient-x nil reorient-y nil))
|
||||
('>^ (setq transpose nil reorient-x nil reorient-y t))
|
||||
('<^ (setq transpose nil reorient-x t reorient-y t))
|
||||
('<v (setq transpose nil reorient-x t reorient-y nil))
|
||||
('v> (setq transpose t reorient-x nil reorient-y t))
|
||||
('^> (setq transpose t reorient-x nil reorient-y nil))
|
||||
('^< (setq transpose t reorient-x t reorient-y nil))
|
||||
('v< (setq transpose t reorient-x t reorient-y t))
|
||||
((or '* '*2 '*1) (setq vectorize x))
|
||||
('! (setq clean 'ses--clean-!))
|
||||
('_ (setq clean `(lambda (&rest x)
|
||||
(ses--clean-_ x ,(if rest (pop rest) 0)))))
|
||||
(_
|
||||
(cond
|
||||
;; Note ses-formula-references contains some simplified code for ses-range.
|
||||
(let ((result-row (make-symbol "result-row"))
|
||||
(result (make-symbol "result"))
|
||||
(prev-row (make-symbol "prev-row"))
|
||||
(reorient-x (make-symbol "reorient-x"))
|
||||
(reorient-y (make-symbol "reorient-y"))
|
||||
(transpose (make-symbol "transpose"))
|
||||
(vectorize (make-symbol "vectorize"))
|
||||
(clean (make-symbol "clean"))
|
||||
(elt (make-symbol "elt"))
|
||||
(x (make-symbol "x"))
|
||||
(iter (make-symbol "iter"))
|
||||
(rest-arg (make-symbol "rest-arg"))
|
||||
(ret (make-symbol "ret")))
|
||||
`(let (,result-row
|
||||
,result
|
||||
(,prev-row -1)
|
||||
,reorient-x
|
||||
,reorient-y
|
||||
,transpose ,vectorize
|
||||
(,clean #'list)
|
||||
(,rest-arg (quote ,rest)))
|
||||
(ses-dorange (cons (quote ,from) (quote ,to))
|
||||
(when (/= ,prev-row row)
|
||||
(push ,result-row ,result)
|
||||
(setq ,result-row nil))
|
||||
(push (ses-cell-value row col) ,result-row)
|
||||
(setq ,prev-row row))
|
||||
(push ,result-row ,result)
|
||||
(while ,rest-arg
|
||||
(let ((,x (pop ,rest-arg)))
|
||||
(pcase ,x
|
||||
('>v (setq ,transpose nil ,reorient-x nil ,reorient-y nil))
|
||||
('>^ (setq ,transpose nil ,reorient-x nil ,reorient-y t))
|
||||
('<^ (setq ,transpose nil ,reorient-x t ,reorient-y t))
|
||||
('<v (setq ,transpose nil ,reorient-x t ,reorient-y nil))
|
||||
('v> (setq ,transpose t ,reorient-x nil ,reorient-y t))
|
||||
('^> (setq ,transpose t ,reorient-x nil ,reorient-y nil))
|
||||
('^< (setq ,transpose t ,reorient-x t ,reorient-y nil))
|
||||
('v< (setq ,transpose t ,reorient-x t ,reorient-y t))
|
||||
((or '* '*2 '*1) (setq ,vectorize ,x))
|
||||
('! (setq ,clean #'ses--clean-!))
|
||||
('_ (setq ,clean `(lambda (&rest x)
|
||||
(ses--clean-_ x ,(if ,rest-arg (pop ,rest-arg) 0)))))
|
||||
(_
|
||||
(cond
|
||||
; shorthands one row
|
||||
((and (null (cdar ,result)) (memq x '(> <)))
|
||||
(push (intern (concat (symbol-name x) "v")) rest))
|
||||
((and (null (cdar ,result)) (memq ,x '(> <)))
|
||||
(push (intern (concat (symbol-name ,x) "v")) ,rest-arg))
|
||||
; 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 #'list (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)))
|
||||
((and (null (cdar ,result)) (memq ,x '(v ^)))
|
||||
(push (intern (concat (symbol-name ,x) ">")) ,rest-arg))
|
||||
(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 #'list (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)))
|
||||
|
||||
(cl-flet ((vectorize-*1
|
||||
(clean result)
|
||||
(cons clean (cons (quote 'vec) (apply #'append result))))
|
||||
(vectorize-*2
|
||||
(clean result)
|
||||
(cons clean (cons (quote 'vec)
|
||||
(mapcar (lambda (x)
|
||||
(cons clean (cons (quote 'vec) x)))
|
||||
result)))))
|
||||
(pcase vectorize
|
||||
('nil (cons clean (apply #'append result)))
|
||||
('*1 (vectorize-*1 clean result))
|
||||
('*2 (vectorize-*2 clean result))
|
||||
('* (funcall (if (cdr result)
|
||||
#'vectorize-*2
|
||||
#'vectorize-*1)
|
||||
clean result))))))
|
||||
(cl-flet ((vectorize-*1
|
||||
(clean result)
|
||||
(apply clean (cons 'vec (apply #'append result))))
|
||||
(vectorize-*2
|
||||
(clean result)
|
||||
(apply clean (cons 'vec
|
||||
(mapcar (lambda (x)
|
||||
(apply clean (cons 'vec x)))
|
||||
result)))))
|
||||
(pcase ,vectorize
|
||||
('nil (apply ,clean (apply #'append ,result)))
|
||||
('*1 (vectorize-*1 ,clean ,result))
|
||||
('*2 (vectorize-*2 ,clean ,result))
|
||||
('* (funcall (if (cdr ,result)
|
||||
#'vectorize-*2
|
||||
#'vectorize-*1)
|
||||
,clean ,result)))))))
|
||||
|
||||
(defun ses-delete-blanks (&rest args)
|
||||
"Return ARGS reversed, with the blank elements (nil and *skip*) removed."
|
||||
|
|
|
|||
|
|
@ -109,7 +109,7 @@ to (1+ ses--foo), makes A2 value equal to 2."
|
|||
|
||||
(ert-deftest ses-tests-renamed-cell-after-setting ()
|
||||
"Check that setting A1 to 1 and A2 to (1+ A1), and then
|
||||
renaming A1 to `ses--foo' makes `ses--foo' value equal to 2."
|
||||
renaming A2 to `ses--foo' makes `ses--foo' value equal to 2."
|
||||
(let ((ses-initial-size '(2 . 1)))
|
||||
(with-temp-buffer
|
||||
(ses-mode)
|
||||
|
|
@ -241,6 +241,51 @@ to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to
|
|||
(ses-command-hook)
|
||||
(should (eq (ses--cell-at-pos (point)) 'ses--toto)))))
|
||||
|
||||
(ert-deftest ses-expand-range ()
|
||||
"Test `ses-range' expansion works well even if the current buffer is not a SES buffer during expansion."
|
||||
(let ((ses-initial-size '(4 . 3))
|
||||
ses-after-entry-functions
|
||||
(ses-buffer (generate-new-buffer "*SES tests*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer ses-buffer
|
||||
(ses-mode)
|
||||
(dolist (c '([0 0 1] [1 0 2] [2 0 3]))
|
||||
(ses-set-cell (aref c 0) (aref c 1) 'value (aref c 2)))
|
||||
(dolist (c '((0 1 (* 2 A1)) (1 1 (* 2 A2)) (2 1 (* 2 A3))))
|
||||
(apply 'ses-cell-set-formula c)
|
||||
(apply 'ses-calculate-cell (list (car c) (cadr c) nil))))
|
||||
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 A3 v))
|
||||
'(1 2 3)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 A3 ^))
|
||||
'(3 2 1)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 B3 >v))
|
||||
'(1 2 2 4 3 6)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 B3 >^))
|
||||
'(3 6 2 4 1 2)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 B3 <v))
|
||||
'(2 1 4 2 6 3)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 B3 <^))
|
||||
'(6 3 4 2 2 1)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 A3 v !))
|
||||
'(1 2 3)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 B4 >v !))
|
||||
'(1 2 2 4 3 6)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 A4 v _ 10))
|
||||
'(1 2 3 10)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 B4 >v _ 10))
|
||||
'(1 2 2 4 3 6 10 10)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 A3 v *))
|
||||
'(vec 1 2 3)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 A3 v *1))
|
||||
'(vec 1 2 3)))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 A3 v *2))
|
||||
'(vec (vec 1 2 3))))
|
||||
(should (equal (with-current-buffer ses-buffer (ses-range A1 A3 > *2))
|
||||
'(vec (vec 1) (vec 2) (vec 3)))))
|
||||
(kill-buffer ses-buffer))))
|
||||
|
||||
(ert-deftest ses-set-formula-write-cells-with-changed-references ()
|
||||
"Test fix of bug#5852.
|
||||
When setting a formula has some cell with changed references, this
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue