diff options
| author | Jay Belanger | 2004-11-19 21:03:48 +0000 |
|---|---|---|
| committer | Jay Belanger | 2004-11-19 21:03:48 +0000 |
| commit | 40ead937150cf5654640b26f3702cf650c0452bf (patch) | |
| tree | e558f77eddae9ac324cbc36358d23e6dc3fce834 | |
| parent | 6de891db98164cc4981a953257dec7fc7c97f2b1 (diff) | |
| download | emacs-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.el | 367 |
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) |