;;; calc-rewr.el --- rewriting functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
-;; Maintainers: D. Goel <deego@gnufans.org>
-;; Colin Walters <walters@debian.org>
+;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
;; This file is part of GNU Emacs.
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY. No author or distributor
-;; accepts responsibility to anyone for the consequences of using it
-;; or for whether it serves any particular purpose or works at all,
-;; unless he says so in writing. Refer to the GNU Emacs General Public
-;; License for full details.
-
-;; Everyone is granted permission to copy, modify and redistribute
-;; GNU Emacs, but only under the conditions described in the
-;; GNU Emacs General Public License. A copy of this license is
-;; supposed to have been given to you along with GNU Emacs so you
-;; can know your rights and responsibilities. It should be in a
-;; file named COPYING. Among other things, the copyright notice
-;; and this notice must be preserved on all copies.
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
;; This file is autoloaded from calc-ext.el.
-(require 'calc-ext)
+(require 'calc-ext)
(require 'calc-macs)
-(defun calc-Need-calc-rewr () nil)
+(defvar math-rewrite-default-iters 100)
+;; The variable calc-rewr-sel is local to calc-rewrite-selection and
+;; calc-rewrite, but is used by calc-locate-selection-marker.
+(defvar calc-rewr-sel)
-(defvar math-rewrite-default-iters 100)
(defun calc-rewrite-selection (rules-str &optional many prefix)
(interactive "sRewrite rule(s): \np")
(calc-slow-wrapper
(let* ((num (max 1 (calc-locate-cursor-element (point))))
(reselect t)
(pop-rules nil)
+ rules
(entry (calc-top num 'entry))
(expr (car entry))
- (sel (calc-auto-selection entry))
+ (calc-rewr-sel (calc-auto-selection entry))
(math-rewrite-selections t)
(math-rewrite-default-iters 1))
(if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
(if (eq many 0)
(setq many '(var inf var-inf))
(if many (setq many (prefix-numeric-value many))))
- (if sel
+ (if calc-rewr-sel
(setq expr (calc-replace-sub-formula (car entry)
- sel
- (list 'calcFunc-select sel)))
+ calc-rewr-sel
+ (list 'calcFunc-select calc-rewr-sel)))
(setq expr (car entry)
reselect nil
math-rewrite-selections nil))
(math-rewrite
(calc-normalize expr)
rules many)))
- sel nil
+ calc-rewr-sel nil
expr (calc-locate-select-marker expr))
- (or (consp sel) (setq sel nil))
+ (or (consp calc-rewr-sel) (setq calc-rewr-sel nil))
(if pop-rules (calc-pop-stack 1))
(calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
(- num (if pop-rules 1 0))
- (list (and reselect sel))))
+ (list (and reselect calc-rewr-sel))))
(calc-handle-whys)))
-(defun calc-locate-select-marker (expr) ; changes "sel"
+(defun calc-locate-select-marker (expr)
(if (Math-primp expr)
expr
(if (and (eq (car expr) 'calcFunc-select)
(= (length expr) 2))
(progn
- (setq sel (if sel t (nth 1 expr)))
+ (setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr)))
(nth 1 expr))
(cons (car expr)
(mapcar 'calc-locate-select-marker (cdr expr))))))
(setq many '(var inf var-inf))
(if many (setq many (prefix-numeric-value many))))
(setq expr (calc-normalize (math-rewrite expr rules many)))
- (let (sel)
+ (let (calc-rewr-sel)
(setq expr (calc-locate-select-marker expr)))
(calc-pop-push-record-list n "rwrt" (list expr)))
(calc-handle-whys)))
-(defun calc-match (pat)
- (interactive "sPattern: \n")
+(defun calc-match (pat &optional interactive)
+ (interactive "sPattern: \np")
(calc-slow-wrapper
(let (n expr)
(if (or (null pat) (equal pat "") (equal pat "$"))
(setq expr (calc-top-n 2)
pat (calc-top-n 1)
n 2)
- (if (interactive-p) (setq calc-previous-alg-entry pat))
(setq pat (if (stringp pat) (math-read-expr pat) pat))
(if (eq (car-safe pat) 'error)
(error "Bad format in expression: %s" (nth 1 pat)))
(calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
-
-(defun math-rewrite (whole-expr rules &optional mmt-many)
- (let ((crules (math-compile-rewrites rules))
- (heads (math-rewrite-heads whole-expr))
- (trace-buffer (get-buffer "*Trace*"))
- (calc-display-just 'center)
- (calc-display-origin 39)
- (calc-line-breaking 78)
- (calc-line-numbering nil)
- (calc-show-selections t)
- (calc-why nil)
- (mmt-func (function
- (lambda (x)
- (let ((result (math-apply-rewrites x (cdr crules)
- heads crules)))
- (if result
- (progn
- (if trace-buffer
- (let ((fmt (math-format-stack-value
- (list result nil nil))))
- (save-excursion
- (set-buffer trace-buffer)
- (insert "\nrewrite to\n" fmt "\n"))))
- (setq heads (math-rewrite-heads result heads t))))
- result)))))
+(defvar math-mt-many)
+
+;; The variable math-rewrite-whole-expr is local to math-rewrite,
+;; 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))
+ (heads (math-rewrite-heads math-rewrite-whole-expr))
+ (trace-buffer (get-buffer "*Trace*"))
+ (calc-display-just 'center)
+ (calc-display-origin 39)
+ (calc-line-breaking 78)
+ (calc-line-numbering nil)
+ (calc-show-selections t)
+ (calc-why nil)
+ (math-mt-func (function
+ (lambda (x)
+ (let ((result (math-apply-rewrites x (cdr crules)
+ heads crules)))
+ (if result
+ (progn
+ (if trace-buffer
+ (let ((fmt (math-format-stack-value
+ (list result nil nil))))
+ (with-current-buffer trace-buffer
+ (insert "\nrewrite to\n" fmt "\n"))))
+ (setq heads (math-rewrite-heads result heads t))))
+ result)))))
(if trace-buffer
- (let ((fmt (math-format-stack-value (list whole-expr nil nil))))
- (save-excursion
- (set-buffer trace-buffer)
+ (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
+ (with-current-buffer trace-buffer
(setq truncate-lines t)
(goto-char (point-max))
(insert "\n\nBegin rewriting\n" fmt "\n"))))
- (or mmt-many (setq mmt-many (or (nth 1 (car crules))
+ (or math-mt-many (setq math-mt-many (or (nth 1 (car crules))
math-rewrite-default-iters)))
- (if (equal mmt-many '(var inf var-inf)) (setq mmt-many 1000000))
- (if (equal mmt-many '(neg (var inf var-inf))) (setq mmt-many -1000000))
+ (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
+ (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
(math-rewrite-phase (nth 3 (car crules)))
(if trace-buffer
- (let ((fmt (math-format-stack-value (list whole-expr nil nil))))
- (save-excursion
- (set-buffer trace-buffer)
+ (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
+ (with-current-buffer trace-buffer
(insert "\nDone rewriting"
- (if (= mmt-many 0) " (reached iteration limit)" "")
+ (if (= math-mt-many 0) " (reached iteration limit)" "")
":\n" fmt "\n"))))
- whole-expr))
+ math-rewrite-whole-expr))
(defun math-rewrite-phase (sched)
- (while (and sched (/= mmt-many 0))
+ (while (and sched (/= math-mt-many 0))
(if (listp (car sched))
- (while (let ((save-expr whole-expr))
+ (while (let ((save-expr math-rewrite-whole-expr))
(math-rewrite-phase (car sched))
- (not (equal whole-expr save-expr))))
+ (not (equal math-rewrite-whole-expr save-expr))))
(if (symbolp (car sched))
(progn
- (setq whole-expr (math-normalize (list (car sched) whole-expr)))
+ (setq math-rewrite-whole-expr
+ (math-normalize (list (car sched) math-rewrite-whole-expr)))
(if trace-buffer
(let ((fmt (math-format-stack-value
- (list whole-expr nil nil))))
- (save-excursion
- (set-buffer trace-buffer)
+ (list math-rewrite-whole-expr nil nil))))
+ (with-current-buffer trace-buffer
(insert "\ncall "
(substring (symbol-name (car sched)) 9)
":\n" fmt "\n")))))
(let ((math-rewrite-phase (car sched)))
(if trace-buffer
- (save-excursion
- (set-buffer trace-buffer)
+ (with-current-buffer trace-buffer
(insert (format "\n(Phase %d)\n" math-rewrite-phase))))
- (while (let ((save-expr whole-expr))
- (setq whole-expr (math-normalize
- (math-map-tree-rec whole-expr)))
- (not (equal whole-expr save-expr)))))))
+ (while (let ((save-expr math-rewrite-whole-expr))
+ (setq math-rewrite-whole-expr (math-normalize
+ (math-map-tree-rec math-rewrite-whole-expr)))
+ (not (equal math-rewrite-whole-expr save-expr)))))))
(setq sched (cdr sched))))
(defun calcFunc-rewrite (expr rules &optional many)
-;;; A compiled rule set is an a-list of entries whose cars are functors,
-;;; and whose cdrs are lists of rules. If there are rules with no
-;;; well-defined head functor, they are included on all lists and also
-;;; on an extra list whose car is nil.
-;;;
-;;; The first entry in the a-list is of the form (schedule A B C ...).
-;;;
-;;; Rule list entries take the form (regs prog head phases), where:
-;;;
-;;; regs is a vector of match registers.
-;;;
-;;; prog is a match program (see below).
-;;;
-;;; head is a rare function name appearing in the rule body (but not the
-;;; head of the whole rule), or nil if none.
-;;;
-;;; phases is a list of phase numbers for which the rule is enabled.
-;;;
-;;; A match program is a list of match instructions.
-;;;
-;;; In the following, "part" is a register number that contains the
-;;; subexpression to be operated on.
-;;;
-;;; Register 0 is the whole expression being matched. The others are
-;;; meta-variables in the pattern, temporaries used for matching and
-;;; backtracking, and constant expressions.
-;;;
-;;; (same part reg)
-;;; The selected part must be math-equal to the contents of "reg".
-;;;
-;;; (same-neg part reg)
-;;; The selected part must be math-equal to the negative of "reg".
-;;;
-;;; (copy part reg)
-;;; The selected part is copied into "reg". (Rarely used.)
-;;;
-;;; (copy-neg part reg)
-;;; The negative of the selected part is copied into "reg".
-;;;
-;;; (integer part)
-;;; The selected part must be an integer.
-;;;
-;;; (real part)
-;;; The selected part must be a real.
-;;;
-;;; (constant part)
-;;; The selected part must be a constant.
-;;;
-;;; (negative part)
-;;; The selected part must "look" negative.
-;;;
-;;; (rel part op reg)
-;;; The selected part must satisfy "part op reg", where "op"
-;;; is one of the 6 relational ops, and "reg" is a register.
-;;;
-;;; (mod part modulo value)
-;;; The selected part must satisfy "part % modulo = value", where
-;;; "modulo" and "value" are constants.
-;;;
-;;; (func part head reg1 reg2 ... regn)
-;;; The selected part must be an n-ary call to function "head".
-;;; The arguments are stored in "reg1" through "regn".
-;;;
-;;; (func-def part head defs reg1 reg2 ... regn)
-;;; The selected part must be an n-ary call to function "head".
-;;; "Defs" is a list of value/register number pairs for default args.
-;;; If a match, assign default values to registers and then skip
-;;; immediately over any following "func-def" instructions and
-;;; the following "func" instruction. If wrong number of arguments,
-;;; proceed to the following "func-def" or "func" instruction.
-;;;
-;;; (func-opt part head defs reg1)
-;;; Like func-def with "n=1", except that if the selected part is
-;;; not a call to "head", then the part itself successfully matches
-;;; "reg1" (and the defaults are assigned).
-;;;
-;;; (try part heads mark reg1 [def])
-;;; The selected part must be a function of the correct type which is
-;;; associative and/or commutative. "Heads" is a list of acceptable
-;;; types. An initial assignment of arguments to "reg1" is tried.
-;;; If the program later fails, it backtracks to this instruction
-;;; and tries other assignments of arguments to "reg1".
-;;; If "def" exists and normal matching fails, backtrack and assign
-;;; "part" to "reg1", and "def" to "reg2" in the following "try2".
-;;; The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
-;;; "mark[0]" points to the argument list; "mark[1]" points to the
-;;; current argument; "mark[2]" is 0 if there are two arguments,
-;;; 1 if reg1 is matching single arguments, 2 if reg2 is matching
-;;; single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
-;;; 3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
-;;; have two arguments, 1 if phase-2 can be skipped, 2 if full
-;;; backtracking is necessary; "mark[4]" is t if the arguments have
-;;; been switched from the order given in the original pattern.
-;;;
-;;; (try2 try reg2)
-;;; Every "try" will be followed by a "try2" whose "try" field is
-;;; a pointer to the corresponding "try". The arguments which were
-;;; not stored in "reg1" by that "try" are now stored in "reg2".
-;;;
-;;; (alt instr nil mark)
-;;; Basic backtracking. Execute the instruction sequence "instr".
-;;; If this fails, back up and execute following the "alt" instruction.
-;;; The "mark" must be the vector "[nil nil 4]". The "instr" sequence
-;;; should execute "end-alt" at the end.
-;;;
-;;; (end-alt ptr)
-;;; Register success of the first alternative of a previous "alt".
-;;; "Ptr" is a pointer to the next instruction following that "alt".
-;;;
-;;; (apply part reg1 reg2)
-;;; The selected part must be a function call. The functor
-;;; (as a variable name) is stored in "reg1"; the arguments
-;;; (as a vector) are stored in "reg2".
-;;;
-;;; (cons part reg1 reg2)
-;;; The selected part must be a nonempty vector. The first element
-;;; of the vector is stored in "reg1"; the rest of the vector
-;;; (as another vector) is stored in "reg2".
-;;;
-;;; (rcons part reg1 reg2)
-;;; The selected part must be a nonempty vector. The last element
-;;; of the vector is stored in "reg2"; the rest of the vector
-;;; (as another vector) is stored in "reg1".
-;;;
-;;; (select part reg)
-;;; If the selected part is a unary call to function "select", its
-;;; argument is stored in "reg"; otherwise (provided this is an `a r'
-;;; and not a `g r' command) the selected part is stored in "reg".
-;;;
-;;; (cond expr)
-;;; The "expr", with registers substituted, must simplify to
-;;; a non-zero value.
-;;;
-;;; (let reg expr)
-;;; Evaluate "expr" and store the result in "reg". Always succeeds.
-;;;
-;;; (done rhs remember)
-;;; Rewrite the expression to "rhs", with register substituted.
-;;; Normalize; if the result is different from the original
-;;; expression, the match has succeeded. This is the last
-;;; instruction of every program. If "remember" is non-nil,
-;;; record the result of the match as a new literal rule.
-
-
-;;; Pseudo-functions related to rewrites:
-;;;
-;;; In patterns: quote, plain, condition, opt, apply, cons, select
-;;;
-;;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
-;;; apply, cons, select
-;;;
-;;; In conditions: let + same as for righthand sides
-
-;;; Some optimizations that would be nice to have:
-;;;
-;;; * Merge registers with disjoint lifetimes.
-;;; * Merge constant registers with equivalent values.
-;;;
-;;; * If an argument of a commutative op math-depends neither on the
-;;; rest of the pattern nor on any of the conditions, then no backtracking
-;;; should be done for that argument. (This won't apply to very many
-;;; cases.)
-;;;
-;;; * If top functor is "select", and its argument is a unique function,
-;;; add the rule to the lists for both "select" and that function.
-;;; (Currently rules like this go on the "nil" list.)
-;;; Same for "func-opt" functions. (Though not urgent for these.)
-;;;
-;;; * Shouldn't evaluate a "let" condition until the end, or until it
-;;; would enable another condition to be evaluated.
-;;;
-
-;;; Some additional features to add / things to think about:
+;; A compiled rule set is an a-list of entries whose cars are functors,
+;; and whose cdrs are lists of rules. If there are rules with no
+;; well-defined head functor, they are included on all lists and also
+;; on an extra list whose car is nil.
+;;
+;; The first entry in the a-list is of the form (schedule A B C ...).
+;;
+;; Rule list entries take the form (regs prog head phases), where:
+;;
+;; regs is a vector of match registers.
+;;
+;; prog is a match program (see below).
+;;
+;; head is a rare function name appearing in the rule body (but not the
+;; head of the whole rule), or nil if none.
+;;
+;; phases is a list of phase numbers for which the rule is enabled.
+;;
+;; A match program is a list of match instructions.
+;;
+;; In the following, "part" is a register number that contains the
+;; subexpression to be operated on.
+;;
+;; Register 0 is the whole expression being matched. The others are
+;; meta-variables in the pattern, temporaries used for matching and
+;; backtracking, and constant expressions.
+;;
+;; (same part reg)
+;; The selected part must be math-equal to the contents of "reg".
+;;
+;; (same-neg part reg)
+;; The selected part must be math-equal to the negative of "reg".
+;;
+;; (copy part reg)
+;; The selected part is copied into "reg". (Rarely used.)
+;;
+;; (copy-neg part reg)
+;; The negative of the selected part is copied into "reg".
+;;
+;; (integer part)
+;; The selected part must be an integer.
+;;
+;; (real part)
+;; The selected part must be a real.
+;;
+;; (constant part)
+;; The selected part must be a constant.
+;;
+;; (negative part)
+;; The selected part must "look" negative.
+;;
+;; (rel part op reg)
+;; The selected part must satisfy "part op reg", where "op"
+;; is one of the 6 relational ops, and "reg" is a register.
+;;
+;; (mod part modulo value)
+;; The selected part must satisfy "part % modulo = value", where
+;; "modulo" and "value" are constants.
+;;
+;; (func part head reg1 reg2 ... regn)
+;; The selected part must be an n-ary call to function "head".
+;; The arguments are stored in "reg1" through "regn".
+;;
+;; (func-def part head defs reg1 reg2 ... regn)
+;; The selected part must be an n-ary call to function "head".
+;; "Defs" is a list of value/register number pairs for default args.
+;; If a match, assign default values to registers and then skip
+;; immediately over any following "func-def" instructions and
+;; the following "func" instruction. If wrong number of arguments,
+;; proceed to the following "func-def" or "func" instruction.
+;;
+;; (func-opt part head defs reg1)
+;; Like func-def with "n=1", except that if the selected part is
+;; not a call to "head", then the part itself successfully matches
+;; "reg1" (and the defaults are assigned).
+;;
+;; (try part heads mark reg1 [def])
+;; The selected part must be a function of the correct type which is
+;; associative and/or commutative. "Heads" is a list of acceptable
+;; types. An initial assignment of arguments to "reg1" is tried.
+;; If the program later fails, it backtracks to this instruction
+;; and tries other assignments of arguments to "reg1".
+;; If "def" exists and normal matching fails, backtrack and assign
+;; "part" to "reg1", and "def" to "reg2" in the following "try2".
+;; The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
+;; "mark[0]" points to the argument list; "mark[1]" points to the
+;; current argument; "mark[2]" is 0 if there are two arguments,
+;; 1 if reg1 is matching single arguments, 2 if reg2 is matching
+;; single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
+;; 3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
+;; have two arguments, 1 if phase-2 can be skipped, 2 if full
+;; backtracking is necessary; "mark[4]" is t if the arguments have
+;; been switched from the order given in the original pattern.
+;;
+;; (try2 try reg2)
+;; Every "try" will be followed by a "try2" whose "try" field is
+;; a pointer to the corresponding "try". The arguments which were
+;; not stored in "reg1" by that "try" are now stored in "reg2".
+;;
+;; (alt instr nil mark)
+;; Basic backtracking. Execute the instruction sequence "instr".
+;; If this fails, back up and execute following the "alt" instruction.
+;; The "mark" must be the vector "[nil nil 4]". The "instr" sequence
+;; should execute "end-alt" at the end.
+;;
+;; (end-alt ptr)
+;; Register success of the first alternative of a previous "alt".
+;; "Ptr" is a pointer to the next instruction following that "alt".
+;;
+;; (apply part reg1 reg2)
+;; The selected part must be a function call. The functor
+;; (as a variable name) is stored in "reg1"; the arguments
+;; (as a vector) are stored in "reg2".
+;;
+;; (cons part reg1 reg2)
+;; The selected part must be a nonempty vector. The first element
+;; of the vector is stored in "reg1"; the rest of the vector
+;; (as another vector) is stored in "reg2".
+;;
+;; (rcons part reg1 reg2)
+;; The selected part must be a nonempty vector. The last element
+;; of the vector is stored in "reg2"; the rest of the vector
+;; (as another vector) is stored in "reg1".
+;;
+;; (select part reg)
+;; If the selected part is a unary call to function "select", its
+;; argument is stored in "reg"; otherwise (provided this is an `a r'
+;; and not a `g r' command) the selected part is stored in "reg".
+;;
+;; (cond expr)
+;; The "expr", with registers substituted, must simplify to
+;; a non-zero value.
+;;
+;; (let reg expr)
+;; Evaluate "expr" and store the result in "reg". Always succeeds.
+;;
+;; (done rhs remember)
+;; Rewrite the expression to "rhs", with register substituted.
+;; Normalize; if the result is different from the original
+;; expression, the match has succeeded. This is the last
+;; instruction of every program. If "remember" is non-nil,
+;; record the result of the match as a new literal rule.
+
+
+;; Pseudo-functions related to rewrites:
+;;
+;; In patterns: quote, plain, condition, opt, apply, cons, select
+;;
+;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
+;; apply, cons, select
+;;
+;; In conditions: let + same as for righthand sides
+
+;; Some optimizations that would be nice to have:
+;;
+;; * Merge registers with disjoint lifetimes.
+;; * Merge constant registers with equivalent values.
+;;
+;; * If an argument of a commutative op math-depends neither on the
+;; rest of the pattern nor on any of the conditions, then no backtracking
+;; should be done for that argument. (This won't apply to very many
+;; cases.)
+;;
+;; * If top functor is "select", and its argument is a unique function,
+;; add the rule to the lists for both "select" and that function.
+;; (Currently rules like this go on the "nil" list.)
+;; Same for "func-opt" functions. (Though not urgent for these.)
+;;
+;; * Shouldn't evaluate a "let" condition until the end, or until it
+;; would enable another condition to be evaluated.
+;;
+
+;; Some additional features to add / things to think about:
;;;
;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)".
;;;
(defvar math-rewrite-whole nil)
(defvar math-make-import-list nil)
+
+;; The variable math-import-list is local to part of math-compile-rewrites,
+;; but is also used in a different part, and so the local version could
+;; be affected by the non-local version when math-compile-rewrites calls itself.
+(defvar math-import-list nil)
+
+;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars,
+;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
+;; math-aliased-vars are local to math-compile-rewrites,
+;; but are used by many functions math-rwcomp-*, which are called by
+;; math-compile-rewrites.
+(defvar math-regs)
+(defvar math-num-regs)
+(defvar math-prog-last)
+(defvar math-bound-vars)
+(defvar math-conds)
+(defvar math-copy-neg)
+(defvar math-rhs)
+(defvar math-pattern)
+(defvar math-remembering)
+(defvar math-aliased-vars)
+
(defun math-compile-rewrites (rules &optional name)
(if (eq (car-safe rules) 'var)
(let ((prop (get (nth 2 rules) 'math-rewrite-cache))
(math-flatten-lands (nth 2 expr)))
(list expr)))
+;; The variables math-rewrite-heads-heads (i.e.; heads for math-rewrite-heads)
+;; math-rewrite-heads-blanks and math-rewrite-heads-skips are local to
+;; math-rewrite-heads, but used by math-rewrite-heads-rec, which is called by
+;; math-rewrite-heads.
+(defvar math-rewrite-heads-heads)
+(defvar math-rewrite-heads-skips)
+(defvar math-rewrite-heads-blanks)
+
(defun math-rewrite-heads (expr &optional more all)
- (let ((heads more)
- (skips (and (not all)
+ (let ((math-rewrite-heads-heads more)
+ (math-rewrite-heads-skips (and (not all)
'(calcFunc-apply calcFunc-condition calcFunc-opt
calcFunc-por calcFunc-pnot)))
- (blanks (and (not all)
+ (math-rewrite-heads-blanks (and (not all)
'(calcFunc-quote calcFunc-plain calcFunc-select
calcFunc-cons calcFunc-rcons
calcFunc-pand))))
(or (Math-primp expr)
(math-rewrite-heads-rec expr))
- heads))
+ math-rewrite-heads-heads))
(defun math-rewrite-heads-rec (expr)
- (or (memq (car expr) skips)
+ (or (memq (car expr) math-rewrite-heads-skips)
(progn
- (or (memq (car expr) heads)
- (memq (car expr) blanks)
+ (or (memq (car expr) math-rewrite-heads-heads)
+ (memq (car expr) math-rewrite-heads-blanks)
(memq 'algebraic (get (car expr) 'math-rewrite-props))
- (setq heads (cons (car expr) heads)))
+ (setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads)))
(while (setq expr (cdr expr))
(or (Math-primp (car expr))
(math-rewrite-heads-rec (car expr)))))))
(list 'neg (list 'calcFunc-register (nth 1 entry)))
(list 'calcFunc-register (nth 1 entry)))))
-(defun math-rwcomp-substitute (expr old new)
- (if (and (eq (car-safe old) 'var)
- (memq (car-safe new) '(var calcFunc-lambda)))
- (let ((old-func (math-var-to-calcFunc old))
- (new-func (math-var-to-calcFunc new)))
+;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new,
+;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func
+;; are local to math-rwcomp-substitute, but are used by
+;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute.
+(defvar math-rwcomp-subst-new)
+(defvar math-rwcomp-subst-old)
+(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)))
(math-rwcomp-subst-rec expr))
- (let ((old-func nil))
+ (let ((math-rwcomp-subst-old-func nil))
(math-rwcomp-subst-rec expr))))
(defun math-rwcomp-subst-rec (expr)
- (cond ((equal expr old) new)
+ (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
((Math-primp expr) expr)
- (t (if (eq (car expr) old-func)
- (math-build-call new-func (mapcar 'math-rwcomp-subst-rec
- (cdr expr)))
+ (t (if (eq (car expr) math-rwcomp-subst-old-func)
+ (math-build-call math-rwcomp-subst-new-func
+ (mapcar 'math-rwcomp-subst-rec
+ (cdr expr)))
(cons (car expr)
(mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
(defun math-rwcomp-assoc-args (expr)
(if (and (eq (car-safe (nth 1 expr)) (car expr))
(= (length (nth 1 expr)) 3))
- (math-rwcomp-assoc-args (nth 1 expr))
- (setq math-args (cons (nth 1 expr) math-args)))
+ (math-rwcomp-assoc-args (nth 1 expr)))
(if (and (eq (car-safe (nth 2 expr)) (car expr))
(= (length (nth 2 expr)) 3))
- (math-rwcomp-assoc-args (nth 2 expr))
- (setq math-args (cons (nth 2 expr) math-args))))
+ (math-rwcomp-assoc-args (nth 2 expr))))
(defun math-rwcomp-addsub-args (expr)
(if (memq (car-safe (nth 1 expr)) '(+ -))
- (math-rwcomp-addsub-args (nth 1 expr))
- (setq math-args (cons (nth 1 expr) math-args)))
+ (math-rwcomp-addsub-args (nth 1 expr)))
(if (eq (car expr) '-)
- (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
+ ()
(if (eq (car-safe (nth 2 expr)) '+)
- (math-rwcomp-addsub-args (nth 2 expr))
- (setq math-args (cons (nth 2 expr) math-args)))))
+ (math-rwcomp-addsub-args (nth 2 expr)))))
(defun math-rwcomp-order (a b)
(< (math-rwcomp-priority (car a))
(math-rwcomp-priority (car b))))
-;;; Order of priority: 0 Constants and other exact matches (first)
-;;; 10 Functions (except below)
-;;; 20 Meta-variables which occur more than once
-;;; 30 Algebraic functions
-;;; 40 Commutative/associative functions
-;;; 50 Meta-variables which occur only once
-;;; +100 for every "!!!" (pnot) in the pattern
-;;; 10000 Optional arguments (last)
+;; Order of priority: 0 Constants and other exact matches (first)
+;; 10 Functions (except below)
+;; 20 Meta-variables which occur more than once
+;; 30 Algebraic functions
+;; 40 Commutative/associative functions
+;; 50 Meta-variables which occur only once
+;; +100 for every "!!!" (pnot) in the pattern
+;; 10000 Optional arguments (last)
(defun math-rwcomp-priority (expr)
(+ (math-rwcomp-count-pnots expr)
(setq count (+ count (math-rwcomp-count-pnots (car expr)))))
count))))
-;;; In the current implementation, all associative functions must
-;;; also be commutative.
+;; In the current implementation, all associative functions must
+;; also be commutative.
(put '+ 'math-rewrite-props '(algebraic assoc commut))
(put '- 'math-rewrite-props '(algebraic assoc commut)) ; see below
(put 'calcFunc-vint 'math-rewrite-props '(assoc commut))
(put 'calcFunc-vxor 'math-rewrite-props '(assoc commut))
-;;; Note: "*" is not commutative for matrix args, but we pretend it is.
-;;; Also, "-" is not commutative but the code tweaks things so that it is.
+;; Note: "*" is not commutative for matrix args, but we pretend it is.
+;; Also, "-" is not commutative but the code tweaks things so that it is.
(put '+ 'math-rewrite-default 0)
(put '- 'math-rewrite-default 0)
'btrack)
''((backtrack)))))
-;;; This monstrosity is necessary because the use of static vectors of
-;;; registers makes rewrite rules non-reentrant. Yucko!
+;; This monstrosity is necessary because the use of static vectors of
+;; registers makes rewrite rules non-reentrant. Yucko!
(defmacro math-rweval (form)
(list 'let '((orig (car rules)))
'(setcar rules (quote (nil nil nil no-phase)))
form
'(setcar rules orig))))
-(setq math-rewrite-phase 1)
+(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.
+(defvar math-apply-rw-regs)
-(defun math-apply-rewrites (expr rules &optional heads ruleset)
+;; The variable math-apply-rw-ruleset is local to math-apply-rewrites,
+;; but is used by math-rwapply-remember.
+(defvar math-apply-rw-ruleset)
+
+(defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
(and
(setq rules (cdr (or (assq (car-safe expr) rules)
(assq nil rules))))
(let ((result nil)
- op regs inst part pc mark btrack
+ op math-apply-rw-regs inst part pc mark btrack
(tracing math-rwcomp-tracing)
(phase math-rewrite-phase))
(while rules
(and (setq part (nth 3 (car rules)))
(not (memq phase part)))
(progn
- (setq regs (car (car rules))
+ (setq math-apply-rw-regs (car (car rules))
pc (nth 1 (car rules))
btrack nil)
- (aset regs 0 expr)
+ (aset math-apply-rw-regs 0 expr)
(while pc
(and tracing
(progn (terpri) (princ (car pc))
(if (and (natnump (nth 1 (car pc)))
- (< (nth 1 (car pc)) (length regs)))
- (princ (format "\n part = %s"
- (aref regs (nth 1 (car pc))))))))
+ (< (nth 1 (car pc)) (length math-apply-rw-regs)))
+ (princ
+ (format "\n part = %s"
+ (aref math-apply-rw-regs (nth 1 (car pc))))))))
(cond ((eq (setq op (car (setq inst (car pc)))) 'func)
- (if (and (consp (setq part (aref regs (car (cdr inst)))))
+ (if (and (consp
+ (setq part (aref math-apply-rw-regs (car (cdr inst)))))
(eq (car part)
(car (setq inst (cdr (cdr inst)))))
(progn
(while (and (setq inst (cdr inst)
part (cdr part))
inst)
- (aset regs (car inst) (car part)))
+ (aset math-apply-rw-regs (car inst) (car part)))
(not (or inst part))))
(setq pc (cdr pc))
(math-rwfail)))
((eq op 'same)
- (if (or (equal (setq part (aref regs (nth 1 inst)))
- (setq mark (aref regs (nth 2 inst))))
+ (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
+ (setq mark (aref math-apply-rw-regs (nth 2 inst))))
(Math-equal part mark))
(setq pc (cdr pc))
(math-rwfail)))
calc-matrix-mode
(not (eq calc-matrix-mode 'scalar))
(eq (car (nth 2 inst)) '*)
- (consp (setq part (aref regs (car (cdr inst)))))
+ (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
(eq (car part) '*)
(not (math-known-scalarp part)))
(setq mark (nth 3 inst)
pc (cdr pc))
(if (aref mark 4)
(progn
- (aset regs (nth 4 inst) (nth 2 part))
+ (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
(aset mark 1 (cdr (cdr part))))
- (aset regs (nth 4 inst) (nth 1 part))
+ (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
(aset mark 1 (cdr part)))
(aset mark 0 (cdr part))
(aset mark 2 0))
((eq op 'try)
- (if (and (consp (setq part (aref regs (car (cdr inst)))))
+ (if (and (consp (setq part
+ (aref math-apply-rw-regs (car (cdr inst)))))
(memq (car part) (nth 2 inst))
(= (length part) 3)
(or (not (eq (car part) '/))
op))
btrack (cons pc btrack)
pc (cdr pc))
- (aset regs (nth 2 inst) (car op))
+ (aset math-apply-rw-regs (nth 2 inst) (car op))
(aset mark 0 op)
(aset mark 1 op)
(aset mark 2 (if (cdr (cdr op)) 1 0)))
(progn
(setq mark (nth 3 inst)
pc (cdr pc))
- (aset regs (nth 4 inst) (nth 1 part))
+ (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
(aset mark 1 -1)
(aset mark 2 4))
(setq mark (nth 3 inst)
pc (cdr pc))
- (aset regs (nth 4 inst) part)
+ (aset math-apply-rw-regs (nth 4 inst) part)
(aset mark 2 3))
(math-rwfail))))
mark (nth 3 part)
op (aref mark 2)
pc (cdr pc))
- (aset regs (nth 2 inst)
+ (aset math-apply-rw-regs (nth 2 inst)
(cond
((eq op 0)
(if (eq (aref mark 0) (aref mark 1))
((eq op 'select)
(setq pc (cdr pc))
- (if (and (consp (setq part (aref regs (nth 1 inst))))
+ (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
(eq (car part) 'calcFunc-select))
- (aset regs (nth 2 inst) (nth 1 part))
+ (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
(if math-rewrite-selections
(math-rwfail)
- (aset regs (nth 2 inst) part))))
+ (aset math-apply-rw-regs (nth 2 inst) part))))
((eq op 'same-neg)
- (if (or (equal (setq part (aref regs (nth 1 inst)))
+ (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
(setq mark (math-neg
- (aref regs (nth 2 inst)))))
+ (aref math-apply-rw-regs (nth 2 inst)))))
(Math-equal part mark))
(setq pc (cdr pc))
(math-rwfail)))
op (aref mark 2))
(cond ((eq op 0)
(if (setq op (cdr (aref mark 1)))
- (aset regs (nth 4 inst) (car (aset mark 1 op)))
+ (aset math-apply-rw-regs (nth 4 inst)
+ (car (aset mark 1 op)))
(if (nth 5 inst)
(progn
(aset mark 2 3)
- (aset regs (nth 4 inst)
- (aref regs (nth 1 inst))))
+ (aset math-apply-rw-regs (nth 4 inst)
+ (aref math-apply-rw-regs (nth 1 inst))))
(math-rwfail t))))
((eq op 1)
(if (setq op (cdr (aref mark 1)))
- (aset regs (nth 4 inst) (car (aset mark 1 op)))
+ (aset math-apply-rw-regs (nth 4 inst)
+ (car (aset mark 1 op)))
(if (= (aref mark 3) 1)
(if (nth 5 inst)
(progn
(aset mark 2 3)
- (aset regs (nth 4 inst)
- (aref regs (nth 1 inst))))
+ (aset math-apply-rw-regs (nth 4 inst)
+ (aref math-apply-rw-regs (nth 1 inst))))
(math-rwfail t))
(aset mark 2 2)
(aset mark 1 (cons nil (aref mark 0)))
(list '- part
(nth 1 (car mark)))
(list op part (car mark))))))
- (aset regs (nth 4 inst) part))
+ (aset math-apply-rw-regs (nth 4 inst) part))
(if (nth 5 inst)
(progn
(aset mark 2 3)
- (aset regs (nth 4 inst)
- (aref regs (nth 1 inst))))
+ (aset math-apply-rw-regs (nth 4 inst)
+ (aref math-apply-rw-regs (nth 1 inst))))
(math-rwfail t))))
((eq op 4)
(setq btrack (cdr btrack)))
(t (math-rwfail t))))
((eq op 'integer)
- (if (Math-integerp (setq part (aref regs (nth 1 inst))))
+ (if (Math-integerp (setq part
+ (aref math-apply-rw-regs (nth 1 inst))))
(setq pc (cdr pc))
(if (Math-primp part)
(math-rwfail)
(math-rwfail)))))
((eq op 'real)
- (if (Math-realp (setq part (aref regs (nth 1 inst))))
+ (if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst))))
(setq pc (cdr pc))
(if (Math-primp part)
(math-rwfail)
(math-rwfail)))))
((eq op 'constant)
- (if (math-constp (setq part (aref regs (nth 1 inst))))
+ (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
(setq pc (cdr pc))
(if (Math-primp part)
(math-rwfail)
(math-rwfail)))))
((eq op 'negative)
- (if (math-looks-negp (setq part (aref regs (nth 1 inst))))
+ (if (math-looks-negp (setq part
+ (aref math-apply-rw-regs (nth 1 inst))))
(setq pc (cdr pc))
(if (Math-primp part)
(math-rwfail)
(math-rwfail)))))
((eq op 'rel)
- (setq part (math-compare (aref regs (nth 1 inst))
- (aref regs (nth 3 inst)))
+ (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
+ (aref math-apply-rw-regs (nth 3 inst)))
op (nth 2 inst))
(if (= part 2)
(setq part (math-rweval
(math-simplify
(calcFunc-sign
- (math-sub (aref regs (nth 1 inst))
- (aref regs (nth 3 inst))))))))
+ (math-sub
+ (aref math-apply-rw-regs (nth 1 inst))
+ (aref math-apply-rw-regs (nth 3 inst))))))))
(if (cond ((eq op 'calcFunc-eq)
(eq part 0))
((eq op 'calcFunc-neq)
(math-rwfail)))
((eq op 'func-def)
- (if (and (consp (setq part (aref regs (car (cdr inst)))))
- (eq (car part)
- (car (setq inst (cdr (cdr inst))))))
+ (if (and
+ (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
+ (eq (car part)
+ (car (setq inst (cdr (cdr inst))))))
(progn
(setq inst (cdr inst)
mark (car inst))
(while (and (setq inst (cdr inst)
part (cdr part))
inst)
- (aset regs (car inst) (car part)))
+ (aset math-apply-rw-regs (car inst) (car part)))
(if (or inst part)
(setq pc (cdr pc))
(while (eq (car (car (setq pc (cdr pc))))
'func-def))
(setq pc (cdr pc)) ; skip over "func"
(while mark
- (aset regs (cdr (car mark)) (car (car mark)))
+ (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
(setq mark (cdr mark)))))
(math-rwfail)))
((eq op 'func-opt)
- (if (or (not (and (consp
- (setq part (aref regs (car (cdr inst)))))
- (eq (car part) (nth 2 inst))))
+ (if (or (not
+ (and
+ (consp
+ (setq part (aref math-apply-rw-regs (car (cdr inst)))))
+ (eq (car part) (nth 2 inst))))
(and (= (length part) 2)
(setq part (nth 1 part))))
(progn
(setq mark (nth 3 inst))
- (aset regs (nth 4 inst) part)
+ (aset math-apply-rw-regs (nth 4 inst) part)
(while (eq (car (car (setq pc (cdr pc)))) 'func-def))
(setq pc (cdr pc)) ; skip over "func"
(while mark
- (aset regs (cdr (car mark)) (car (car mark)))
+ (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
(setq mark (cdr mark))))
(setq pc (cdr pc))))
((eq op 'mod)
- (if (if (Math-zerop (setq part (aref regs (nth 1 inst))))
+ (if (if (Math-zerop
+ (setq part (aref math-apply-rw-regs (nth 1 inst))))
(Math-zerop (nth 3 inst))
(and (not (Math-zerop (nth 2 inst)))
(progn
(math-rwfail)))
((eq op 'apply)
- (if (and (consp (setq part (aref regs (car (cdr inst)))))
+ (if (and (consp
+ (setq part (aref math-apply-rw-regs (car (cdr inst)))))
(not (Math-objvecp part))
(not (eq (car part) 'var)))
(progn
- (aset regs (nth 2 inst)
+ (aset math-apply-rw-regs (nth 2 inst)
(math-calcFunc-to-var (car part)))
- (aset regs (nth 3 inst)
+ (aset math-apply-rw-regs (nth 3 inst)
(cons 'vec (cdr part)))
(setq pc (cdr pc)))
(math-rwfail)))
((eq op 'cons)
- (if (and (consp (setq part (aref regs (car (cdr inst)))))
+ (if (and (consp
+ (setq part (aref math-apply-rw-regs (car (cdr inst)))))
(eq (car part) 'vec)
(cdr part))
(progn
- (aset regs (nth 2 inst) (nth 1 part))
- (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part))))
+ (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
+ (aset math-apply-rw-regs (nth 3 inst)
+ (cons 'vec (cdr (cdr part))))
(setq pc (cdr pc)))
(math-rwfail)))
((eq op 'rcons)
- (if (and (consp (setq part (aref regs (car (cdr inst)))))
+ (if (and (consp
+ (setq part (aref math-apply-rw-regs (car (cdr inst)))))
(eq (car part) 'vec)
(cdr part))
(progn
- (aset regs (nth 2 inst) (calcFunc-rhead part))
- (aset regs (nth 3 inst) (calcFunc-rtail part))
+ (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
+ (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
(setq pc (cdr pc)))
(math-rwfail)))
(math-rwfail)))
((eq op 'let)
- (aset regs (nth 1 inst)
+ (aset math-apply-rw-regs (nth 1 inst)
(math-rweval
(math-normalize
(math-rwapply-replace-regs (nth 2 inst)))))
(setq pc (cdr pc)))
((eq op 'copy)
- (aset regs (nth 2 inst) (aref regs (nth 1 inst)))
+ (aset math-apply-rw-regs (nth 2 inst)
+ (aref math-apply-rw-regs (nth 1 inst)))
(setq pc (cdr pc)))
((eq op 'copy-neg)
- (aset regs (nth 2 inst)
- (math-rwapply-neg (aref regs (nth 1 inst))))
+ (aset math-apply-rw-regs (nth 2 inst)
+ (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
(setq pc (cdr pc)))
((eq op 'alt)
(cond ((Math-primp expr)
expr)
((eq (car expr) 'calcFunc-register)
- (setq expr (aref regs (nth 1 expr)))
+ (setq expr (aref math-apply-rw-regs (nth 1 expr)))
(if (eq (car-safe expr) '*)
(if (eq (nth 1 expr) -1)
(math-neg (nth 2 expr))
(math-rwapply-reg-neg (nth 1 expr)))
((and (eq (car expr) 'neg)
(eq (car-safe (nth 1 expr)) 'calcFunc-register)
- (math-scalarp (aref regs (nth 1 (nth 1 expr)))))
+ (math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr)))))
(math-neg (math-rwapply-replace-regs (nth 1 expr))))
((and (eq (car expr) '+)
(math-rwapply-reg-looks-negp (nth 1 expr)))
(if (Math-primp (nth 1 expr))
(nth 1 expr)
(if (eq (car (nth 1 expr)) 'calcFunc-register)
- (aref regs (nth 1 (nth 1 expr)))
+ (aref math-apply-rw-regs (nth 1 (nth 1 expr)))
(cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
(cdr (nth 1 expr)))))))
(t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
(defun math-rwapply-reg-looks-negp (expr)
(if (eq (car-safe expr) 'calcFunc-register)
- (math-looks-negp (aref regs (nth 1 expr)))
+ (math-looks-negp (aref math-apply-rw-regs (nth 1 expr)))
(if (memq (car-safe expr) '(* /))
(or (math-rwapply-reg-looks-negp (nth 1 expr))
(math-rwapply-reg-looks-negp (nth 2 expr))))))
(math-rwapply-reg-neg (nth 2 expr)))))))
(defun math-rwapply-remember (old new)
- (let ((varval (symbol-value (nth 2 (car ruleset))))
- (rules (assq (car-safe old) ruleset)))
+ (let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset))))
+ (rules (assq (car-safe old) math-apply-rw-ruleset)))
(if (and (eq (car-safe varval) 'vec)
(not (memq (car-safe old) '(nil schedule + -)))
rules)
nil nil)
(cdr rules)))))))
-;;; arch-tag: ca8d7b7d-bff1-4535-90f3-e2241f5e786b
+(provide 'calc-rewr)
+
+;; arch-tag: ca8d7b7d-bff1-4535-90f3-e2241f5e786b
;;; calc-rewr.el ends here
HCoop / bpt / emacs.git / blobdiff