diff options
Diffstat (limited to 'lisp/calc/calc-rewr.el')
| -rw-r--r-- | lisp/calc/calc-rewr.el | 44 |
1 files changed, 25 insertions, 19 deletions
diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el index bb909e728e1..2cc7b6beef0 100644 --- a/lisp/calc/calc-rewr.el +++ b/lisp/calc/calc-rewr.el @@ -1,4 +1,4 @@ -;;; calc-rewr.el --- rewriting functions for Calc +;;; calc-rewr.el --- rewriting functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2020 Free Software Foundation, Inc. @@ -142,7 +142,7 @@ (calc-pop-push-record-list n "rwrt" (list expr))) (calc-handle-whys))) -(defun calc-match (pat &optional interactive) +(defun calc-match (pat &optional _interactive) (interactive "sPattern: \np") (calc-slow-wrapper (let (n expr) @@ -158,9 +158,9 @@ (setq expr (calc-top-n 1) n 1)) (or (math-vectorp expr) (error "Argument must be a vector")) - (if (calc-is-inverse) - (calc-enter-result n "mtcn" (math-match-patterns pat expr t)) - (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))) + (calc-enter-result n "mtcn" + (math-match-patterns pat expr + (not (not (calc-is-inverse)))))))) (defvar math-mt-many) @@ -169,8 +169,10 @@ ;; but is used by math-rewrite-phase (defvar math-rewrite-whole-expr) -(defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many) - (let* ((crules (math-compile-rewrites rules)) +(defun math-rewrite (rewrite-whole-expr rules &optional mt-many) + (let* ((math-rewrite-whole-expr rewrite-whole-expr) + (math-mt-many mt-many) + (crules (math-compile-rewrites rules)) (heads (math-rewrite-heads math-rewrite-whole-expr)) (trace-buffer (get-buffer "*Trace*")) (calc-display-just 'center) @@ -211,6 +213,8 @@ ":\n" fmt "\n")))) math-rewrite-whole-expr)) +(defvar math-rewrite-phase 1) + (defun math-rewrite-phase (sched) (while (and sched (/= math-mt-many 0)) (if (listp (car sched)) @@ -464,6 +468,8 @@ ;;; whole match the name v. Beware of circular structures! ;;; +(defvar math-rewrite-whole nil) + (defun math-compile-patterns (pats) (if (and (eq (car-safe pats) 'var) (calc-var-value (nth 2 pats))) @@ -485,7 +491,6 @@ (cdr pats) (list pats))))))))) -(defvar math-rewrite-whole nil) (defvar math-make-import-list nil) ;; The variable math-import-list is local to part of math-compile-rewrites, @@ -580,7 +585,7 @@ (let ((rule-set nil) (all-heads nil) (nil-rules nil) - (rule-count 0) + ;; (rule-count 0) (math-schedule nil) (math-iterations nil) (math-phases nil) @@ -831,14 +836,16 @@ (defvar math-rwcomp-subst-new-func) (defvar math-rwcomp-subst-old-func) -(defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new) - (if (and (eq (car-safe math-rwcomp-subst-old) 'var) - (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda))) - (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old)) - (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new))) +(defun math-rwcomp-substitute (expr rwcomp-subst-old rwcomp-subst-new) + (let ((math-rwcomp-subst-old rwcomp-subst-old) + (math-rwcomp-subst-new rwcomp-subst-new)) + (if (and (eq (car-safe rwcomp-subst-old) 'var) + (memq (car-safe rwcomp-subst-new) '(var calcFunc-lambda))) + (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc rwcomp-subst-old)) + (math-rwcomp-subst-new-func (math-var-to-calcFunc rwcomp-subst-new))) (math-rwcomp-subst-rec expr)) (let ((math-rwcomp-subst-old-func nil)) - (math-rwcomp-subst-rec expr)))) + (math-rwcomp-subst-rec expr))))) (defun math-rwcomp-subst-rec (expr) (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new) @@ -1452,8 +1459,6 @@ ,form (setcar rules orig)))) -(defvar math-rewrite-phase 1) - ;; The variable math-apply-rw-regs is local to math-apply-rewrites, ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp ;; which are called by math-apply-rewrites. @@ -1463,11 +1468,12 @@ ;; but is used by math-rwapply-remember. (defvar math-apply-rw-ruleset) -(defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset) +(defun math-apply-rewrites (expr rules &optional heads apply-rw-ruleset) (and (setq rules (cdr (or (assq (car-safe expr) rules) (assq nil rules)))) - (let ((result nil) + (let ((math-apply-rw-ruleset apply-rw-ruleset) + (result nil) op math-apply-rw-regs inst part pc mark btrack (tracing math-rwcomp-tracing) (phase math-rewrite-phase)) |