aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJay Belanger2004-11-19 21:03:48 +0000
committerJay Belanger2004-11-19 21:03:48 +0000
commit40ead937150cf5654640b26f3702cf650c0452bf (patch)
treee558f77eddae9ac324cbc36358d23e6dc3fce834
parent6de891db98164cc4981a953257dec7fc7c97f2b1 (diff)
downloademacs-40ead937150cf5654640b26f3702cf650c0452bf.tar.gz
emacs-40ead937150cf5654640b26f3702cf650c0452bf.zip
(calc-rewrite-selection): Make rules a local variable.
(calc-rewr-sel): New variable. (calc-rewrite-selection, calc-locate-selection-marker, calc-rewrite): Use the declared variable calc-rewr-sel instead of sel. (math-rewrite): Use let* to declare variables. (math-mt-many): Declare it. (math-rewrite-whole-expr): New variable. (math-rewrite, math-rewrite-phase): Replace variable expr by declared variable. (math-import-list): Declare it. (math-rewrite-heads-heads, math-rewrite-heads-skips) (math-rewrite-heads-blanks ): New variables. (math-rewrite-heads, math-rewrite-heads-rec): Replace variables heads, skips and blanks by declared variables. (math-regs, math-num-regs, math-prog-last, math-bound-vars) (math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering) (math-aliased-vars): Declare them. (math-rwcomp-subst-old, math-rwcomp-subst-new) (math-rwcomp-subst-old-func, math-rwcomp-subst-new-func): New variables. (math-rwcomp-substitute, math-rwcomp-subst-rec): Replace variables old, new, old-func and new-func by declared variables. (math-rwcomp-assoc-args, math-rwcomp-addsub-args): Remove unnecessary variable. (math-rewrite-phase): Declare it. (math-apply-rw-regs): New variable. (math-apply-rewrites, math-rwapply-replace-regs, math-rwapply-reg-looks-negp): Replace variable regs by declared variable. (math-apply-rw-ruleset): New variable. (math-apply-rewrites, math-rwapply-remember): Replace variable ruleset by declared variable.
-rw-r--r--lisp/calc/calc-rewr.el367
1 files changed, 220 insertions, 147 deletions
diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el
index fd361bd3eee..85e4700ef10 100644
--- a/lisp/calc/calc-rewr.el
+++ b/lisp/calc/calc-rewr.el
@@ -3,8 +3,7 @@
3;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. 3;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
4 4
5;; Author: David Gillespie <daveg@synaptics.com> 5;; Author: David Gillespie <daveg@synaptics.com>
6;; Maintainers: D. Goel <deego@gnufans.org> 6;; Maintainer: Jay Belanger <belanger@truman.edu>
7;; Colin Walters <walters@debian.org>
8 7
9;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
10 9
@@ -36,6 +35,11 @@
36 35
37 36
38(defvar math-rewrite-default-iters 100) 37(defvar math-rewrite-default-iters 100)
38
39;; The variable calc-rewr-sel is local to calc-rewrite-selection and
40;; calc-rewrite, but is used by calc-locate-selection-marker.
41(defvar calc-rewr-sel)
42
39(defun calc-rewrite-selection (rules-str &optional many prefix) 43(defun calc-rewrite-selection (rules-str &optional many prefix)
40 (interactive "sRewrite rule(s): \np") 44 (interactive "sRewrite rule(s): \np")
41 (calc-slow-wrapper 45 (calc-slow-wrapper
@@ -43,9 +47,10 @@
43 (let* ((num (max 1 (calc-locate-cursor-element (point)))) 47 (let* ((num (max 1 (calc-locate-cursor-element (point))))
44 (reselect t) 48 (reselect t)
45 (pop-rules nil) 49 (pop-rules nil)
50 rules
46 (entry (calc-top num 'entry)) 51 (entry (calc-top num 'entry))
47 (expr (car entry)) 52 (expr (car entry))
48 (sel (calc-auto-selection entry)) 53 (calc-rewr-sel (calc-auto-selection entry))
49 (math-rewrite-selections t) 54 (math-rewrite-selections t)
50 (math-rewrite-default-iters 1)) 55 (math-rewrite-default-iters 1))
51 (if (or (null rules-str) (equal rules-str "") (equal rules-str "$")) 56 (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
@@ -73,10 +78,10 @@
73 (if (eq many 0) 78 (if (eq many 0)
74 (setq many '(var inf var-inf)) 79 (setq many '(var inf var-inf))
75 (if many (setq many (prefix-numeric-value many)))) 80 (if many (setq many (prefix-numeric-value many))))
76 (if sel 81 (if calc-rewr-sel
77 (setq expr (calc-replace-sub-formula (car entry) 82 (setq expr (calc-replace-sub-formula (car entry)
78 sel 83 calc-rewr-sel
79 (list 'calcFunc-select sel))) 84 (list 'calcFunc-select calc-rewr-sel)))
80 (setq expr (car entry) 85 (setq expr (car entry)
81 reselect nil 86 reselect nil
82 math-rewrite-selections nil)) 87 math-rewrite-selections nil))
@@ -85,22 +90,22 @@
85 (math-rewrite 90 (math-rewrite
86 (calc-normalize expr) 91 (calc-normalize expr)
87 rules many))) 92 rules many)))
88 sel nil 93 calc-rewr-sel nil
89 expr (calc-locate-select-marker expr)) 94 expr (calc-locate-select-marker expr))
90 (or (consp sel) (setq sel nil)) 95 (or (consp calc-rewr-sel) (setq calc-rewr-sel nil))
91 (if pop-rules (calc-pop-stack 1)) 96 (if pop-rules (calc-pop-stack 1))
92 (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr) 97 (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
93 (- num (if pop-rules 1 0)) 98 (- num (if pop-rules 1 0))
94 (list (and reselect sel)))) 99 (list (and reselect calc-rewr-sel))))
95 (calc-handle-whys))) 100 (calc-handle-whys)))
96 101
97(defun calc-locate-select-marker (expr) ; changes "sel" 102(defun calc-locate-select-marker (expr)
98 (if (Math-primp expr) 103 (if (Math-primp expr)
99 expr 104 expr
100 (if (and (eq (car expr) 'calcFunc-select) 105 (if (and (eq (car expr) 'calcFunc-select)
101 (= (length expr) 2)) 106 (= (length expr) 2))
102 (progn 107 (progn
103 (setq sel (if sel t (nth 1 expr))) 108 (setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr)))
104 (nth 1 expr)) 109 (nth 1 expr))
105 (cons (car expr) 110 (cons (car expr)
106 (mapcar 'calc-locate-select-marker (cdr expr)))))) 111 (mapcar 'calc-locate-select-marker (cdr expr))))))
@@ -138,7 +143,7 @@
138 (setq many '(var inf var-inf)) 143 (setq many '(var inf var-inf))
139 (if many (setq many (prefix-numeric-value many)))) 144 (if many (setq many (prefix-numeric-value many))))
140 (setq expr (calc-normalize (math-rewrite expr rules many))) 145 (setq expr (calc-normalize (math-rewrite expr rules many)))
141 (let (sel) 146 (let (calc-rewr-sel)
142 (setq expr (calc-locate-select-marker expr))) 147 (setq expr (calc-locate-select-marker expr)))
143 (calc-pop-push-record-list n "rwrt" (list expr))) 148 (calc-pop-push-record-list n "rwrt" (list expr)))
144 (calc-handle-whys))) 149 (calc-handle-whys)))
@@ -165,33 +170,38 @@
165 (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))) 170 (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
166 171
167 172
168 173(defvar math-mt-many)
169(defun math-rewrite (whole-expr rules &optional math-mt-many) 174
170 (let ((crules (math-compile-rewrites rules)) 175;; The variable math-rewrite-whole-expr is local to math-rewrite,
171 (heads (math-rewrite-heads whole-expr)) 176;; but is used by math-rewrite-phase
172 (trace-buffer (get-buffer "*Trace*")) 177(defvar math-rewrite-whole-expr)
173 (calc-display-just 'center) 178
174 (calc-display-origin 39) 179(defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
175 (calc-line-breaking 78) 180 (let* ((crules (math-compile-rewrites rules))
176 (calc-line-numbering nil) 181 (heads (math-rewrite-heads math-rewrite-whole-expr))
177 (calc-show-selections t) 182 (trace-buffer (get-buffer "*Trace*"))
178 (calc-why nil) 183 (calc-display-just 'center)
179 (math-mt-func (function 184 (calc-display-origin 39)
180 (lambda (x) 185 (calc-line-breaking 78)
181 (let ((result (math-apply-rewrites x (cdr crules) 186 (calc-line-numbering nil)
182 heads crules))) 187 (calc-show-selections t)
183 (if result 188 (calc-why nil)
184 (progn 189 (math-mt-func (function
185 (if trace-buffer 190 (lambda (x)
186 (let ((fmt (math-format-stack-value 191 (let ((result (math-apply-rewrites x (cdr crules)
187 (list result nil nil)))) 192 heads crules)))
188 (save-excursion 193 (if result
189 (set-buffer trace-buffer) 194 (progn
190 (insert "\nrewrite to\n" fmt "\n")))) 195 (if trace-buffer
191 (setq heads (math-rewrite-heads result heads t)))) 196 (let ((fmt (math-format-stack-value
192 result))))) 197 (list result nil nil))))
198 (save-excursion
199 (set-buffer trace-buffer)
200 (insert "\nrewrite to\n" fmt "\n"))))
201 (setq heads (math-rewrite-heads result heads t))))
202 result)))))
193 (if trace-buffer 203 (if trace-buffer
194 (let ((fmt (math-format-stack-value (list whole-expr nil nil)))) 204 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
195 (save-excursion 205 (save-excursion
196 (set-buffer trace-buffer) 206 (set-buffer trace-buffer)
197 (setq truncate-lines t) 207 (setq truncate-lines t)
@@ -203,26 +213,27 @@
203 (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000)) 213 (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
204 (math-rewrite-phase (nth 3 (car crules))) 214 (math-rewrite-phase (nth 3 (car crules)))
205 (if trace-buffer 215 (if trace-buffer
206 (let ((fmt (math-format-stack-value (list whole-expr nil nil)))) 216 (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
207 (save-excursion 217 (save-excursion
208 (set-buffer trace-buffer) 218 (set-buffer trace-buffer)
209 (insert "\nDone rewriting" 219 (insert "\nDone rewriting"
210 (if (= math-mt-many 0) " (reached iteration limit)" "") 220 (if (= math-mt-many 0) " (reached iteration limit)" "")
211 ":\n" fmt "\n")))) 221 ":\n" fmt "\n"))))
212 whole-expr)) 222 math-rewrite-whole-expr))
213 223
214(defun math-rewrite-phase (sched) 224(defun math-rewrite-phase (sched)
215 (while (and sched (/= math-mt-many 0)) 225 (while (and sched (/= math-mt-many 0))
216 (if (listp (car sched)) 226 (if (listp (car sched))
217 (while (let ((save-expr whole-expr)) 227 (while (let ((save-expr math-rewrite-whole-expr))
218 (math-rewrite-phase (car sched)) 228 (math-rewrite-phase (car sched))
219 (not (equal whole-expr save-expr)))) 229 (not (equal math-rewrite-whole-expr save-expr))))
220 (if (symbolp (car sched)) 230 (if (symbolp (car sched))
221 (progn 231 (progn
222 (setq whole-expr (math-normalize (list (car sched) whole-expr))) 232 (setq math-rewrite-whole-expr
233 (math-normalize (list (car sched) math-rewrite-whole-expr)))
223 (if trace-buffer 234 (if trace-buffer
224 (let ((fmt (math-format-stack-value 235 (let ((fmt (math-format-stack-value
225 (list whole-expr nil nil)))) 236 (list math-rewrite-whole-expr nil nil))))
226 (save-excursion 237 (save-excursion
227 (set-buffer trace-buffer) 238 (set-buffer trace-buffer)
228 (insert "\ncall " 239 (insert "\ncall "
@@ -233,10 +244,10 @@
233 (save-excursion 244 (save-excursion
234 (set-buffer trace-buffer) 245 (set-buffer trace-buffer)
235 (insert (format "\n(Phase %d)\n" math-rewrite-phase)))) 246 (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
236 (while (let ((save-expr whole-expr)) 247 (while (let ((save-expr math-rewrite-whole-expr))
237 (setq whole-expr (math-normalize 248 (setq math-rewrite-whole-expr (math-normalize
238 (math-map-tree-rec whole-expr))) 249 (math-map-tree-rec math-rewrite-whole-expr)))
239 (not (equal whole-expr save-expr))))))) 250 (not (equal math-rewrite-whole-expr save-expr)))))))
240 (setq sched (cdr sched)))) 251 (setq sched (cdr sched))))
241 252
242(defun calcFunc-rewrite (expr rules &optional many) 253(defun calcFunc-rewrite (expr rules &optional many)
@@ -488,6 +499,28 @@
488 499
489(defvar math-rewrite-whole nil) 500(defvar math-rewrite-whole nil)
490(defvar math-make-import-list nil) 501(defvar math-make-import-list nil)
502
503;; The variable math-import-list is local to part of math-compile-rewrites,
504;; but is also used in a different part, and so the local version could
505;; be affected by the non-local version when math-compile-rewrites calls itself.
506(defvar math-import-list nil)
507
508;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars,
509;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
510;; math-aliased-vars are local to math-compile-rewrites,
511;; but are used by many functions math-rwcomp-*, which are called by
512;; math-compile-rewrites.
513(defvar math-regs)
514(defvar math-num-regs)
515(defvar math-prog-last)
516(defvar math-bound-vars)
517(defvar math-conds)
518(defvar math-copy-neg)
519(defvar math-rhs)
520(defvar math-pattern)
521(defvar math-remembering)
522(defvar math-aliased-vars)
523
491(defun math-compile-rewrites (rules &optional name) 524(defun math-compile-rewrites (rules &optional name)
492 (if (eq (car-safe rules) 'var) 525 (if (eq (car-safe rules) 'var)
493 (let ((prop (get (nth 2 rules) 'math-rewrite-cache)) 526 (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
@@ -731,26 +764,34 @@
731 (math-flatten-lands (nth 2 expr))) 764 (math-flatten-lands (nth 2 expr)))
732 (list expr))) 765 (list expr)))
733 766
767;; The variables math-rewrite-heads-heads (i.e.; heads for math-rewrite-heads)
768;; math-rewrite-heads-blanks and math-rewrite-heads-skips are local to
769;; math-rewrite-heads, but used by math-rewrite-heads-rec, which is called by
770;; math-rewrite-heads.
771(defvar math-rewrite-heads-heads)
772(defvar math-rewrite-heads-skips)
773(defvar math-rewrite-heads-blanks)
774
734(defun math-rewrite-heads (expr &optional more all) 775(defun math-rewrite-heads (expr &optional more all)
735 (let ((heads more) 776 (let ((math-rewrite-heads-heads more)
736 (skips (and (not all) 777 (math-rewrite-heads-skips (and (not all)
737 '(calcFunc-apply calcFunc-condition calcFunc-opt 778 '(calcFunc-apply calcFunc-condition calcFunc-opt
738 calcFunc-por calcFunc-pnot))) 779 calcFunc-por calcFunc-pnot)))
739 (blanks (and (not all) 780 (math-rewrite-heads-blanks (and (not all)
740 '(calcFunc-quote calcFunc-plain calcFunc-select 781 '(calcFunc-quote calcFunc-plain calcFunc-select
741 calcFunc-cons calcFunc-rcons 782 calcFunc-cons calcFunc-rcons
742 calcFunc-pand)))) 783 calcFunc-pand))))
743 (or (Math-primp expr) 784 (or (Math-primp expr)
744 (math-rewrite-heads-rec expr)) 785 (math-rewrite-heads-rec expr))
745 heads)) 786 math-rewrite-heads-heads))
746 787
747(defun math-rewrite-heads-rec (expr) 788(defun math-rewrite-heads-rec (expr)
748 (or (memq (car expr) skips) 789 (or (memq (car expr) math-rewrite-heads-skips)
749 (progn 790 (progn
750 (or (memq (car expr) heads) 791 (or (memq (car expr) math-rewrite-heads-heads)
751 (memq (car expr) blanks) 792 (memq (car expr) math-rewrite-heads-blanks)
752 (memq 'algebraic (get (car expr) 'math-rewrite-props)) 793 (memq 'algebraic (get (car expr) 'math-rewrite-props))
753 (setq heads (cons (car expr) heads))) 794 (setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads)))
754 (while (setq expr (cdr expr)) 795 (while (setq expr (cdr expr))
755 (or (Math-primp (car expr)) 796 (or (Math-primp (car expr))
756 (math-rewrite-heads-rec (car expr))))))) 797 (math-rewrite-heads-rec (car expr)))))))
@@ -793,21 +834,31 @@
793 (list 'neg (list 'calcFunc-register (nth 1 entry))) 834 (list 'neg (list 'calcFunc-register (nth 1 entry)))
794 (list 'calcFunc-register (nth 1 entry))))) 835 (list 'calcFunc-register (nth 1 entry)))))
795 836
796(defun math-rwcomp-substitute (expr old new) 837;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new,
797 (if (and (eq (car-safe old) 'var) 838;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func
798 (memq (car-safe new) '(var calcFunc-lambda))) 839;; are local to math-rwcomp-substitute, but are used by
799 (let ((old-func (math-var-to-calcFunc old)) 840;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute.
800 (new-func (math-var-to-calcFunc new))) 841(defvar math-rwcomp-subst-new)
842(defvar math-rwcomp-subst-old)
843(defvar math-rwcomp-subst-new-func)
844(defvar math-rwcomp-subst-old-func)
845
846(defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new)
847 (if (and (eq (car-safe math-rwcomp-subst-old) 'var)
848 (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda)))
849 (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old))
850 (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new)))
801 (math-rwcomp-subst-rec expr)) 851 (math-rwcomp-subst-rec expr))
802 (let ((old-func nil)) 852 (let ((math-rwcomp-subst-old-func nil))
803 (math-rwcomp-subst-rec expr)))) 853 (math-rwcomp-subst-rec expr))))
804 854
805(defun math-rwcomp-subst-rec (expr) 855(defun math-rwcomp-subst-rec (expr)
806 (cond ((equal expr old) new) 856 (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
807 ((Math-primp expr) expr) 857 ((Math-primp expr) expr)
808 (t (if (eq (car expr) old-func) 858 (t (if (eq (car expr) math-rwcomp-subst-old-func)
809 (math-build-call new-func (mapcar 'math-rwcomp-subst-rec 859 (math-build-call math-rwcomp-subst-new-func
810 (cdr expr))) 860 (mapcar 'math-rwcomp-subst-rec
861 (cdr expr)))
811 (cons (car expr) 862 (cons (car expr)
812 (mapcar 'math-rwcomp-subst-rec (cdr expr))))))) 863 (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
813 864
@@ -1268,22 +1319,18 @@
1268(defun math-rwcomp-assoc-args (expr) 1319(defun math-rwcomp-assoc-args (expr)
1269 (if (and (eq (car-safe (nth 1 expr)) (car expr)) 1320 (if (and (eq (car-safe (nth 1 expr)) (car expr))
1270 (= (length (nth 1 expr)) 3)) 1321 (= (length (nth 1 expr)) 3))
1271 (math-rwcomp-assoc-args (nth 1 expr)) 1322 (math-rwcomp-assoc-args (nth 1 expr)))
1272 (setq math-args (cons (nth 1 expr) math-args)))
1273 (if (and (eq (car-safe (nth 2 expr)) (car expr)) 1323 (if (and (eq (car-safe (nth 2 expr)) (car expr))
1274 (= (length (nth 2 expr)) 3)) 1324 (= (length (nth 2 expr)) 3))
1275 (math-rwcomp-assoc-args (nth 2 expr)) 1325 (math-rwcomp-assoc-args (nth 2 expr))))
1276 (setq math-args (cons (nth 2 expr) math-args))))
1277 1326
1278(defun math-rwcomp-addsub-args (expr) 1327(defun math-rwcomp-addsub-args (expr)
1279 (if (memq (car-safe (nth 1 expr)) '(+ -)) 1328 (if (memq (car-safe (nth 1 expr)) '(+ -))
1280 (math-rwcomp-addsub-args (nth 1 expr)) 1329 (math-rwcomp-addsub-args (nth 1 expr)))
1281 (setq math-args (cons (nth 1 expr) math-args)))
1282 (if (eq (car expr) '-) 1330 (if (eq (car expr) '-)
1283 (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args)) 1331 ()
1284 (if (eq (car-safe (nth 2 expr)) '+) 1332 (if (eq (car-safe (nth 2 expr)) '+)
1285 (math-rwcomp-addsub-args (nth 2 expr)) 1333 (math-rwcomp-addsub-args (nth 2 expr)))))
1286 (setq math-args (cons (nth 2 expr) math-args)))))
1287 1334
1288(defun math-rwcomp-order (a b) 1335(defun math-rwcomp-order (a b)
1289 (< (math-rwcomp-priority (car a)) 1336 (< (math-rwcomp-priority (car a))
@@ -1419,14 +1466,23 @@
1419 form 1466 form
1420 '(setcar rules orig)))) 1467 '(setcar rules orig))))
1421 1468
1422(setq math-rewrite-phase 1) 1469(defvar math-rewrite-phase 1)
1470
1471;; The variable math-apply-rw-regs is local to math-apply-rewrites,
1472;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
1473;; which are called by math-apply-rewrites.
1474(defvar math-apply-rw-regs)
1423 1475
1424(defun math-apply-rewrites (expr rules &optional heads ruleset) 1476;; The variable math-apply-rw-ruleset is local to math-apply-rewrites,
1477;; but is used by math-rwapply-remember.
1478(defvar math-apply-rw-ruleset)
1479
1480(defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
1425 (and 1481 (and
1426 (setq rules (cdr (or (assq (car-safe expr) rules) 1482 (setq rules (cdr (or (assq (car-safe expr) rules)
1427 (assq nil rules)))) 1483 (assq nil rules))))
1428 (let ((result nil) 1484 (let ((result nil)
1429 op regs inst part pc mark btrack 1485 op math-apply-rw-regs inst part pc mark btrack
1430 (tracing math-rwcomp-tracing) 1486 (tracing math-rwcomp-tracing)
1431 (phase math-rewrite-phase)) 1487 (phase math-rewrite-phase))
1432 (while rules 1488 (while rules
@@ -1437,35 +1493,37 @@
1437 (and (setq part (nth 3 (car rules))) 1493 (and (setq part (nth 3 (car rules)))
1438 (not (memq phase part))) 1494 (not (memq phase part)))
1439 (progn 1495 (progn
1440 (setq regs (car (car rules)) 1496 (setq math-apply-rw-regs (car (car rules))
1441 pc (nth 1 (car rules)) 1497 pc (nth 1 (car rules))
1442 btrack nil) 1498 btrack nil)
1443 (aset regs 0 expr) 1499 (aset math-apply-rw-regs 0 expr)
1444 (while pc 1500 (while pc
1445 1501
1446 (and tracing 1502 (and tracing
1447 (progn (terpri) (princ (car pc)) 1503 (progn (terpri) (princ (car pc))
1448 (if (and (natnump (nth 1 (car pc))) 1504 (if (and (natnump (nth 1 (car pc)))
1449 (< (nth 1 (car pc)) (length regs))) 1505 (< (nth 1 (car pc)) (length math-apply-rw-regs)))
1450 (princ (format "\n part = %s" 1506 (princ
1451 (aref regs (nth 1 (car pc)))))))) 1507 (format "\n part = %s"
1508 (aref math-apply-rw-regs (nth 1 (car pc))))))))
1452 1509
1453 (cond ((eq (setq op (car (setq inst (car pc)))) 'func) 1510 (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
1454 (if (and (consp (setq part (aref regs (car (cdr inst))))) 1511 (if (and (consp
1512 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1455 (eq (car part) 1513 (eq (car part)
1456 (car (setq inst (cdr (cdr inst))))) 1514 (car (setq inst (cdr (cdr inst)))))
1457 (progn 1515 (progn
1458 (while (and (setq inst (cdr inst) 1516 (while (and (setq inst (cdr inst)
1459 part (cdr part)) 1517 part (cdr part))
1460 inst) 1518 inst)
1461 (aset regs (car inst) (car part))) 1519 (aset math-apply-rw-regs (car inst) (car part)))
1462 (not (or inst part)))) 1520 (not (or inst part))))
1463 (setq pc (cdr pc)) 1521 (setq pc (cdr pc))
1464 (math-rwfail))) 1522 (math-rwfail)))
1465 1523
1466 ((eq op 'same) 1524 ((eq op 'same)
1467 (if (or (equal (setq part (aref regs (nth 1 inst))) 1525 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1468 (setq mark (aref regs (nth 2 inst)))) 1526 (setq mark (aref math-apply-rw-regs (nth 2 inst))))
1469 (Math-equal part mark)) 1527 (Math-equal part mark))
1470 (setq pc (cdr pc)) 1528 (setq pc (cdr pc))
1471 (math-rwfail))) 1529 (math-rwfail)))
@@ -1474,22 +1532,23 @@
1474 calc-matrix-mode 1532 calc-matrix-mode
1475 (not (eq calc-matrix-mode 'scalar)) 1533 (not (eq calc-matrix-mode 'scalar))
1476 (eq (car (nth 2 inst)) '*) 1534 (eq (car (nth 2 inst)) '*)
1477 (consp (setq part (aref regs (car (cdr inst))))) 1535 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1478 (eq (car part) '*) 1536 (eq (car part) '*)
1479 (not (math-known-scalarp part))) 1537 (not (math-known-scalarp part)))
1480 (setq mark (nth 3 inst) 1538 (setq mark (nth 3 inst)
1481 pc (cdr pc)) 1539 pc (cdr pc))
1482 (if (aref mark 4) 1540 (if (aref mark 4)
1483 (progn 1541 (progn
1484 (aset regs (nth 4 inst) (nth 2 part)) 1542 (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
1485 (aset mark 1 (cdr (cdr part)))) 1543 (aset mark 1 (cdr (cdr part))))
1486 (aset regs (nth 4 inst) (nth 1 part)) 1544 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1487 (aset mark 1 (cdr part))) 1545 (aset mark 1 (cdr part)))
1488 (aset mark 0 (cdr part)) 1546 (aset mark 0 (cdr part))
1489 (aset mark 2 0)) 1547 (aset mark 2 0))
1490 1548
1491 ((eq op 'try) 1549 ((eq op 'try)
1492 (if (and (consp (setq part (aref regs (car (cdr inst))))) 1550 (if (and (consp (setq part
1551 (aref math-apply-rw-regs (car (cdr inst)))))
1493 (memq (car part) (nth 2 inst)) 1552 (memq (car part) (nth 2 inst))
1494 (= (length part) 3) 1553 (= (length part) 3)
1495 (or (not (eq (car part) '/)) 1554 (or (not (eq (car part) '/))
@@ -1525,7 +1584,7 @@
1525 op)) 1584 op))
1526 btrack (cons pc btrack) 1585 btrack (cons pc btrack)
1527 pc (cdr pc)) 1586 pc (cdr pc))
1528 (aset regs (nth 2 inst) (car op)) 1587 (aset math-apply-rw-regs (nth 2 inst) (car op))
1529 (aset mark 0 op) 1588 (aset mark 0 op)
1530 (aset mark 1 op) 1589 (aset mark 1 op)
1531 (aset mark 2 (if (cdr (cdr op)) 1 0))) 1590 (aset mark 2 (if (cdr (cdr op)) 1 0)))
@@ -1537,12 +1596,12 @@
1537 (progn 1596 (progn
1538 (setq mark (nth 3 inst) 1597 (setq mark (nth 3 inst)
1539 pc (cdr pc)) 1598 pc (cdr pc))
1540 (aset regs (nth 4 inst) (nth 1 part)) 1599 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1541 (aset mark 1 -1) 1600 (aset mark 1 -1)
1542 (aset mark 2 4)) 1601 (aset mark 2 4))
1543 (setq mark (nth 3 inst) 1602 (setq mark (nth 3 inst)
1544 pc (cdr pc)) 1603 pc (cdr pc))
1545 (aset regs (nth 4 inst) part) 1604 (aset math-apply-rw-regs (nth 4 inst) part)
1546 (aset mark 2 3)) 1605 (aset mark 2 3))
1547 (math-rwfail)))) 1606 (math-rwfail))))
1548 1607
@@ -1551,7 +1610,7 @@
1551 mark (nth 3 part) 1610 mark (nth 3 part)
1552 op (aref mark 2) 1611 op (aref mark 2)
1553 pc (cdr pc)) 1612 pc (cdr pc))
1554 (aset regs (nth 2 inst) 1613 (aset math-apply-rw-regs (nth 2 inst)
1555 (cond 1614 (cond
1556 ((eq op 0) 1615 ((eq op 0)
1557 (if (eq (aref mark 0) (aref mark 1)) 1616 (if (eq (aref mark 0) (aref mark 1))
@@ -1591,17 +1650,17 @@
1591 1650
1592 ((eq op 'select) 1651 ((eq op 'select)
1593 (setq pc (cdr pc)) 1652 (setq pc (cdr pc))
1594 (if (and (consp (setq part (aref regs (nth 1 inst)))) 1653 (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1595 (eq (car part) 'calcFunc-select)) 1654 (eq (car part) 'calcFunc-select))
1596 (aset regs (nth 2 inst) (nth 1 part)) 1655 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1597 (if math-rewrite-selections 1656 (if math-rewrite-selections
1598 (math-rwfail) 1657 (math-rwfail)
1599 (aset regs (nth 2 inst) part)))) 1658 (aset math-apply-rw-regs (nth 2 inst) part))))
1600 1659
1601 ((eq op 'same-neg) 1660 ((eq op 'same-neg)
1602 (if (or (equal (setq part (aref regs (nth 1 inst))) 1661 (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1603 (setq mark (math-neg 1662 (setq mark (math-neg
1604 (aref regs (nth 2 inst))))) 1663 (aref math-apply-rw-regs (nth 2 inst)))))
1605 (Math-equal part mark)) 1664 (Math-equal part mark))
1606 (setq pc (cdr pc)) 1665 (setq pc (cdr pc))
1607 (math-rwfail))) 1666 (math-rwfail)))
@@ -1613,22 +1672,24 @@
1613 op (aref mark 2)) 1672 op (aref mark 2))
1614 (cond ((eq op 0) 1673 (cond ((eq op 0)
1615 (if (setq op (cdr (aref mark 1))) 1674 (if (setq op (cdr (aref mark 1)))
1616 (aset regs (nth 4 inst) (car (aset mark 1 op))) 1675 (aset math-apply-rw-regs (nth 4 inst)
1676 (car (aset mark 1 op)))
1617 (if (nth 5 inst) 1677 (if (nth 5 inst)
1618 (progn 1678 (progn
1619 (aset mark 2 3) 1679 (aset mark 2 3)
1620 (aset regs (nth 4 inst) 1680 (aset math-apply-rw-regs (nth 4 inst)
1621 (aref regs (nth 1 inst)))) 1681 (aref math-apply-rw-regs (nth 1 inst))))
1622 (math-rwfail t)))) 1682 (math-rwfail t))))
1623 ((eq op 1) 1683 ((eq op 1)
1624 (if (setq op (cdr (aref mark 1))) 1684 (if (setq op (cdr (aref mark 1)))
1625 (aset regs (nth 4 inst) (car (aset mark 1 op))) 1685 (aset math-apply-rw-regs (nth 4 inst)
1686 (car (aset mark 1 op)))
1626 (if (= (aref mark 3) 1) 1687 (if (= (aref mark 3) 1)
1627 (if (nth 5 inst) 1688 (if (nth 5 inst)
1628 (progn 1689 (progn
1629 (aset mark 2 3) 1690 (aset mark 2 3)
1630 (aset regs (nth 4 inst) 1691 (aset math-apply-rw-regs (nth 4 inst)
1631 (aref regs (nth 1 inst)))) 1692 (aref math-apply-rw-regs (nth 1 inst))))
1632 (math-rwfail t)) 1693 (math-rwfail t))
1633 (aset mark 2 2) 1694 (aset mark 2 2)
1634 (aset mark 1 (cons nil (aref mark 0))) 1695 (aset mark 1 (cons nil (aref mark 0)))
@@ -1666,19 +1727,20 @@
1666 (list '- part 1727 (list '- part
1667 (nth 1 (car mark))) 1728 (nth 1 (car mark)))
1668 (list op part (car mark)))))) 1729 (list op part (car mark))))))
1669 (aset regs (nth 4 inst) part)) 1730 (aset math-apply-rw-regs (nth 4 inst) part))
1670 (if (nth 5 inst) 1731 (if (nth 5 inst)
1671 (progn 1732 (progn
1672 (aset mark 2 3) 1733 (aset mark 2 3)
1673 (aset regs (nth 4 inst) 1734 (aset math-apply-rw-regs (nth 4 inst)
1674 (aref regs (nth 1 inst)))) 1735 (aref math-apply-rw-regs (nth 1 inst))))
1675 (math-rwfail t)))) 1736 (math-rwfail t))))
1676 ((eq op 4) 1737 ((eq op 4)
1677 (setq btrack (cdr btrack))) 1738 (setq btrack (cdr btrack)))
1678 (t (math-rwfail t)))) 1739 (t (math-rwfail t))))
1679 1740
1680 ((eq op 'integer) 1741 ((eq op 'integer)
1681 (if (Math-integerp (setq part (aref regs (nth 1 inst)))) 1742 (if (Math-integerp (setq part
1743 (aref math-apply-rw-regs (nth 1 inst))))
1682 (setq pc (cdr pc)) 1744 (setq pc (cdr pc))
1683 (if (Math-primp part) 1745 (if (Math-primp part)
1684 (math-rwfail) 1746 (math-rwfail)
@@ -1688,7 +1750,7 @@
1688 (math-rwfail))))) 1750 (math-rwfail)))))
1689 1751
1690 ((eq op 'real) 1752 ((eq op 'real)
1691 (if (Math-realp (setq part (aref regs (nth 1 inst)))) 1753 (if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1692 (setq pc (cdr pc)) 1754 (setq pc (cdr pc))
1693 (if (Math-primp part) 1755 (if (Math-primp part)
1694 (math-rwfail) 1756 (math-rwfail)
@@ -1698,7 +1760,7 @@
1698 (math-rwfail))))) 1760 (math-rwfail)))))
1699 1761
1700 ((eq op 'constant) 1762 ((eq op 'constant)
1701 (if (math-constp (setq part (aref regs (nth 1 inst)))) 1763 (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1702 (setq pc (cdr pc)) 1764 (setq pc (cdr pc))
1703 (if (Math-primp part) 1765 (if (Math-primp part)
1704 (math-rwfail) 1766 (math-rwfail)
@@ -1708,7 +1770,8 @@
1708 (math-rwfail))))) 1770 (math-rwfail)))))
1709 1771
1710 ((eq op 'negative) 1772 ((eq op 'negative)
1711 (if (math-looks-negp (setq part (aref regs (nth 1 inst)))) 1773 (if (math-looks-negp (setq part
1774 (aref math-apply-rw-regs (nth 1 inst))))
1712 (setq pc (cdr pc)) 1775 (setq pc (cdr pc))
1713 (if (Math-primp part) 1776 (if (Math-primp part)
1714 (math-rwfail) 1777 (math-rwfail)
@@ -1718,15 +1781,16 @@
1718 (math-rwfail))))) 1781 (math-rwfail)))))
1719 1782
1720 ((eq op 'rel) 1783 ((eq op 'rel)
1721 (setq part (math-compare (aref regs (nth 1 inst)) 1784 (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
1722 (aref regs (nth 3 inst))) 1785 (aref math-apply-rw-regs (nth 3 inst)))
1723 op (nth 2 inst)) 1786 op (nth 2 inst))
1724 (if (= part 2) 1787 (if (= part 2)
1725 (setq part (math-rweval 1788 (setq part (math-rweval
1726 (math-simplify 1789 (math-simplify
1727 (calcFunc-sign 1790 (calcFunc-sign
1728 (math-sub (aref regs (nth 1 inst)) 1791 (math-sub
1729 (aref regs (nth 3 inst)))))))) 1792 (aref math-apply-rw-regs (nth 1 inst))
1793 (aref math-apply-rw-regs (nth 3 inst))))))))
1730 (if (cond ((eq op 'calcFunc-eq) 1794 (if (cond ((eq op 'calcFunc-eq)
1731 (eq part 0)) 1795 (eq part 0))
1732 ((eq op 'calcFunc-neq) 1796 ((eq op 'calcFunc-neq)
@@ -1743,44 +1807,48 @@
1743 (math-rwfail))) 1807 (math-rwfail)))
1744 1808
1745 ((eq op 'func-def) 1809 ((eq op 'func-def)
1746 (if (and (consp (setq part (aref regs (car (cdr inst))))) 1810 (if (and
1747 (eq (car part) 1811 (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1748 (car (setq inst (cdr (cdr inst)))))) 1812 (eq (car part)
1813 (car (setq inst (cdr (cdr inst))))))
1749 (progn 1814 (progn
1750 (setq inst (cdr inst) 1815 (setq inst (cdr inst)
1751 mark (car inst)) 1816 mark (car inst))
1752 (while (and (setq inst (cdr inst) 1817 (while (and (setq inst (cdr inst)
1753 part (cdr part)) 1818 part (cdr part))
1754 inst) 1819 inst)
1755 (aset regs (car inst) (car part))) 1820 (aset math-apply-rw-regs (car inst) (car part)))
1756 (if (or inst part) 1821 (if (or inst part)
1757 (setq pc (cdr pc)) 1822 (setq pc (cdr pc))
1758 (while (eq (car (car (setq pc (cdr pc)))) 1823 (while (eq (car (car (setq pc (cdr pc))))
1759 'func-def)) 1824 'func-def))
1760 (setq pc (cdr pc)) ; skip over "func" 1825 (setq pc (cdr pc)) ; skip over "func"
1761 (while mark 1826 (while mark
1762 (aset regs (cdr (car mark)) (car (car mark))) 1827 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1763 (setq mark (cdr mark))))) 1828 (setq mark (cdr mark)))))
1764 (math-rwfail))) 1829 (math-rwfail)))
1765 1830
1766 ((eq op 'func-opt) 1831 ((eq op 'func-opt)
1767 (if (or (not (and (consp 1832 (if (or (not
1768 (setq part (aref regs (car (cdr inst))))) 1833 (and
1769 (eq (car part) (nth 2 inst)))) 1834 (consp
1835 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1836 (eq (car part) (nth 2 inst))))
1770 (and (= (length part) 2) 1837 (and (= (length part) 2)
1771 (setq part (nth 1 part)))) 1838 (setq part (nth 1 part))))
1772 (progn 1839 (progn
1773 (setq mark (nth 3 inst)) 1840 (setq mark (nth 3 inst))
1774 (aset regs (nth 4 inst) part) 1841 (aset math-apply-rw-regs (nth 4 inst) part)
1775 (while (eq (car (car (setq pc (cdr pc)))) 'func-def)) 1842 (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
1776 (setq pc (cdr pc)) ; skip over "func" 1843 (setq pc (cdr pc)) ; skip over "func"
1777 (while mark 1844 (while mark
1778 (aset regs (cdr (car mark)) (car (car mark))) 1845 (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1779 (setq mark (cdr mark)))) 1846 (setq mark (cdr mark))))
1780 (setq pc (cdr pc)))) 1847 (setq pc (cdr pc))))
1781 1848
1782 ((eq op 'mod) 1849 ((eq op 'mod)
1783 (if (if (Math-zerop (setq part (aref regs (nth 1 inst)))) 1850 (if (if (Math-zerop
1851 (setq part (aref math-apply-rw-regs (nth 1 inst))))
1784 (Math-zerop (nth 3 inst)) 1852 (Math-zerop (nth 3 inst))
1785 (and (not (Math-zerop (nth 2 inst))) 1853 (and (not (Math-zerop (nth 2 inst)))
1786 (progn 1854 (progn
@@ -1793,34 +1861,38 @@
1793 (math-rwfail))) 1861 (math-rwfail)))
1794 1862
1795 ((eq op 'apply) 1863 ((eq op 'apply)
1796 (if (and (consp (setq part (aref regs (car (cdr inst))))) 1864 (if (and (consp
1865 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1797 (not (Math-objvecp part)) 1866 (not (Math-objvecp part))
1798 (not (eq (car part) 'var))) 1867 (not (eq (car part) 'var)))
1799 (progn 1868 (progn
1800 (aset regs (nth 2 inst) 1869 (aset math-apply-rw-regs (nth 2 inst)
1801 (math-calcFunc-to-var (car part))) 1870 (math-calcFunc-to-var (car part)))
1802 (aset regs (nth 3 inst) 1871 (aset math-apply-rw-regs (nth 3 inst)
1803 (cons 'vec (cdr part))) 1872 (cons 'vec (cdr part)))
1804 (setq pc (cdr pc))) 1873 (setq pc (cdr pc)))
1805 (math-rwfail))) 1874 (math-rwfail)))
1806 1875
1807 ((eq op 'cons) 1876 ((eq op 'cons)
1808 (if (and (consp (setq part (aref regs (car (cdr inst))))) 1877 (if (and (consp
1878 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1809 (eq (car part) 'vec) 1879 (eq (car part) 'vec)
1810 (cdr part)) 1880 (cdr part))
1811 (progn 1881 (progn
1812 (aset regs (nth 2 inst) (nth 1 part)) 1882 (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1813 (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part)))) 1883 (aset math-apply-rw-regs (nth 3 inst)
1884 (cons 'vec (cdr (cdr part))))
1814 (setq pc (cdr pc))) 1885 (setq pc (cdr pc)))
1815 (math-rwfail))) 1886 (math-rwfail)))
1816 1887
1817 ((eq op 'rcons) 1888 ((eq op 'rcons)
1818 (if (and (consp (setq part (aref regs (car (cdr inst))))) 1889 (if (and (consp
1890 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1819 (eq (car part) 'vec) 1891 (eq (car part) 'vec)
1820 (cdr part)) 1892 (cdr part))
1821 (progn 1893 (progn
1822 (aset regs (nth 2 inst) (calcFunc-rhead part)) 1894 (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
1823 (aset regs (nth 3 inst) (calcFunc-rtail part)) 1895 (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
1824 (setq pc (cdr pc))) 1896 (setq pc (cdr pc)))
1825 (math-rwfail))) 1897 (math-rwfail)))
1826 1898
@@ -1833,19 +1905,20 @@
1833 (math-rwfail))) 1905 (math-rwfail)))
1834 1906
1835 ((eq op 'let) 1907 ((eq op 'let)
1836 (aset regs (nth 1 inst) 1908 (aset math-apply-rw-regs (nth 1 inst)
1837 (math-rweval 1909 (math-rweval
1838 (math-normalize 1910 (math-normalize
1839 (math-rwapply-replace-regs (nth 2 inst))))) 1911 (math-rwapply-replace-regs (nth 2 inst)))))
1840 (setq pc (cdr pc))) 1912 (setq pc (cdr pc)))
1841 1913
1842 ((eq op 'copy) 1914 ((eq op 'copy)
1843 (aset regs (nth 2 inst) (aref regs (nth 1 inst))) 1915 (aset math-apply-rw-regs (nth 2 inst)
1916 (aref math-apply-rw-regs (nth 1 inst)))
1844 (setq pc (cdr pc))) 1917 (setq pc (cdr pc)))
1845 1918
1846 ((eq op 'copy-neg) 1919 ((eq op 'copy-neg)
1847 (aset regs (nth 2 inst) 1920 (aset math-apply-rw-regs (nth 2 inst)
1848 (math-rwapply-neg (aref regs (nth 1 inst)))) 1921 (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
1849 (setq pc (cdr pc))) 1922 (setq pc (cdr pc)))
1850 1923
1851 ((eq op 'alt) 1924 ((eq op 'alt)
@@ -1904,7 +1977,7 @@
1904 (cond ((Math-primp expr) 1977 (cond ((Math-primp expr)
1905 expr) 1978 expr)
1906 ((eq (car expr) 'calcFunc-register) 1979 ((eq (car expr) 'calcFunc-register)
1907 (setq expr (aref regs (nth 1 expr))) 1980 (setq expr (aref math-apply-rw-regs (nth 1 expr)))
1908 (if (eq (car-safe expr) '*) 1981 (if (eq (car-safe expr) '*)
1909 (if (eq (nth 1 expr) -1) 1982 (if (eq (nth 1 expr) -1)
1910 (math-neg (nth 2 expr)) 1983 (math-neg (nth 2 expr))
@@ -1953,7 +2026,7 @@
1953 (math-rwapply-reg-neg (nth 1 expr))) 2026 (math-rwapply-reg-neg (nth 1 expr)))
1954 ((and (eq (car expr) 'neg) 2027 ((and (eq (car expr) 'neg)
1955 (eq (car-safe (nth 1 expr)) 'calcFunc-register) 2028 (eq (car-safe (nth 1 expr)) 'calcFunc-register)
1956 (math-scalarp (aref regs (nth 1 (nth 1 expr))))) 2029 (math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr)))))
1957 (math-neg (math-rwapply-replace-regs (nth 1 expr)))) 2030 (math-neg (math-rwapply-replace-regs (nth 1 expr))))
1958 ((and (eq (car expr) '+) 2031 ((and (eq (car expr) '+)
1959 (math-rwapply-reg-looks-negp (nth 1 expr))) 2032 (math-rwapply-reg-looks-negp (nth 1 expr)))
@@ -2001,14 +2074,14 @@
2001 (if (Math-primp (nth 1 expr)) 2074 (if (Math-primp (nth 1 expr))
2002 (nth 1 expr) 2075 (nth 1 expr)
2003 (if (eq (car (nth 1 expr)) 'calcFunc-register) 2076 (if (eq (car (nth 1 expr)) 'calcFunc-register)
2004 (aref regs (nth 1 (nth 1 expr))) 2077 (aref math-apply-rw-regs (nth 1 (nth 1 expr)))
2005 (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs 2078 (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
2006 (cdr (nth 1 expr))))))) 2079 (cdr (nth 1 expr)))))))
2007 (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))) 2080 (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
2008 2081
2009(defun math-rwapply-reg-looks-negp (expr) 2082(defun math-rwapply-reg-looks-negp (expr)
2010 (if (eq (car-safe expr) 'calcFunc-register) 2083 (if (eq (car-safe expr) 'calcFunc-register)
2011 (math-looks-negp (aref regs (nth 1 expr))) 2084 (math-looks-negp (aref math-apply-rw-regs (nth 1 expr)))
2012 (if (memq (car-safe expr) '(* /)) 2085 (if (memq (car-safe expr) '(* /))
2013 (or (math-rwapply-reg-looks-negp (nth 1 expr)) 2086 (or (math-rwapply-reg-looks-negp (nth 1 expr))
2014 (math-rwapply-reg-looks-negp (nth 2 expr)))))) 2087 (math-rwapply-reg-looks-negp (nth 2 expr))))))
@@ -2025,8 +2098,8 @@
2025 (math-rwapply-reg-neg (nth 2 expr))))))) 2098 (math-rwapply-reg-neg (nth 2 expr)))))))
2026 2099
2027(defun math-rwapply-remember (old new) 2100(defun math-rwapply-remember (old new)
2028 (let ((varval (symbol-value (nth 2 (car ruleset)))) 2101 (let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset))))
2029 (rules (assq (car-safe old) ruleset))) 2102 (rules (assq (car-safe old) math-apply-rw-ruleset)))
2030 (if (and (eq (car-safe varval) 'vec) 2103 (if (and (eq (car-safe varval) 'vec)
2031 (not (memq (car-safe old) '(nil schedule + -))) 2104 (not (memq (car-safe old) '(nil schedule + -)))
2032 rules) 2105 rules)