3 |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: David Gillespie <daveg@synaptics.com> |
;; Author: David Gillespie <daveg@synaptics.com> |
6 |
;; Maintainers: D. Goel <deego@gnufans.org> |
;; Maintainer: Jay Belanger <belanger@truman.edu> |
|
;; Colin Walters <walters@debian.org> |
|
7 |
|
|
8 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
9 |
|
|
35 |
|
|
36 |
|
|
37 |
(defvar math-rewrite-default-iters 100) |
(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 |
|
|
43 |
(defun calc-rewrite-selection (rules-str &optional many prefix) |
(defun calc-rewrite-selection (rules-str &optional many prefix) |
44 |
(interactive "sRewrite rule(s): \np") |
(interactive "sRewrite rule(s): \np") |
45 |
(calc-slow-wrapper |
(calc-slow-wrapper |
47 |
(let* ((num (max 1 (calc-locate-cursor-element (point)))) |
(let* ((num (max 1 (calc-locate-cursor-element (point)))) |
48 |
(reselect t) |
(reselect t) |
49 |
(pop-rules nil) |
(pop-rules nil) |
50 |
|
rules |
51 |
(entry (calc-top num 'entry)) |
(entry (calc-top num 'entry)) |
52 |
(expr (car entry)) |
(expr (car entry)) |
53 |
(sel (calc-auto-selection entry)) |
(calc-rewr-sel (calc-auto-selection entry)) |
54 |
(math-rewrite-selections t) |
(math-rewrite-selections t) |
55 |
(math-rewrite-default-iters 1)) |
(math-rewrite-default-iters 1)) |
56 |
(if (or (null rules-str) (equal rules-str "") (equal rules-str "$")) |
(if (or (null rules-str) (equal rules-str "") (equal rules-str "$")) |
78 |
(if (eq many 0) |
(if (eq many 0) |
79 |
(setq many '(var inf var-inf)) |
(setq many '(var inf var-inf)) |
80 |
(if many (setq many (prefix-numeric-value many)))) |
(if many (setq many (prefix-numeric-value many)))) |
81 |
(if sel |
(if calc-rewr-sel |
82 |
(setq expr (calc-replace-sub-formula (car entry) |
(setq expr (calc-replace-sub-formula (car entry) |
83 |
sel |
calc-rewr-sel |
84 |
(list 'calcFunc-select sel))) |
(list 'calcFunc-select calc-rewr-sel))) |
85 |
(setq expr (car entry) |
(setq expr (car entry) |
86 |
reselect nil |
reselect nil |
87 |
math-rewrite-selections nil)) |
math-rewrite-selections nil)) |
90 |
(math-rewrite |
(math-rewrite |
91 |
(calc-normalize expr) |
(calc-normalize expr) |
92 |
rules many))) |
rules many))) |
93 |
sel nil |
calc-rewr-sel nil |
94 |
expr (calc-locate-select-marker expr)) |
expr (calc-locate-select-marker expr)) |
95 |
(or (consp sel) (setq sel nil)) |
(or (consp calc-rewr-sel) (setq calc-rewr-sel nil)) |
96 |
(if pop-rules (calc-pop-stack 1)) |
(if pop-rules (calc-pop-stack 1)) |
97 |
(calc-pop-push-record-list 1 (or prefix "rwrt") (list expr) |
(calc-pop-push-record-list 1 (or prefix "rwrt") (list expr) |
98 |
(- num (if pop-rules 1 0)) |
(- num (if pop-rules 1 0)) |
99 |
(list (and reselect sel)))) |
(list (and reselect calc-rewr-sel)))) |
100 |
(calc-handle-whys))) |
(calc-handle-whys))) |
101 |
|
|
102 |
(defun calc-locate-select-marker (expr) ; changes "sel" |
(defun calc-locate-select-marker (expr) |
103 |
(if (Math-primp expr) |
(if (Math-primp expr) |
104 |
expr |
expr |
105 |
(if (and (eq (car expr) 'calcFunc-select) |
(if (and (eq (car expr) 'calcFunc-select) |
106 |
(= (length expr) 2)) |
(= (length expr) 2)) |
107 |
(progn |
(progn |
108 |
(setq sel (if sel t (nth 1 expr))) |
(setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr))) |
109 |
(nth 1 expr)) |
(nth 1 expr)) |
110 |
(cons (car expr) |
(cons (car expr) |
111 |
(mapcar 'calc-locate-select-marker (cdr expr)))))) |
(mapcar 'calc-locate-select-marker (cdr expr)))))) |
143 |
(setq many '(var inf var-inf)) |
(setq many '(var inf var-inf)) |
144 |
(if many (setq many (prefix-numeric-value many)))) |
(if many (setq many (prefix-numeric-value many)))) |
145 |
(setq expr (calc-normalize (math-rewrite expr rules many))) |
(setq expr (calc-normalize (math-rewrite expr rules many))) |
146 |
(let (sel) |
(let (calc-rewr-sel) |
147 |
(setq expr (calc-locate-select-marker expr))) |
(setq expr (calc-locate-select-marker expr))) |
148 |
(calc-pop-push-record-list n "rwrt" (list expr))) |
(calc-pop-push-record-list n "rwrt" (list expr))) |
149 |
(calc-handle-whys))) |
(calc-handle-whys))) |
170 |
(calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))) |
(calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))) |
171 |
|
|
172 |
|
|
173 |
|
(defvar math-mt-many) |
174 |
|
|
175 |
(defun math-rewrite (whole-expr rules &optional math-mt-many) |
;; The variable math-rewrite-whole-expr is local to math-rewrite, |
176 |
(let ((crules (math-compile-rewrites rules)) |
;; but is used by math-rewrite-phase |
177 |
(heads (math-rewrite-heads whole-expr)) |
(defvar math-rewrite-whole-expr) |
178 |
(trace-buffer (get-buffer "*Trace*")) |
|
179 |
(calc-display-just 'center) |
(defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many) |
180 |
(calc-display-origin 39) |
(let* ((crules (math-compile-rewrites rules)) |
181 |
(calc-line-breaking 78) |
(heads (math-rewrite-heads math-rewrite-whole-expr)) |
182 |
(calc-line-numbering nil) |
(trace-buffer (get-buffer "*Trace*")) |
183 |
(calc-show-selections t) |
(calc-display-just 'center) |
184 |
(calc-why nil) |
(calc-display-origin 39) |
185 |
(math-mt-func (function |
(calc-line-breaking 78) |
186 |
(lambda (x) |
(calc-line-numbering nil) |
187 |
(let ((result (math-apply-rewrites x (cdr crules) |
(calc-show-selections t) |
188 |
heads crules))) |
(calc-why nil) |
189 |
(if result |
(math-mt-func (function |
190 |
(progn |
(lambda (x) |
191 |
(if trace-buffer |
(let ((result (math-apply-rewrites x (cdr crules) |
192 |
(let ((fmt (math-format-stack-value |
heads crules))) |
193 |
(list result nil nil)))) |
(if result |
194 |
(save-excursion |
(progn |
195 |
(set-buffer trace-buffer) |
(if trace-buffer |
196 |
(insert "\nrewrite to\n" fmt "\n")))) |
(let ((fmt (math-format-stack-value |
197 |
(setq heads (math-rewrite-heads result heads t)))) |
(list result nil nil)))) |
198 |
result))))) |
(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))))) |
203 |
(if trace-buffer |
(if trace-buffer |
204 |
(let ((fmt (math-format-stack-value (list whole-expr nil nil)))) |
(let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil)))) |
205 |
(save-excursion |
(save-excursion |
206 |
(set-buffer trace-buffer) |
(set-buffer trace-buffer) |
207 |
(setq truncate-lines t) |
(setq truncate-lines t) |
213 |
(if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000)) |
(if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000)) |
214 |
(math-rewrite-phase (nth 3 (car crules))) |
(math-rewrite-phase (nth 3 (car crules))) |
215 |
(if trace-buffer |
(if trace-buffer |
216 |
(let ((fmt (math-format-stack-value (list whole-expr nil nil)))) |
(let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil)))) |
217 |
(save-excursion |
(save-excursion |
218 |
(set-buffer trace-buffer) |
(set-buffer trace-buffer) |
219 |
(insert "\nDone rewriting" |
(insert "\nDone rewriting" |
220 |
(if (= math-mt-many 0) " (reached iteration limit)" "") |
(if (= math-mt-many 0) " (reached iteration limit)" "") |
221 |
":\n" fmt "\n")))) |
":\n" fmt "\n")))) |
222 |
whole-expr)) |
math-rewrite-whole-expr)) |
223 |
|
|
224 |
(defun math-rewrite-phase (sched) |
(defun math-rewrite-phase (sched) |
225 |
(while (and sched (/= math-mt-many 0)) |
(while (and sched (/= math-mt-many 0)) |
226 |
(if (listp (car sched)) |
(if (listp (car sched)) |
227 |
(while (let ((save-expr whole-expr)) |
(while (let ((save-expr math-rewrite-whole-expr)) |
228 |
(math-rewrite-phase (car sched)) |
(math-rewrite-phase (car sched)) |
229 |
(not (equal whole-expr save-expr)))) |
(not (equal math-rewrite-whole-expr save-expr)))) |
230 |
(if (symbolp (car sched)) |
(if (symbolp (car sched)) |
231 |
(progn |
(progn |
232 |
(setq whole-expr (math-normalize (list (car sched) whole-expr))) |
(setq math-rewrite-whole-expr |
233 |
|
(math-normalize (list (car sched) math-rewrite-whole-expr))) |
234 |
(if trace-buffer |
(if trace-buffer |
235 |
(let ((fmt (math-format-stack-value |
(let ((fmt (math-format-stack-value |
236 |
(list whole-expr nil nil)))) |
(list math-rewrite-whole-expr nil nil)))) |
237 |
(save-excursion |
(save-excursion |
238 |
(set-buffer trace-buffer) |
(set-buffer trace-buffer) |
239 |
(insert "\ncall " |
(insert "\ncall " |
244 |
(save-excursion |
(save-excursion |
245 |
(set-buffer trace-buffer) |
(set-buffer trace-buffer) |
246 |
(insert (format "\n(Phase %d)\n" math-rewrite-phase)))) |
(insert (format "\n(Phase %d)\n" math-rewrite-phase)))) |
247 |
(while (let ((save-expr whole-expr)) |
(while (let ((save-expr math-rewrite-whole-expr)) |
248 |
(setq whole-expr (math-normalize |
(setq math-rewrite-whole-expr (math-normalize |
249 |
(math-map-tree-rec whole-expr))) |
(math-map-tree-rec math-rewrite-whole-expr))) |
250 |
(not (equal whole-expr save-expr))))))) |
(not (equal math-rewrite-whole-expr save-expr))))))) |
251 |
(setq sched (cdr sched)))) |
(setq sched (cdr sched)))) |
252 |
|
|
253 |
(defun calcFunc-rewrite (expr rules &optional many) |
(defun calcFunc-rewrite (expr rules &optional many) |
499 |
|
|
500 |
(defvar math-rewrite-whole nil) |
(defvar math-rewrite-whole nil) |
501 |
(defvar math-make-import-list nil) |
(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 |
|
|
524 |
(defun math-compile-rewrites (rules &optional name) |
(defun math-compile-rewrites (rules &optional name) |
525 |
(if (eq (car-safe rules) 'var) |
(if (eq (car-safe rules) 'var) |
526 |
(let ((prop (get (nth 2 rules) 'math-rewrite-cache)) |
(let ((prop (get (nth 2 rules) 'math-rewrite-cache)) |
764 |
(math-flatten-lands (nth 2 expr))) |
(math-flatten-lands (nth 2 expr))) |
765 |
(list expr))) |
(list expr))) |
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 |
|
|
775 |
(defun math-rewrite-heads (expr &optional more all) |
(defun math-rewrite-heads (expr &optional more all) |
776 |
(let ((heads more) |
(let ((math-rewrite-heads-heads more) |
777 |
(skips (and (not all) |
(math-rewrite-heads-skips (and (not all) |
778 |
'(calcFunc-apply calcFunc-condition calcFunc-opt |
'(calcFunc-apply calcFunc-condition calcFunc-opt |
779 |
calcFunc-por calcFunc-pnot))) |
calcFunc-por calcFunc-pnot))) |
780 |
(blanks (and (not all) |
(math-rewrite-heads-blanks (and (not all) |
781 |
'(calcFunc-quote calcFunc-plain calcFunc-select |
'(calcFunc-quote calcFunc-plain calcFunc-select |
782 |
calcFunc-cons calcFunc-rcons |
calcFunc-cons calcFunc-rcons |
783 |
calcFunc-pand)))) |
calcFunc-pand)))) |
784 |
(or (Math-primp expr) |
(or (Math-primp expr) |
785 |
(math-rewrite-heads-rec expr)) |
(math-rewrite-heads-rec expr)) |
786 |
heads)) |
math-rewrite-heads-heads)) |
787 |
|
|
788 |
(defun math-rewrite-heads-rec (expr) |
(defun math-rewrite-heads-rec (expr) |
789 |
(or (memq (car expr) skips) |
(or (memq (car expr) math-rewrite-heads-skips) |
790 |
(progn |
(progn |
791 |
(or (memq (car expr) heads) |
(or (memq (car expr) math-rewrite-heads-heads) |
792 |
(memq (car expr) blanks) |
(memq (car expr) math-rewrite-heads-blanks) |
793 |
(memq 'algebraic (get (car expr) 'math-rewrite-props)) |
(memq 'algebraic (get (car expr) 'math-rewrite-props)) |
794 |
(setq heads (cons (car expr) heads))) |
(setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads))) |
795 |
(while (setq expr (cdr expr)) |
(while (setq expr (cdr expr)) |
796 |
(or (Math-primp (car expr)) |
(or (Math-primp (car expr)) |
797 |
(math-rewrite-heads-rec (car expr))))))) |
(math-rewrite-heads-rec (car expr))))))) |
834 |
(list 'neg (list 'calcFunc-register (nth 1 entry))) |
(list 'neg (list 'calcFunc-register (nth 1 entry))) |
835 |
(list 'calcFunc-register (nth 1 entry))))) |
(list 'calcFunc-register (nth 1 entry))))) |
836 |
|
|
837 |
(defun math-rwcomp-substitute (expr old new) |
;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new, |
838 |
(if (and (eq (car-safe old) 'var) |
;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func |
839 |
(memq (car-safe new) '(var calcFunc-lambda))) |
;; are local to math-rwcomp-substitute, but are used by |
840 |
(let ((old-func (math-var-to-calcFunc old)) |
;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute. |
841 |
(new-func (math-var-to-calcFunc new))) |
(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))) |
851 |
(math-rwcomp-subst-rec expr)) |
(math-rwcomp-subst-rec expr)) |
852 |
(let ((old-func nil)) |
(let ((math-rwcomp-subst-old-func nil)) |
853 |
(math-rwcomp-subst-rec expr)))) |
(math-rwcomp-subst-rec expr)))) |
854 |
|
|
855 |
(defun math-rwcomp-subst-rec (expr) |
(defun math-rwcomp-subst-rec (expr) |
856 |
(cond ((equal expr old) new) |
(cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new) |
857 |
((Math-primp expr) expr) |
((Math-primp expr) expr) |
858 |
(t (if (eq (car expr) old-func) |
(t (if (eq (car expr) math-rwcomp-subst-old-func) |
859 |
(math-build-call new-func (mapcar 'math-rwcomp-subst-rec |
(math-build-call math-rwcomp-subst-new-func |
860 |
(cdr expr))) |
(mapcar 'math-rwcomp-subst-rec |
861 |
|
(cdr expr))) |
862 |
(cons (car expr) |
(cons (car expr) |
863 |
(mapcar 'math-rwcomp-subst-rec (cdr expr))))))) |
(mapcar 'math-rwcomp-subst-rec (cdr expr))))))) |
864 |
|
|
1319 |
(defun math-rwcomp-assoc-args (expr) |
(defun math-rwcomp-assoc-args (expr) |
1320 |
(if (and (eq (car-safe (nth 1 expr)) (car expr)) |
(if (and (eq (car-safe (nth 1 expr)) (car expr)) |
1321 |
(= (length (nth 1 expr)) 3)) |
(= (length (nth 1 expr)) 3)) |
1322 |
(math-rwcomp-assoc-args (nth 1 expr)) |
(math-rwcomp-assoc-args (nth 1 expr))) |
|
(setq math-args (cons (nth 1 expr) math-args))) |
|
1323 |
(if (and (eq (car-safe (nth 2 expr)) (car expr)) |
(if (and (eq (car-safe (nth 2 expr)) (car expr)) |
1324 |
(= (length (nth 2 expr)) 3)) |
(= (length (nth 2 expr)) 3)) |
1325 |
(math-rwcomp-assoc-args (nth 2 expr)) |
(math-rwcomp-assoc-args (nth 2 expr)))) |
|
(setq math-args (cons (nth 2 expr) math-args)))) |
|
1326 |
|
|
1327 |
(defun math-rwcomp-addsub-args (expr) |
(defun math-rwcomp-addsub-args (expr) |
1328 |
(if (memq (car-safe (nth 1 expr)) '(+ -)) |
(if (memq (car-safe (nth 1 expr)) '(+ -)) |
1329 |
(math-rwcomp-addsub-args (nth 1 expr)) |
(math-rwcomp-addsub-args (nth 1 expr))) |
|
(setq math-args (cons (nth 1 expr) math-args))) |
|
1330 |
(if (eq (car expr) '-) |
(if (eq (car expr) '-) |
1331 |
(setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args)) |
() |
1332 |
(if (eq (car-safe (nth 2 expr)) '+) |
(if (eq (car-safe (nth 2 expr)) '+) |
1333 |
(math-rwcomp-addsub-args (nth 2 expr)) |
(math-rwcomp-addsub-args (nth 2 expr))))) |
|
(setq math-args (cons (nth 2 expr) math-args))))) |
|
1334 |
|
|
1335 |
(defun math-rwcomp-order (a b) |
(defun math-rwcomp-order (a b) |
1336 |
(< (math-rwcomp-priority (car a)) |
(< (math-rwcomp-priority (car a)) |
1466 |
form |
form |
1467 |
'(setcar rules orig)))) |
'(setcar rules orig)))) |
1468 |
|
|
1469 |
(setq math-rewrite-phase 1) |
(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) |
1475 |
|
|
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 ruleset) |
(defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset) |
1481 |
(and |
(and |
1482 |
(setq rules (cdr (or (assq (car-safe expr) rules) |
(setq rules (cdr (or (assq (car-safe expr) rules) |
1483 |
(assq nil rules)))) |
(assq nil rules)))) |
1484 |
(let ((result nil) |
(let ((result nil) |
1485 |
op regs inst part pc mark btrack |
op math-apply-rw-regs inst part pc mark btrack |
1486 |
(tracing math-rwcomp-tracing) |
(tracing math-rwcomp-tracing) |
1487 |
(phase math-rewrite-phase)) |
(phase math-rewrite-phase)) |
1488 |
(while rules |
(while rules |
1493 |
(and (setq part (nth 3 (car rules))) |
(and (setq part (nth 3 (car rules))) |
1494 |
(not (memq phase part))) |
(not (memq phase part))) |
1495 |
(progn |
(progn |
1496 |
(setq regs (car (car rules)) |
(setq math-apply-rw-regs (car (car rules)) |
1497 |
pc (nth 1 (car rules)) |
pc (nth 1 (car rules)) |
1498 |
btrack nil) |
btrack nil) |
1499 |
(aset regs 0 expr) |
(aset math-apply-rw-regs 0 expr) |
1500 |
(while pc |
(while pc |
1501 |
|
|
1502 |
(and tracing |
(and tracing |
1503 |
(progn (terpri) (princ (car pc)) |
(progn (terpri) (princ (car pc)) |
1504 |
(if (and (natnump (nth 1 (car pc))) |
(if (and (natnump (nth 1 (car pc))) |
1505 |
(< (nth 1 (car pc)) (length regs))) |
(< (nth 1 (car pc)) (length math-apply-rw-regs))) |
1506 |
(princ (format "\n part = %s" |
(princ |
1507 |
(aref regs (nth 1 (car pc)))))))) |
(format "\n part = %s" |
1508 |
|
(aref math-apply-rw-regs (nth 1 (car pc)))))))) |
1509 |
|
|
1510 |
(cond ((eq (setq op (car (setq inst (car pc)))) 'func) |
(cond ((eq (setq op (car (setq inst (car pc)))) 'func) |
1511 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and (consp |
1512 |
|
(setq part (aref math-apply-rw-regs (car (cdr inst))))) |
1513 |
(eq (car part) |
(eq (car part) |
1514 |
(car (setq inst (cdr (cdr inst))))) |
(car (setq inst (cdr (cdr inst))))) |
1515 |
(progn |
(progn |
1516 |
(while (and (setq inst (cdr inst) |
(while (and (setq inst (cdr inst) |
1517 |
part (cdr part)) |
part (cdr part)) |
1518 |
inst) |
inst) |
1519 |
(aset regs (car inst) (car part))) |
(aset math-apply-rw-regs (car inst) (car part))) |
1520 |
(not (or inst part)))) |
(not (or inst part)))) |
1521 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1522 |
(math-rwfail))) |
(math-rwfail))) |
1523 |
|
|
1524 |
((eq op 'same) |
((eq op 'same) |
1525 |
(if (or (equal (setq part (aref regs (nth 1 inst))) |
(if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst))) |
1526 |
(setq mark (aref regs (nth 2 inst)))) |
(setq mark (aref math-apply-rw-regs (nth 2 inst)))) |
1527 |
(Math-equal part mark)) |
(Math-equal part mark)) |
1528 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1529 |
(math-rwfail))) |
(math-rwfail))) |
1532 |
calc-matrix-mode |
calc-matrix-mode |
1533 |
(not (eq calc-matrix-mode 'scalar)) |
(not (eq calc-matrix-mode 'scalar)) |
1534 |
(eq (car (nth 2 inst)) '*) |
(eq (car (nth 2 inst)) '*) |
1535 |
(consp (setq part (aref regs (car (cdr inst))))) |
(consp (setq part (aref math-apply-rw-regs (car (cdr inst))))) |
1536 |
(eq (car part) '*) |
(eq (car part) '*) |
1537 |
(not (math-known-scalarp part))) |
(not (math-known-scalarp part))) |
1538 |
(setq mark (nth 3 inst) |
(setq mark (nth 3 inst) |
1539 |
pc (cdr pc)) |
pc (cdr pc)) |
1540 |
(if (aref mark 4) |
(if (aref mark 4) |
1541 |
(progn |
(progn |
1542 |
(aset regs (nth 4 inst) (nth 2 part)) |
(aset math-apply-rw-regs (nth 4 inst) (nth 2 part)) |
1543 |
(aset mark 1 (cdr (cdr part)))) |
(aset mark 1 (cdr (cdr part)))) |
1544 |
(aset regs (nth 4 inst) (nth 1 part)) |
(aset math-apply-rw-regs (nth 4 inst) (nth 1 part)) |
1545 |
(aset mark 1 (cdr part))) |
(aset mark 1 (cdr part))) |
1546 |
(aset mark 0 (cdr part)) |
(aset mark 0 (cdr part)) |
1547 |
(aset mark 2 0)) |
(aset mark 2 0)) |
1548 |
|
|
1549 |
((eq op 'try) |
((eq op 'try) |
1550 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and (consp (setq part |
1551 |
|
(aref math-apply-rw-regs (car (cdr inst))))) |
1552 |
(memq (car part) (nth 2 inst)) |
(memq (car part) (nth 2 inst)) |
1553 |
(= (length part) 3) |
(= (length part) 3) |
1554 |
(or (not (eq (car part) '/)) |
(or (not (eq (car part) '/)) |
1584 |
op)) |
op)) |
1585 |
btrack (cons pc btrack) |
btrack (cons pc btrack) |
1586 |
pc (cdr pc)) |
pc (cdr pc)) |
1587 |
(aset regs (nth 2 inst) (car op)) |
(aset math-apply-rw-regs (nth 2 inst) (car op)) |
1588 |
(aset mark 0 op) |
(aset mark 0 op) |
1589 |
(aset mark 1 op) |
(aset mark 1 op) |
1590 |
(aset mark 2 (if (cdr (cdr op)) 1 0))) |
(aset mark 2 (if (cdr (cdr op)) 1 0))) |
1596 |
(progn |
(progn |
1597 |
(setq mark (nth 3 inst) |
(setq mark (nth 3 inst) |
1598 |
pc (cdr pc)) |
pc (cdr pc)) |
1599 |
(aset regs (nth 4 inst) (nth 1 part)) |
(aset math-apply-rw-regs (nth 4 inst) (nth 1 part)) |
1600 |
(aset mark 1 -1) |
(aset mark 1 -1) |
1601 |
(aset mark 2 4)) |
(aset mark 2 4)) |
1602 |
(setq mark (nth 3 inst) |
(setq mark (nth 3 inst) |
1603 |
pc (cdr pc)) |
pc (cdr pc)) |
1604 |
(aset regs (nth 4 inst) part) |
(aset math-apply-rw-regs (nth 4 inst) part) |
1605 |
(aset mark 2 3)) |
(aset mark 2 3)) |
1606 |
(math-rwfail)))) |
(math-rwfail)))) |
1607 |
|
|
1610 |
mark (nth 3 part) |
mark (nth 3 part) |
1611 |
op (aref mark 2) |
op (aref mark 2) |
1612 |
pc (cdr pc)) |
pc (cdr pc)) |
1613 |
(aset regs (nth 2 inst) |
(aset math-apply-rw-regs (nth 2 inst) |
1614 |
(cond |
(cond |
1615 |
((eq op 0) |
((eq op 0) |
1616 |
(if (eq (aref mark 0) (aref mark 1)) |
(if (eq (aref mark 0) (aref mark 1)) |
1650 |
|
|
1651 |
((eq op 'select) |
((eq op 'select) |
1652 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1653 |
(if (and (consp (setq part (aref regs (nth 1 inst)))) |
(if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst)))) |
1654 |
(eq (car part) 'calcFunc-select)) |
(eq (car part) 'calcFunc-select)) |
1655 |
(aset regs (nth 2 inst) (nth 1 part)) |
(aset math-apply-rw-regs (nth 2 inst) (nth 1 part)) |
1656 |
(if math-rewrite-selections |
(if math-rewrite-selections |
1657 |
(math-rwfail) |
(math-rwfail) |
1658 |
(aset regs (nth 2 inst) part)))) |
(aset math-apply-rw-regs (nth 2 inst) part)))) |
1659 |
|
|
1660 |
((eq op 'same-neg) |
((eq op 'same-neg) |
1661 |
(if (or (equal (setq part (aref regs (nth 1 inst))) |
(if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst))) |
1662 |
(setq mark (math-neg |
(setq mark (math-neg |
1663 |
(aref regs (nth 2 inst))))) |
(aref math-apply-rw-regs (nth 2 inst))))) |
1664 |
(Math-equal part mark)) |
(Math-equal part mark)) |
1665 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1666 |
(math-rwfail))) |
(math-rwfail))) |
1672 |
op (aref mark 2)) |
op (aref mark 2)) |
1673 |
(cond ((eq op 0) |
(cond ((eq op 0) |
1674 |
(if (setq op (cdr (aref mark 1))) |
(if (setq op (cdr (aref mark 1))) |
1675 |
(aset regs (nth 4 inst) (car (aset mark 1 op))) |
(aset math-apply-rw-regs (nth 4 inst) |
1676 |
|
(car (aset mark 1 op))) |
1677 |
(if (nth 5 inst) |
(if (nth 5 inst) |
1678 |
(progn |
(progn |
1679 |
(aset mark 2 3) |
(aset mark 2 3) |
1680 |
(aset regs (nth 4 inst) |
(aset math-apply-rw-regs (nth 4 inst) |
1681 |
(aref regs (nth 1 inst)))) |
(aref math-apply-rw-regs (nth 1 inst)))) |
1682 |
(math-rwfail t)))) |
(math-rwfail t)))) |
1683 |
((eq op 1) |
((eq op 1) |
1684 |
(if (setq op (cdr (aref mark 1))) |
(if (setq op (cdr (aref mark 1))) |
1685 |
(aset regs (nth 4 inst) (car (aset mark 1 op))) |
(aset math-apply-rw-regs (nth 4 inst) |
1686 |
|
(car (aset mark 1 op))) |
1687 |
(if (= (aref mark 3) 1) |
(if (= (aref mark 3) 1) |
1688 |
(if (nth 5 inst) |
(if (nth 5 inst) |
1689 |
(progn |
(progn |
1690 |
(aset mark 2 3) |
(aset mark 2 3) |
1691 |
(aset regs (nth 4 inst) |
(aset math-apply-rw-regs (nth 4 inst) |
1692 |
(aref regs (nth 1 inst)))) |
(aref math-apply-rw-regs (nth 1 inst)))) |
1693 |
(math-rwfail t)) |
(math-rwfail t)) |
1694 |
(aset mark 2 2) |
(aset mark 2 2) |
1695 |
(aset mark 1 (cons nil (aref mark 0))) |
(aset mark 1 (cons nil (aref mark 0))) |
1727 |
(list '- part |
(list '- part |
1728 |
(nth 1 (car mark))) |
(nth 1 (car mark))) |
1729 |
(list op part (car mark)))))) |
(list op part (car mark)))))) |
1730 |
(aset regs (nth 4 inst) part)) |
(aset math-apply-rw-regs (nth 4 inst) part)) |
1731 |
(if (nth 5 inst) |
(if (nth 5 inst) |
1732 |
(progn |
(progn |
1733 |
(aset mark 2 3) |
(aset mark 2 3) |
1734 |
(aset regs (nth 4 inst) |
(aset math-apply-rw-regs (nth 4 inst) |
1735 |
(aref regs (nth 1 inst)))) |
(aref math-apply-rw-regs (nth 1 inst)))) |
1736 |
(math-rwfail t)))) |
(math-rwfail t)))) |
1737 |
((eq op 4) |
((eq op 4) |
1738 |
(setq btrack (cdr btrack))) |
(setq btrack (cdr btrack))) |
1739 |
(t (math-rwfail t)))) |
(t (math-rwfail t)))) |
1740 |
|
|
1741 |
((eq op 'integer) |
((eq op 'integer) |
1742 |
(if (Math-integerp (setq part (aref regs (nth 1 inst)))) |
(if (Math-integerp (setq part |
1743 |
|
(aref math-apply-rw-regs (nth 1 inst)))) |
1744 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1745 |
(if (Math-primp part) |
(if (Math-primp part) |
1746 |
(math-rwfail) |
(math-rwfail) |
1750 |
(math-rwfail))))) |
(math-rwfail))))) |
1751 |
|
|
1752 |
((eq op 'real) |
((eq op 'real) |
1753 |
(if (Math-realp (setq part (aref regs (nth 1 inst)))) |
(if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst)))) |
1754 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1755 |
(if (Math-primp part) |
(if (Math-primp part) |
1756 |
(math-rwfail) |
(math-rwfail) |
1760 |
(math-rwfail))))) |
(math-rwfail))))) |
1761 |
|
|
1762 |
((eq op 'constant) |
((eq op 'constant) |
1763 |
(if (math-constp (setq part (aref regs (nth 1 inst)))) |
(if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst)))) |
1764 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1765 |
(if (Math-primp part) |
(if (Math-primp part) |
1766 |
(math-rwfail) |
(math-rwfail) |
1770 |
(math-rwfail))))) |
(math-rwfail))))) |
1771 |
|
|
1772 |
((eq op 'negative) |
((eq op 'negative) |
1773 |
(if (math-looks-negp (setq part (aref regs (nth 1 inst)))) |
(if (math-looks-negp (setq part |
1774 |
|
(aref math-apply-rw-regs (nth 1 inst)))) |
1775 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1776 |
(if (Math-primp part) |
(if (Math-primp part) |
1777 |
(math-rwfail) |
(math-rwfail) |
1781 |
(math-rwfail))))) |
(math-rwfail))))) |
1782 |
|
|
1783 |
((eq op 'rel) |
((eq op 'rel) |
1784 |
(setq part (math-compare (aref regs (nth 1 inst)) |
(setq part (math-compare (aref math-apply-rw-regs (nth 1 inst)) |
1785 |
(aref regs (nth 3 inst))) |
(aref math-apply-rw-regs (nth 3 inst))) |
1786 |
op (nth 2 inst)) |
op (nth 2 inst)) |
1787 |
(if (= part 2) |
(if (= part 2) |
1788 |
(setq part (math-rweval |
(setq part (math-rweval |
1789 |
(math-simplify |
(math-simplify |
1790 |
(calcFunc-sign |
(calcFunc-sign |
1791 |
(math-sub (aref regs (nth 1 inst)) |
(math-sub |
1792 |
(aref regs (nth 3 inst)))))))) |
(aref math-apply-rw-regs (nth 1 inst)) |
1793 |
|
(aref math-apply-rw-regs (nth 3 inst)))))))) |
1794 |
(if (cond ((eq op 'calcFunc-eq) |
(if (cond ((eq op 'calcFunc-eq) |
1795 |
(eq part 0)) |
(eq part 0)) |
1796 |
((eq op 'calcFunc-neq) |
((eq op 'calcFunc-neq) |
1807 |
(math-rwfail))) |
(math-rwfail))) |
1808 |
|
|
1809 |
((eq op 'func-def) |
((eq op 'func-def) |
1810 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and |
1811 |
(eq (car part) |
(consp (setq part (aref math-apply-rw-regs (car (cdr inst))))) |
1812 |
(car (setq inst (cdr (cdr inst)))))) |
(eq (car part) |
1813 |
|
(car (setq inst (cdr (cdr inst)))))) |
1814 |
(progn |
(progn |
1815 |
(setq inst (cdr inst) |
(setq inst (cdr inst) |
1816 |
mark (car inst)) |
mark (car inst)) |
1817 |
(while (and (setq inst (cdr inst) |
(while (and (setq inst (cdr inst) |
1818 |
part (cdr part)) |
part (cdr part)) |
1819 |
inst) |
inst) |
1820 |
(aset regs (car inst) (car part))) |
(aset math-apply-rw-regs (car inst) (car part))) |
1821 |
(if (or inst part) |
(if (or inst part) |
1822 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1823 |
(while (eq (car (car (setq pc (cdr pc)))) |
(while (eq (car (car (setq pc (cdr pc)))) |
1824 |
'func-def)) |
'func-def)) |
1825 |
(setq pc (cdr pc)) ; skip over "func" |
(setq pc (cdr pc)) ; skip over "func" |
1826 |
(while mark |
(while mark |
1827 |
(aset regs (cdr (car mark)) (car (car mark))) |
(aset math-apply-rw-regs (cdr (car mark)) (car (car mark))) |
1828 |
(setq mark (cdr mark))))) |
(setq mark (cdr mark))))) |
1829 |
(math-rwfail))) |
(math-rwfail))) |
1830 |
|
|
1831 |
((eq op 'func-opt) |
((eq op 'func-opt) |
1832 |
(if (or (not (and (consp |
(if (or (not |
1833 |
(setq part (aref regs (car (cdr inst))))) |
(and |
1834 |
(eq (car part) (nth 2 inst)))) |
(consp |
1835 |
|
(setq part (aref math-apply-rw-regs (car (cdr inst))))) |
1836 |
|
(eq (car part) (nth 2 inst)))) |
1837 |
(and (= (length part) 2) |
(and (= (length part) 2) |
1838 |
(setq part (nth 1 part)))) |
(setq part (nth 1 part)))) |
1839 |
(progn |
(progn |
1840 |
(setq mark (nth 3 inst)) |
(setq mark (nth 3 inst)) |
1841 |
(aset regs (nth 4 inst) part) |
(aset math-apply-rw-regs (nth 4 inst) part) |
1842 |
(while (eq (car (car (setq pc (cdr pc)))) 'func-def)) |
(while (eq (car (car (setq pc (cdr pc)))) 'func-def)) |
1843 |
(setq pc (cdr pc)) ; skip over "func" |
(setq pc (cdr pc)) ; skip over "func" |
1844 |
(while mark |
(while mark |
1845 |
(aset regs (cdr (car mark)) (car (car mark))) |
(aset math-apply-rw-regs (cdr (car mark)) (car (car mark))) |
1846 |
(setq mark (cdr mark)))) |
(setq mark (cdr mark)))) |
1847 |
(setq pc (cdr pc)))) |
(setq pc (cdr pc)))) |
1848 |
|
|
1849 |
((eq op 'mod) |
((eq op 'mod) |
1850 |
(if (if (Math-zerop (setq part (aref regs (nth 1 inst)))) |
(if (if (Math-zerop |
1851 |
|
(setq part (aref math-apply-rw-regs (nth 1 inst)))) |
1852 |
(Math-zerop (nth 3 inst)) |
(Math-zerop (nth 3 inst)) |
1853 |
(and (not (Math-zerop (nth 2 inst))) |
(and (not (Math-zerop (nth 2 inst))) |
1854 |
(progn |
(progn |
1861 |
(math-rwfail))) |
(math-rwfail))) |
1862 |
|
|
1863 |
((eq op 'apply) |
((eq op 'apply) |
1864 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and (consp |
1865 |
|
(setq part (aref math-apply-rw-regs (car (cdr inst))))) |
1866 |
(not (Math-objvecp part)) |
(not (Math-objvecp part)) |
1867 |
(not (eq (car part) 'var))) |
(not (eq (car part) 'var))) |
1868 |
(progn |
(progn |
1869 |
(aset regs (nth 2 inst) |
(aset math-apply-rw-regs (nth 2 inst) |
1870 |
(math-calcFunc-to-var (car part))) |
(math-calcFunc-to-var (car part))) |
1871 |
(aset regs (nth 3 inst) |
(aset math-apply-rw-regs (nth 3 inst) |
1872 |
(cons 'vec (cdr part))) |
(cons 'vec (cdr part))) |
1873 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1874 |
(math-rwfail))) |
(math-rwfail))) |
1875 |
|
|
1876 |
((eq op 'cons) |
((eq op 'cons) |
1877 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and (consp |
1878 |
|
(setq part (aref math-apply-rw-regs (car (cdr inst))))) |
1879 |
(eq (car part) 'vec) |
(eq (car part) 'vec) |
1880 |
(cdr part)) |
(cdr part)) |
1881 |
(progn |
(progn |
1882 |
(aset regs (nth 2 inst) (nth 1 part)) |
(aset math-apply-rw-regs (nth 2 inst) (nth 1 part)) |
1883 |
(aset regs (nth 3 inst) (cons 'vec (cdr (cdr part)))) |
(aset math-apply-rw-regs (nth 3 inst) |
1884 |
|
(cons 'vec (cdr (cdr part)))) |
1885 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1886 |
(math-rwfail))) |
(math-rwfail))) |
1887 |
|
|
1888 |
((eq op 'rcons) |
((eq op 'rcons) |
1889 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and (consp |
1890 |
|
(setq part (aref math-apply-rw-regs (car (cdr inst))))) |
1891 |
(eq (car part) 'vec) |
(eq (car part) 'vec) |
1892 |
(cdr part)) |
(cdr part)) |
1893 |
(progn |
(progn |
1894 |
(aset regs (nth 2 inst) (calcFunc-rhead part)) |
(aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part)) |
1895 |
(aset regs (nth 3 inst) (calcFunc-rtail part)) |
(aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part)) |
1896 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1897 |
(math-rwfail))) |
(math-rwfail))) |
1898 |
|
|
1905 |
(math-rwfail))) |
(math-rwfail))) |
1906 |
|
|
1907 |
((eq op 'let) |
((eq op 'let) |
1908 |
(aset regs (nth 1 inst) |
(aset math-apply-rw-regs (nth 1 inst) |
1909 |
(math-rweval |
(math-rweval |
1910 |
(math-normalize |
(math-normalize |
1911 |
(math-rwapply-replace-regs (nth 2 inst))))) |
(math-rwapply-replace-regs (nth 2 inst))))) |
1912 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1913 |
|
|
1914 |
((eq op 'copy) |
((eq op 'copy) |
1915 |
(aset regs (nth 2 inst) (aref regs (nth 1 inst))) |
(aset math-apply-rw-regs (nth 2 inst) |
1916 |
|
(aref math-apply-rw-regs (nth 1 inst))) |
1917 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1918 |
|
|
1919 |
((eq op 'copy-neg) |
((eq op 'copy-neg) |
1920 |
(aset regs (nth 2 inst) |
(aset math-apply-rw-regs (nth 2 inst) |
1921 |
(math-rwapply-neg (aref regs (nth 1 inst)))) |
(math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst)))) |
1922 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1923 |
|
|
1924 |
((eq op 'alt) |
((eq op 'alt) |
1977 |
(cond ((Math-primp expr) |
(cond ((Math-primp expr) |
1978 |
expr) |
expr) |
1979 |
((eq (car expr) 'calcFunc-register) |
((eq (car expr) 'calcFunc-register) |
1980 |
(setq expr (aref regs (nth 1 expr))) |
(setq expr (aref math-apply-rw-regs (nth 1 expr))) |
1981 |
(if (eq (car-safe expr) '*) |
(if (eq (car-safe expr) '*) |
1982 |
(if (eq (nth 1 expr) -1) |
(if (eq (nth 1 expr) -1) |
1983 |
(math-neg (nth 2 expr)) |
(math-neg (nth 2 expr)) |
2026 |
(math-rwapply-reg-neg (nth 1 expr))) |
(math-rwapply-reg-neg (nth 1 expr))) |
2027 |
((and (eq (car expr) 'neg) |
((and (eq (car expr) 'neg) |
2028 |
(eq (car-safe (nth 1 expr)) 'calcFunc-register) |
(eq (car-safe (nth 1 expr)) 'calcFunc-register) |
2029 |
(math-scalarp (aref regs (nth 1 (nth 1 expr))))) |
(math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr))))) |
2030 |
(math-neg (math-rwapply-replace-regs (nth 1 expr)))) |
(math-neg (math-rwapply-replace-regs (nth 1 expr)))) |
2031 |
((and (eq (car expr) '+) |
((and (eq (car expr) '+) |
2032 |
(math-rwapply-reg-looks-negp (nth 1 expr))) |
(math-rwapply-reg-looks-negp (nth 1 expr))) |
2074 |
(if (Math-primp (nth 1 expr)) |
(if (Math-primp (nth 1 expr)) |
2075 |
(nth 1 expr) |
(nth 1 expr) |
2076 |
(if (eq (car (nth 1 expr)) 'calcFunc-register) |
(if (eq (car (nth 1 expr)) 'calcFunc-register) |
2077 |
(aref regs (nth 1 (nth 1 expr))) |
(aref math-apply-rw-regs (nth 1 (nth 1 expr))) |
2078 |
(cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs |
(cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs |
2079 |
(cdr (nth 1 expr))))))) |
(cdr (nth 1 expr))))))) |
2080 |
(t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))) |
(t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))) |
2081 |
|
|
2082 |
(defun math-rwapply-reg-looks-negp (expr) |
(defun math-rwapply-reg-looks-negp (expr) |
2083 |
(if (eq (car-safe expr) 'calcFunc-register) |
(if (eq (car-safe expr) 'calcFunc-register) |
2084 |
(math-looks-negp (aref regs (nth 1 expr))) |
(math-looks-negp (aref math-apply-rw-regs (nth 1 expr))) |
2085 |
(if (memq (car-safe expr) '(* /)) |
(if (memq (car-safe expr) '(* /)) |
2086 |
(or (math-rwapply-reg-looks-negp (nth 1 expr)) |
(or (math-rwapply-reg-looks-negp (nth 1 expr)) |
2087 |
(math-rwapply-reg-looks-negp (nth 2 expr)))))) |
(math-rwapply-reg-looks-negp (nth 2 expr)))))) |
2098 |
(math-rwapply-reg-neg (nth 2 expr))))))) |
(math-rwapply-reg-neg (nth 2 expr))))))) |
2099 |
|
|
2100 |
(defun math-rwapply-remember (old new) |
(defun math-rwapply-remember (old new) |
2101 |
(let ((varval (symbol-value (nth 2 (car ruleset)))) |
(let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset)))) |
2102 |
(rules (assq (car-safe old) ruleset))) |
(rules (assq (car-safe old) math-apply-rw-ruleset))) |
2103 |
(if (and (eq (car-safe varval) 'vec) |
(if (and (eq (car-safe varval) 'vec) |
2104 |
(not (memq (car-safe old) '(nil schedule + -))) |
(not (memq (car-safe old) '(nil schedule + -))) |
2105 |
rules) |
rules) |