lisp/calc/calc-rewr.el

   1 ;;; calc-rewr.el --- rewriting functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: David Gillespie <daveg@synaptics.com>
   7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 ;; This file is autoloaded from calc-ext.el.
  29
  30 (require 'calc-ext)
  31 (require 'calc-macs)
  32
  33 (defvar math-rewrite-default-iters 100)
  34
  35 ;; The variable calc-rewr-sel is local to calc-rewrite-selection and
  36 ;; calc-rewrite, but is used by calc-locate-selection-marker.
  37 (defvar calc-rewr-sel)
  38
  39 (defun calc-rewrite-selection (rules-str &optional many prefix)
  40   (interactive "sRewrite rule(s): \np")
  41   (calc-slow-wrapper
  42    (calc-preserve-point)
  43    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  44           (reselect t)
  45           (pop-rules nil)
  46           rules
  47           (entry (calc-top num 'entry))
  48           (expr (car entry))
  49           (calc-rewr-sel (calc-auto-selection entry))
  50           (math-rewrite-selections t)
  51           (math-rewrite-default-iters 1))
  52      (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
  53          (if (= num 1)
  54              (error "Can't use same stack entry for formula and rules")
  55            (setq rules (calc-top-n 1 t)
  56                  pop-rules t))
  57        (setq rules (if (stringp rules-str)
  58                        (math-read-exprs rules-str) rules-str))
  59        (if (eq (car-safe rules) 'error)
  60            (error "Bad format in expression: %s" (nth 1 rules)))
  61        (if (= (length rules) 1)
  62            (setq rules (car rules))
  63          (setq rules (cons 'vec rules)))
  64        (or (memq (car-safe rules) '(vec var calcFunc-assign
  65                                         calcFunc-condition))
  66            (let ((rhs (math-read-expr
  67                        (read-string (concat "Rewrite from:    " rules-str
  68                                             "  to: ")))))
  69              (if (eq (car-safe rhs) 'error)
  70                  (error "Bad format in expression: %s" (nth 1 rhs)))
  71              (setq rules (list 'calcFunc-assign rules rhs))))
  72        (or (eq (car-safe rules) 'var)
  73            (calc-record rules "rule")))
  74      (if (eq many 0)
  75          (setq many '(var inf var-inf))
  76        (if many (setq many (prefix-numeric-value many))))
  77      (if calc-rewr-sel
  78          (setq expr (calc-replace-sub-formula (car entry)
  79                                               calc-rewr-sel
  80                                               (list 'calcFunc-select calc-rewr-sel)))
  81        (setq expr (car entry)
  82              reselect nil
  83              math-rewrite-selections nil))
  84      (setq expr (calc-encase-atoms
  85                  (calc-normalize
  86                   (math-rewrite
  87                    (calc-normalize expr)
  88                    rules many)))
  89            calc-rewr-sel nil
  90            expr (calc-locate-select-marker expr))
  91      (or (consp calc-rewr-sel) (setq calc-rewr-sel nil))
  92      (if pop-rules (calc-pop-stack 1))
  93      (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
  94                                 (- num (if pop-rules 1 0))
  95                                 (list (and reselect calc-rewr-sel))))
  96    (calc-handle-whys)))
  97
  98 (defun calc-locate-select-marker (expr)
  99   (if (Math-primp expr)
 100       expr
 101     (if (and (eq (car expr) 'calcFunc-select)
 102              (= (length expr) 2))
 103         (progn
 104           (setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr)))
 105           (nth 1 expr))
 106       (cons (car expr)
 107             (mapcar 'calc-locate-select-marker (cdr expr))))))
 108
 109
 110
 111 (defun calc-rewrite (rules-str many)
 112   (interactive "sRewrite rule(s): \nP")
 113   (calc-slow-wrapper
 114    (let (n rules expr)
 115      (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
 116          (setq expr (calc-top-n 2)
 117                rules (calc-top-n 1 t)
 118                n 2)
 119        (setq rules (if (stringp rules-str)
 120                        (math-read-exprs rules-str) rules-str))
 121        (if (eq (car-safe rules) 'error)
 122            (error "Bad format in expression: %s" (nth 1 rules)))
 123        (if (= (length rules) 1)
 124            (setq rules (car rules))
 125          (setq rules (cons 'vec rules)))
 126        (or (memq (car-safe rules) '(vec var calcFunc-assign
 127                                         calcFunc-condition))
 128            (let ((rhs (math-read-expr
 129                        (read-string (concat "Rewrite from:    " rules-str
 130                                             " to: ")))))
 131              (if (eq (car-safe rhs) 'error)
 132                  (error "Bad format in expression: %s" (nth 1 rhs)))
 133              (setq rules (list 'calcFunc-assign rules rhs))))
 134        (or (eq (car-safe rules) 'var)
 135            (calc-record rules "rule"))
 136        (setq expr (calc-top-n 1)
 137              n 1))
 138      (if (eq many 0)
 139          (setq many '(var inf var-inf))
 140        (if many (setq many (prefix-numeric-value many))))
 141      (setq expr (calc-normalize (math-rewrite expr rules many)))
 142      (let (calc-rewr-sel)
 143        (setq expr (calc-locate-select-marker expr)))
 144      (calc-pop-push-record-list n "rwrt" (list expr)))
 145    (calc-handle-whys)))
 146
 147 (defun calc-match (pat &optional interactive)
 148   (interactive "sPattern: \np")
 149   (calc-slow-wrapper
 150    (let (n expr)
 151      (if (or (null pat) (equal pat "") (equal pat "$"))
 152          (setq expr (calc-top-n 2)
 153                pat (calc-top-n 1)
 154                n 2)
 155        (setq pat (if (stringp pat) (math-read-expr pat) pat))
 156        (if (eq (car-safe pat) 'error)
 157            (error "Bad format in expression: %s" (nth 1 pat)))
 158        (if (not (eq (car-safe pat) 'var))
 159            (calc-record pat "pat"))
 160        (setq expr (calc-top-n 1)
 161              n 1))
 162      (or (math-vectorp expr) (error "Argument must be a vector"))
 163      (if (calc-is-inverse)
 164          (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
 165        (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
 166
 167
 168 (defvar math-mt-many)
 169
 170 ;; The variable math-rewrite-whole-expr is local to math-rewrite,
 171 ;; but is used by math-rewrite-phase
 172 (defvar math-rewrite-whole-expr)
 173
 174 (defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
 175   (let* ((crules (math-compile-rewrites rules))
 176          (heads (math-rewrite-heads math-rewrite-whole-expr))
 177          (trace-buffer (get-buffer "*Trace*"))
 178          (calc-display-just 'center)
 179          (calc-display-origin 39)
 180          (calc-line-breaking 78)
 181          (calc-line-numbering nil)
 182          (calc-show-selections t)
 183          (calc-why nil)
 184          (math-mt-func (function
 185                         (lambda (x)
 186                           (let ((result (math-apply-rewrites x (cdr crules)
 187                                                              heads crules)))
 188                             (if result
 189                                 (progn
 190                                   (if trace-buffer
 191                                       (let ((fmt (math-format-stack-value
 192                                                   (list result nil nil))))
 193                                         (with-current-buffer trace-buffer
 194                                           (insert "\nrewrite to\n" fmt "\n"))))
 195                                   (setq heads (math-rewrite-heads result heads t))))
 196                             result)))))
 197     (if trace-buffer
 198         (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
 199           (with-current-buffer trace-buffer
 200             (setq truncate-lines t)
 201             (goto-char (point-max))
 202             (insert "\n\nBegin rewriting\n" fmt "\n"))))
 203     (or math-mt-many (setq math-mt-many (or (nth 1 (car crules))
 204                                     math-rewrite-default-iters)))
 205     (if (equal math-mt-many '(var inf var-inf)) (setq math-mt-many 1000000))
 206     (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
 207     (math-rewrite-phase (nth 3 (car crules)))
 208     (if trace-buffer
 209         (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
 210           (with-current-buffer trace-buffer
 211             (insert "\nDone rewriting"
 212                     (if (= math-mt-many 0) " (reached iteration limit)" "")
 213                     ":\n" fmt "\n"))))
 214     math-rewrite-whole-expr))
 215
 216 (defun math-rewrite-phase (sched)
 217   (while (and sched (/= math-mt-many 0))
 218     (if (listp (car sched))
 219         (while (let ((save-expr math-rewrite-whole-expr))
 220                  (math-rewrite-phase (car sched))
 221                  (not (equal math-rewrite-whole-expr save-expr))))
 222       (if (symbolp (car sched))
 223           (progn
 224             (setq math-rewrite-whole-expr
 225                   (math-normalize (list (car sched) math-rewrite-whole-expr)))
 226             (if trace-buffer
 227                 (let ((fmt (math-format-stack-value
 228                             (list math-rewrite-whole-expr nil nil))))
 229                   (with-current-buffer trace-buffer
 230                     (insert "\ncall "
 231                             (substring (symbol-name (car sched)) 9)
 232                             ":\n" fmt "\n")))))
 233         (let ((math-rewrite-phase (car sched)))
 234           (if trace-buffer
 235               (with-current-buffer trace-buffer
 236                 (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
 237           (while (let ((save-expr math-rewrite-whole-expr))
 238                    (setq math-rewrite-whole-expr (math-normalize
 239                                      (math-map-tree-rec math-rewrite-whole-expr)))
 240                    (not (equal math-rewrite-whole-expr save-expr)))))))
 241     (setq sched (cdr sched))))
 242
 243 (defun calcFunc-rewrite (expr rules &optional many)
 244   (or (null many) (integerp many)
 245       (equal many '(var inf var-inf)) (equal many '(neg (var inf var-inf)))
 246       (math-reject-arg many 'fixnump))
 247   (condition-case err
 248       (math-rewrite expr rules (or many 1))
 249     (error (math-reject-arg rules (nth 1 err)))))
 250
 251 (defun calcFunc-match (pat vec)
 252   (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
 253   (condition-case err
 254       (math-match-patterns pat vec nil)
 255     (error (math-reject-arg pat (nth 1 err)))))
 256
 257 (defun calcFunc-matchnot (pat vec)
 258   (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
 259   (condition-case err
 260       (math-match-patterns pat vec t)
 261     (error (math-reject-arg pat (nth 1 err)))))
 262
 263 (defun math-match-patterns (pat vec &optional not-flag)
 264   (let ((newvec nil)
 265         (crules (math-compile-patterns pat)))
 266     (while (setq vec (cdr vec))
 267       (if (eq (not (math-apply-rewrites (car vec) crules))
 268               not-flag)
 269           (setq newvec (cons (car vec) newvec))))
 270     (cons 'vec (nreverse newvec))))
 271
 272 (defun calcFunc-matches (expr pat)
 273   (condition-case err
 274       (if (math-apply-rewrites expr (math-compile-patterns pat))
 275           1
 276         0)
 277     (error (math-reject-arg pat (nth 1 err)))))
 278
 279 (defun calcFunc-vmatches (expr pat)
 280   (condition-case err
 281       (or (math-apply-rewrites expr (math-compile-patterns pat))
 282           0)
 283     (error (math-reject-arg pat (nth 1 err)))))
 284
 285
 286
 287 ;; A compiled rule set is an a-list of entries whose cars are functors,
 288 ;; and whose cdrs are lists of rules.  If there are rules with no
 289 ;; well-defined head functor, they are included on all lists and also
 290 ;; on an extra list whose car is nil.
 291 ;;
 292 ;; The first entry in the a-list is of the form (schedule A B C ...).
 293 ;;
 294 ;; Rule list entries take the form (regs prog head phases), where:
 295 ;;
 296 ;;   regs   is a vector of match registers.
 297 ;;
 298 ;;   prog   is a match program (see below).
 299 ;;
 300 ;;   head   is a rare function name appearing in the rule body (but not the
 301 ;;           head of the whole rule), or nil if none.
 302 ;;
 303 ;;   phases is a list of phase numbers for which the rule is enabled.
 304 ;;
 305 ;; A match program is a list of match instructions.
 306 ;;
 307 ;; In the following, "part" is a register number that contains the
 308 ;; subexpression to be operated on.
 309 ;;
 310 ;; Register 0 is the whole expression being matched.  The others are
 311 ;; meta-variables in the pattern, temporaries used for matching and
 312 ;; backtracking, and constant expressions.
 313 ;;
 314 ;; (same part reg)
 315 ;;         The selected part must be math-equal to the contents of "reg".
 316 ;;
 317 ;; (same-neg part reg)
 318 ;;         The selected part must be math-equal to the negative of "reg".
 319 ;;
 320 ;; (copy part reg)
 321 ;;          The selected part is copied into "reg".  (Rarely used.)
 322 ;;
 323 ;; (copy-neg part reg)
 324 ;;          The negative of the selected part is copied into "reg".
 325 ;;
 326 ;; (integer part)
 327 ;;         The selected part must be an integer.
 328 ;;
 329 ;; (real part)
 330 ;;         The selected part must be a real.
 331 ;;
 332 ;; (constant part)
 333 ;;         The selected part must be a constant.
 334 ;;
 335 ;; (negative part)
 336 ;;          The selected part must "look" negative.
 337 ;;
 338 ;; (rel part op reg)
 339 ;;         The selected part must satisfy "part op reg", where "op"
 340 ;;          is one of the 6 relational ops, and "reg" is a register.
 341 ;;
 342 ;; (mod part modulo value)
 343 ;;         The selected part must satisfy "part % modulo = value", where
 344 ;;         "modulo" and "value" are constants.
 345 ;;
 346 ;; (func part head reg1 reg2 ... regn)
 347 ;;         The selected part must be an n-ary call to function "head".
 348 ;;         The arguments are stored in "reg1" through "regn".
 349 ;;
 350 ;; (func-def part head defs reg1 reg2 ... regn)
 351 ;;          The selected part must be an n-ary call to function "head".
 352 ;;          "Defs" is a list of value/register number pairs for default args.
 353 ;;          If a match, assign default values to registers and then skip
 354 ;;          immediately over any following "func-def" instructions and
 355 ;;          the following "func" instruction.  If wrong number of arguments,
 356 ;;          proceed to the following "func-def" or "func" instruction.
 357 ;;
 358 ;; (func-opt part head defs reg1)
 359 ;;          Like func-def with "n=1", except that if the selected part is
 360 ;;          not a call to "head", then the part itself successfully matches
 361 ;;          "reg1" (and the defaults are assigned).
 362 ;;
 363 ;; (try part heads mark reg1 [def])
 364 ;;         The selected part must be a function of the correct type which is
 365 ;;         associative and/or commutative.  "Heads" is a list of acceptable
 366 ;;         types.  An initial assignment of arguments to "reg1" is tried.
 367 ;;          If the program later fails, it backtracks to this instruction
 368 ;;          and tries other assignments of arguments to "reg1".
 369 ;;          If "def" exists and normal matching fails, backtrack and assign
 370 ;;          "part" to "reg1", and "def" to "reg2" in the following "try2".
 371 ;;          The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
 372 ;;          "mark[0]" points to the argument list; "mark[1]" points to the
 373 ;;          current argument; "mark[2]" is 0 if there are two arguments,
 374 ;;          1 if reg1 is matching single arguments, 2 if reg2 is matching
 375 ;;          single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
 376 ;;         3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
 377 ;;          have two arguments, 1 if phase-2 can be skipped, 2 if full
 378 ;;          backtracking is necessary; "mark[4]" is t if the arguments have
 379 ;;          been switched from the order given in the original pattern.
 380 ;;
 381 ;; (try2 try reg2)
 382 ;;         Every "try" will be followed by a "try2" whose "try" field is
 383 ;;          a pointer to the corresponding "try".  The arguments which were
 384 ;;          not stored in "reg1" by that "try" are now stored in "reg2".
 385 ;;
 386 ;; (alt instr nil mark)
 387 ;;          Basic backtracking.  Execute the instruction sequence "instr".
 388 ;;          If this fails, back up and execute following the "alt" instruction.
 389 ;;          The "mark" must be the vector "[nil nil 4]".  The "instr" sequence
 390 ;;          should execute "end-alt" at the end.
 391 ;;
 392 ;; (end-alt ptr)
 393 ;;          Register success of the first alternative of a previous "alt".
 394 ;;          "Ptr" is a pointer to the next instruction following that "alt".
 395 ;;
 396 ;; (apply part reg1 reg2)
 397 ;;         The selected part must be a function call.  The functor
 398 ;;          (as a variable name) is stored in "reg1"; the arguments
 399 ;;          (as a vector) are stored in "reg2".
 400 ;;
 401 ;; (cons part reg1 reg2)
 402 ;;          The selected part must be a nonempty vector.  The first element
 403 ;;          of the vector is stored in "reg1"; the rest of the vector
 404 ;;          (as another vector) is stored in "reg2".
 405 ;;
 406 ;; (rcons part reg1 reg2)
 407 ;;          The selected part must be a nonempty vector.  The last element
 408 ;;          of the vector is stored in "reg2"; the rest of the vector
 409 ;;          (as another vector) is stored in "reg1".
 410 ;;
 411 ;; (select part reg)
 412 ;;         If the selected part is a unary call to function "select", its
 413 ;;         argument is stored in "reg"; otherwise (provided this is an `a r'
 414 ;;         and not a `g r' command) the selected part is stored in "reg".
 415 ;;
 416 ;; (cond expr)
 417 ;;         The "expr", with registers substituted, must simplify to
 418 ;;         a non-zero value.
 419 ;;
 420 ;; (let reg expr)
 421 ;;         Evaluate "expr" and store the result in "reg".  Always succeeds.
 422 ;;
 423 ;; (done rhs remember)
 424 ;;         Rewrite the expression to "rhs", with register substituted.
 425 ;;          Normalize; if the result is different from the original
 426 ;;          expression, the match has succeeded.  This is the last
 427 ;;          instruction of every program.  If "remember" is non-nil,
 428 ;;         record the result of the match as a new literal rule.
 429
 430
 431 ;; Pseudo-functions related to rewrites:
 432 ;;
 433 ;;  In patterns:  quote, plain, condition, opt, apply, cons, select
 434 ;;
 435 ;;  In righthand sides:  quote, plain, eval, evalsimp, evalextsimp,
 436 ;;                       apply, cons, select
 437 ;;
 438 ;;  In conditions:  let + same as for righthand sides
 439
 440 ;; Some optimizations that would be nice to have:
 441 ;;
 442 ;;  * Merge registers with disjoint lifetimes.
 443 ;;  * Merge constant registers with equivalent values.
 444 ;;
 445 ;;  * If an argument of a commutative op math-depends neither on the
 446 ;;    rest of the pattern nor on any of the conditions, then no backtracking
 447 ;;    should be done for that argument.  (This won't apply to very many
 448 ;;    cases.)
 449 ;;
 450 ;;  * If top functor is "select", and its argument is a unique function,
 451 ;;    add the rule to the lists for both "select" and that function.
 452 ;;    (Currently rules like this go on the "nil" list.)
 453 ;;    Same for "func-opt" functions.  (Though not urgent for these.)
 454 ;;
 455 ;;  * Shouldn't evaluate a "let" condition until the end, or until it
 456 ;;    would enable another condition to be evaluated.
 457 ;;
 458
 459 ;; Some additional features to add / things to think about:
 460 ;;;
 461 ;;;  * Figure out what happens to "a +/- b" and "a +/- opt(b)".
 462 ;;;
 463 ;;;  * Same for interval forms.
 464 ;;;
 465 ;;;  * Have a name(v,pat) pattern which matches pat, and gives the
 466 ;;;    whole match the name v.  Beware of circular structures!
 467 ;;;
 468
 469 (defun math-compile-patterns (pats)
 470   (if (and (eq (car-safe pats) 'var)
 471            (calc-var-value (nth 2 pats)))
 472       (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
 473         (or prop
 474             (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
 475         (or (eq (car prop) (symbol-value (nth 2 pats)))
 476             (progn
 477               (setcdr prop (math-compile-patterns
 478                             (symbol-value (nth 2 pats))))
 479               (setcar prop (symbol-value (nth 2 pats)))))
 480         (cdr prop))
 481     (let ((math-rewrite-whole t))
 482       (cdr (math-compile-rewrites (cons
 483                                    'vec
 484                                    (mapcar (function (lambda (x)
 485                                                        (list 'vec x t)))
 486                                            (if (eq (car-safe pats) 'vec)
 487                                                (cdr pats)
 488                                              (list pats)))))))))
 489
 490 (defvar math-rewrite-whole nil)
 491 (defvar math-make-import-list nil)
 492
 493 ;; The variable math-import-list is local to part of math-compile-rewrites,
 494 ;; but is also used in a different part, and so the local version could
 495 ;; be affected by the non-local version when math-compile-rewrites calls itself.
 496 (defvar math-import-list nil)
 497
 498 ;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars,
 499 ;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
 500 ;; math-aliased-vars are local to math-compile-rewrites,
 501 ;; but are used by many functions math-rwcomp-*, which are called by
 502 ;; math-compile-rewrites.
 503 (defvar math-regs)
 504 (defvar math-num-regs)
 505 (defvar math-prog-last)
 506 (defvar math-bound-vars)
 507 (defvar math-conds)
 508 (defvar math-copy-neg)
 509 (defvar math-rhs)
 510 (defvar math-pattern)
 511 (defvar math-remembering)
 512 (defvar math-aliased-vars)
 513
 514 (defun math-compile-rewrites (rules &optional name)
 515   (if (eq (car-safe rules) 'var)
 516       (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
 517             (math-import-list nil)
 518             (math-make-import-list t)
 519             p)
 520         (or (calc-var-value (nth 2 rules))
 521             (error "Rules variable %s has no stored value" (nth 1 rules)))
 522         (or prop
 523             (put (nth 2 rules) 'math-rewrite-cache
 524                  (setq prop (list (list (cons (nth 2 rules) nil))))))
 525         (setq p (car prop))
 526         (while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
 527           (setq p (cdr p)))
 528         (or (null p)
 529             (progn
 530               (message "Compiling rule set %s..." (nth 1 rules))
 531               (setcdr prop (math-compile-rewrites
 532                             (symbol-value (nth 2 rules))
 533                             (nth 2 rules)))
 534               (message "Compiling rule set %s...done" (nth 1 rules))
 535               (setcar prop (cons (cons (nth 2 rules)
 536                                        (symbol-value (nth 2 rules)))
 537                                  math-import-list))))
 538         (cdr prop))
 539     (if (or (not (eq (car-safe rules) 'vec))
 540             (and (memq (length rules) '(3 4))
 541                  (let ((p rules))
 542                    (while (and (setq p (cdr p))
 543                                (memq (car-safe (car p))
 544                                      '(vec
 545                                        calcFunc-assign
 546                                        calcFunc-condition
 547                                        calcFunc-import
 548                                        calcFunc-phase
 549                                        calcFunc-schedule
 550                                        calcFunc-iterations))))
 551                    p)))
 552         (setq rules (list rules))
 553       (setq rules (cdr rules)))
 554     (if (assq 'calcFunc-import rules)
 555         (let ((pp (setq rules (copy-sequence rules)))
 556               p part)
 557           (while (setq p (car (cdr pp)))
 558             (if (eq (car-safe p) 'calcFunc-import)
 559                 (progn
 560                   (setcdr pp (cdr (cdr pp)))
 561                   (or (and (eq (car-safe (nth 1 p)) 'var)
 562                            (setq part (calc-var-value (nth 2 (nth 1 p))))
 563                            (memq (car-safe part) '(vec
 564                                                    calcFunc-assign
 565                                                    calcFunc-condition)))
 566                       (error "Argument of import() must be a rules variable"))
 567                   (if math-make-import-list
 568                       (setq math-import-list
 569                             (cons (cons (nth 2 (nth 1 p))
 570                                         (symbol-value (nth 2 (nth 1 p))))
 571                                   math-import-list)))
 572                   (while (setq p (cdr (cdr p)))
 573                     (or (cdr p)
 574                         (error "import() must have odd number of arguments"))
 575                     (setq part (math-rwcomp-substitute part
 576                                                        (car p) (nth 1 p))))
 577                   (if (eq (car-safe part) 'vec)
 578                       (setq part (cdr part))
 579                     (setq part (list part)))
 580                   (setcdr pp (append part (cdr pp))))
 581               (setq pp (cdr pp))))))
 582     (let ((rule-set nil)
 583           (all-heads nil)
 584           (nil-rules nil)
 585           (rule-count 0)
 586           (math-schedule nil)
 587           (math-iterations nil)
 588           (math-phases nil)
 589           (math-all-phases nil)
 590           (math-remembering nil)
 591           math-pattern math-rhs math-conds)
 592       (while rules
 593         (cond
 594          ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
 595                (= (length (car rules)) 2))
 596           (or (integerp (nth 1 (car rules)))
 597               (equal (nth 1 (car rules)) '(var inf var-inf))
 598               (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
 599               (error "Invalid argument for iterations(n)"))
 600           (or math-iterations
 601               (setq math-iterations (nth 1 (car rules)))))
 602          ((eq (car-safe (car rules)) 'calcFunc-schedule)
 603           (or math-schedule
 604               (setq math-schedule (math-parse-schedule (cdr (car rules))))))
 605          ((eq (car-safe (car rules)) 'calcFunc-phase)
 606           (setq math-phases (cdr (car rules)))
 607           (if (equal math-phases '((var all var-all)))
 608               (setq math-phases nil))
 609           (let ((p math-phases))
 610             (while p
 611               (or (integerp (car p))
 612                   (error "Phase numbers must be small integers"))
 613               (or (memq (car p) math-all-phases)
 614                   (setq math-all-phases (cons (car p) math-all-phases)))
 615               (setq p (cdr p)))))
 616          ((or (and (eq (car-safe (car rules)) 'vec)
 617                    (cdr (cdr (car rules)))
 618                    (not (nthcdr 4 (car rules)))
 619                    (setq math-conds (nth 3 (car rules))
 620                          math-rhs (nth 2 (car rules))
 621                          math-pattern (nth 1 (car rules))))
 622               (progn
 623                 (setq math-conds nil
 624                       math-pattern (car rules))
 625                 (while (and (eq (car-safe math-pattern) 'calcFunc-condition)
 626                             (= (length math-pattern) 3))
 627                   (let ((cond (nth 2 math-pattern)))
 628                     (setq math-conds (if math-conds
 629                                          (list 'calcFunc-land math-conds cond)
 630                                        cond)
 631                           math-pattern (nth 1 math-pattern))))
 632                 (and (eq (car-safe math-pattern) 'calcFunc-assign)
 633                      (= (length math-pattern) 3)
 634                      (setq math-rhs (nth 2 math-pattern)
 635                            math-pattern (nth 1 math-pattern)))))
 636           (let* ((math-prog (list nil))
 637                  (math-prog-last math-prog)
 638                  (math-num-regs 1)
 639                  (math-regs (list (list nil 0 nil nil)))
 640                  (math-bound-vars nil)
 641                  (math-aliased-vars nil)
 642                  (math-copy-neg nil))
 643             (setq math-conds (and math-conds (math-flatten-lands math-conds)))
 644             (math-rwcomp-pattern math-pattern 0)
 645             (while math-conds
 646               (let ((expr (car math-conds)))
 647                 (setq math-conds (cdr math-conds))
 648                 (math-rwcomp-cond-instr expr)))
 649             (math-rwcomp-instr 'done
 650                                (if (eq math-rhs t)
 651                                    (cons 'vec
 652                                          (delq
 653                                           nil
 654                                           (nreverse
 655                                            (mapcar
 656                                             (function
 657                                              (lambda (v)
 658                                                (and (car v)
 659                                                     (list
 660                                                      'calcFunc-assign
 661                                                      (math-build-var-name
 662                                                       (car v))
 663                                                      (math-rwcomp-register-expr
 664                                                       (nth 1 v))))))
 665                                             math-regs))))
 666                                  (math-rwcomp-match-vars math-rhs))
 667                                math-remembering)
 668             (setq math-prog (cdr math-prog))
 669             (let* ((heads (math-rewrite-heads math-pattern))
 670                    (rule (list (vconcat
 671                                 (nreverse
 672                                  (mapcar (function (lambda (x) (nth 3 x)))
 673                                          math-regs)))
 674                                math-prog
 675                                heads
 676                                math-phases))
 677                    (head (and (not (Math-primp math-pattern))
 678                               (not (and (eq (car (car math-prog)) 'try)
 679                                         (nth 5 (car math-prog))))
 680                               (not (memq (car (car math-prog)) '(func-opt
 681                                                                  apply
 682                                                                  select
 683                                                                  alt)))
 684                               (if (memq (car (car math-prog)) '(func
 685                                                                 func-def))
 686                                   (nth 2 (car math-prog))
 687                                 (if (eq (car math-pattern) 'calcFunc-quote)
 688                                     (car-safe (nth 1 math-pattern))
 689                                   (car math-pattern))))))
 690               (let (found)
 691                 (while heads
 692                   (if (setq found (assq (car heads) all-heads))
 693                       (setcdr found (1+ (cdr found)))
 694                     (setq all-heads (cons (cons (car heads) 1) all-heads)))
 695                   (setq heads (cdr heads))))
 696               (if (eq head '-) (setq head '+))
 697               (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
 698               (if head
 699                   (progn
 700                     (nconc (or (assq head rule-set)
 701                                (car (setq rule-set (cons (cons head
 702                                                                (copy-sequence
 703                                                                 nil-rules))
 704                                                          rule-set))))
 705                            (list rule))
 706                     (if (eq head '*)
 707                         (nconc (or (assq '/ rule-set)
 708                                    (car (setq rule-set (cons (cons
 709                                                               '/
 710                                                               (copy-sequence
 711                                                                nil-rules))
 712                                                              rule-set))))
 713                                (list rule))))
 714                 (setq nil-rules (nconc nil-rules (list rule)))
 715                 (let ((ptr rule-set))
 716                   (while ptr
 717                     (nconc (car ptr) (list rule))
 718                     (setq ptr (cdr ptr))))))))
 719          (t
 720           (error "Rewrite rule set must be a vector of A := B rules")))
 721         (setq rules (cdr rules)))
 722       (if nil-rules
 723           (setq rule-set (cons (cons nil nil-rules) rule-set)))
 724       (setq all-heads (mapcar 'car
 725                               (sort all-heads (function
 726                                                (lambda (x y)
 727                                                  (< (cdr x) (cdr y)))))))
 728       (let ((set rule-set)
 729             rule heads ptr)
 730         (while set
 731           (setq rule (cdr (car set)))
 732           (while rule
 733             (if (consp (setq heads (nth 2 (car rule))))
 734                 (progn
 735                   (setq heads (delq (car (car set)) heads)
 736                         ptr all-heads)
 737                   (while (and ptr (not (memq (car ptr) heads)))
 738                     (setq ptr (cdr ptr)))
 739                   (setcar (nthcdr 2 (car rule)) (car ptr))))
 740             (setq rule (cdr rule)))
 741           (setq set (cdr set))))
 742       (let ((plus (assq '+ rule-set)))
 743         (if plus
 744             (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
 745       (cons (list 'schedule math-iterations name
 746                   (or math-schedule
 747                       (sort math-all-phases '<)
 748                       (list 1)))
 749             rule-set))))
 750
 751 (defun math-flatten-lands (expr)
 752   (if (eq (car-safe expr) 'calcFunc-land)
 753       (append (math-flatten-lands (nth 1 expr))
 754               (math-flatten-lands (nth 2 expr)))
 755     (list expr)))
 756
 757 ;; The variables math-rewrite-heads-heads (i.e.; heads for math-rewrite-heads)
 758 ;; math-rewrite-heads-blanks and math-rewrite-heads-skips are local to
 759 ;; math-rewrite-heads, but used by math-rewrite-heads-rec, which is called by
 760 ;; math-rewrite-heads.
 761 (defvar math-rewrite-heads-heads)
 762 (defvar math-rewrite-heads-skips)
 763 (defvar math-rewrite-heads-blanks)
 764
 765 (defun math-rewrite-heads (expr &optional more all)
 766   (let ((math-rewrite-heads-heads more)
 767         (math-rewrite-heads-skips (and (not all)
 768                     '(calcFunc-apply calcFunc-condition calcFunc-opt
 769                                      calcFunc-por calcFunc-pnot)))
 770         (math-rewrite-heads-blanks (and (not all)
 771                      '(calcFunc-quote calcFunc-plain calcFunc-select
 772                                       calcFunc-cons calcFunc-rcons
 773                                       calcFunc-pand))))
 774     (or (Math-primp expr)
 775         (math-rewrite-heads-rec expr))
 776     math-rewrite-heads-heads))
 777
 778 (defun math-rewrite-heads-rec (expr)
 779   (or (memq (car expr) math-rewrite-heads-skips)
 780       (progn
 781         (or (memq (car expr) math-rewrite-heads-heads)
 782             (memq (car expr) math-rewrite-heads-blanks)
 783             (memq 'algebraic (get (car expr) 'math-rewrite-props))
 784             (setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads)))
 785         (while (setq expr (cdr expr))
 786           (or (Math-primp (car expr))
 787               (math-rewrite-heads-rec (car expr)))))))
 788
 789 (defun math-parse-schedule (sched)
 790   (mapcar (function
 791            (lambda (s)
 792              (if (integerp s)
 793                  s
 794                (if (math-vectorp s)
 795                    (math-parse-schedule (cdr s))
 796                  (if (eq (car-safe s) 'var)
 797                      (math-var-to-calcFunc s)
 798                    (error "Improper component in rewrite schedule"))))))
 799           sched))
 800
 801 (defun math-rwcomp-match-vars (expr)
 802   (if (Math-primp expr)
 803       (if (eq (car-safe expr) 'var)
 804           (let ((entry (assq (nth 2 expr) math-regs)))
 805             (if entry
 806                 (math-rwcomp-register-expr (nth 1 entry))
 807               expr))
 808         expr)
 809     (if (and (eq (car expr) 'calcFunc-quote)
 810              (= (length expr) 2))
 811         (math-rwcomp-match-vars (nth 1 expr))
 812       (if (and (eq (car expr) 'calcFunc-plain)
 813                (= (length expr) 2)
 814                (not (Math-primp (nth 1 expr))))
 815           (list (car expr)
 816                 (cons (car (nth 1 expr))
 817                       (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
 818         (cons (car expr)
 819               (mapcar 'math-rwcomp-match-vars (cdr expr)))))))
 820
 821 (defun math-rwcomp-register-expr (num)
 822   (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
 823     (if (nth 2 entry)
 824         (list 'neg (list 'calcFunc-register (nth 1 entry)))
 825       (list 'calcFunc-register (nth 1 entry)))))
 826
 827 ;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new,
 828 ;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func
 829 ;; are local to math-rwcomp-substitute, but are used by
 830 ;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute.
 831 (defvar math-rwcomp-subst-new)
 832 (defvar math-rwcomp-subst-old)
 833 (defvar math-rwcomp-subst-new-func)
 834 (defvar math-rwcomp-subst-old-func)
 835
 836 (defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new)
 837   (if (and (eq (car-safe math-rwcomp-subst-old) 'var)
 838            (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda)))
 839       (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old))
 840             (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new)))
 841         (math-rwcomp-subst-rec expr))
 842     (let ((math-rwcomp-subst-old-func nil))
 843       (math-rwcomp-subst-rec expr))))
 844
 845 (defun math-rwcomp-subst-rec (expr)
 846   (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
 847         ((Math-primp expr) expr)
 848         (t (if (eq (car expr) math-rwcomp-subst-old-func)
 849                (math-build-call math-rwcomp-subst-new-func
 850                                 (mapcar 'math-rwcomp-subst-rec
 851                                         (cdr expr)))
 852              (cons (car expr)
 853                    (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
 854
 855 (defvar math-rwcomp-tracing nil)
 856
 857 (defun math-rwcomp-trace (instr)
 858   (when math-rwcomp-tracing
 859     (terpri) (princ instr))
 860   instr)
 861
 862 (defun math-rwcomp-instr (&rest instr)
 863   (setcdr math-prog-last
 864           (setq math-prog-last (list (math-rwcomp-trace instr)))))
 865
 866 (defun math-rwcomp-multi-instr (tail &rest instr)
 867   (setcdr math-prog-last
 868           (setq math-prog-last (list (math-rwcomp-trace (append instr tail))))))
 869
 870 (defun math-rwcomp-bind-var (reg var)
 871   (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
 872   (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
 873   (math-rwcomp-do-conditions))
 874
 875 (defun math-rwcomp-unbind-vars (mark)
 876   (while (not (eq math-bound-vars mark))
 877     (setcar (assq (car math-bound-vars) math-regs) nil)
 878     (setq math-bound-vars (cdr math-bound-vars))))
 879
 880 (defun math-rwcomp-do-conditions ()
 881   (let ((cond math-conds))
 882     (while cond
 883       (if (math-rwcomp-all-regs-done (car cond))
 884           (let ((expr (car cond)))
 885             (setq math-conds (delq (car cond) math-conds))
 886             (setcar cond 1)
 887             (math-rwcomp-cond-instr expr)))
 888       (setq cond (cdr cond)))))
 889
 890 (defun math-rwcomp-cond-instr (expr)
 891   (let (op arg)
 892     (cond ((and (eq (car-safe expr) 'calcFunc-matches)
 893                 (= (length expr) 3)
 894                 (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
 895                     'calcFunc-register))
 896            (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
 897           ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
 898            (if (Math-zerop expr)
 899                (math-rwcomp-instr 'backtrack)))
 900           ((and (eq (car expr) 'calcFunc-let)
 901                 (= (length expr) 3))
 902            (let ((reg (math-rwcomp-reg)))
 903              (math-rwcomp-instr 'let reg (nth 2 expr))
 904              (math-rwcomp-pattern (nth 1 expr) reg)))
 905           ((and (eq (car expr) 'calcFunc-let)
 906                 (= (length expr) 2)
 907                 (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
 908                 (= (length (nth 1 expr)) 3))
 909            (let ((reg (math-rwcomp-reg)))
 910              (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
 911              (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
 912           ((and (setq op (cdr (assq (car-safe expr)
 913                                     '( (calcFunc-integer  . integer)
 914                                        (calcFunc-real     . real)
 915                                        (calcFunc-constant . constant)
 916                                        (calcFunc-negative . negative) ))))
 917                 (= (length expr) 2)
 918                 (or (and (eq (car-safe (nth 1 expr)) 'neg)
 919                          (memq op '(integer real constant))
 920                          (setq arg (nth 1 (nth 1 expr))))
 921                     (setq arg (nth 1 expr)))
 922                 (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
 923            (math-rwcomp-instr op (nth 1 arg)))
 924           ((and (assq (car-safe expr) calc-tweak-eqn-table)
 925                 (= (length expr) 3)
 926                 (eq (car-safe (nth 1 expr)) 'calcFunc-register))
 927            (if (math-constp (nth 2 expr))
 928                (let ((reg (math-rwcomp-reg)))
 929                  (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
 930                  (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
 931                                     (car expr) reg))
 932              (if (eq (car (nth 2 expr)) 'calcFunc-register)
 933                  (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
 934                                     (car expr) (nth 1 (nth 2 expr)))
 935                (math-rwcomp-instr 'cond expr))))
 936           ((and (eq (car-safe expr) 'calcFunc-eq)
 937                 (= (length expr) 3)
 938                 (eq (car-safe (nth 1 expr)) '%)
 939                 (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
 940                 (math-constp (nth 2 (nth 1 expr)))
 941                 (math-constp (nth 2 expr)))
 942            (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
 943                               (nth 2 (nth 1 expr)) (nth 2 expr)))
 944           ((equal expr '(var remember var-remember))
 945            (setq math-remembering 1))
 946           ((and (eq (car-safe expr) 'calcFunc-remember)
 947                 (= (length expr) 2))
 948            (setq math-remembering (if math-remembering
 949                                       (list 'calcFunc-lor
 950                                             math-remembering (nth 1 expr))
 951                                     (nth 1 expr))))
 952           (t (math-rwcomp-instr 'cond expr)))))
 953
 954 (defun math-rwcomp-same-instr (reg1 reg2 neg)
 955   (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
 956                                  (nth 2 (math-rwcomp-reg-entry reg2)))
 957                              neg)
 958                          'same-neg
 959                        'same)
 960                      reg1 reg2))
 961
 962 (defun math-rwcomp-copy-instr (reg1 reg2 neg)
 963   (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
 964               (nth 2 (math-rwcomp-reg-entry reg2)))
 965           neg)
 966       (math-rwcomp-instr 'copy-neg reg1 reg2)
 967     (or (eq reg1 reg2)
 968         (math-rwcomp-instr 'copy reg1 reg2))))
 969
 970 (defun math-rwcomp-reg ()
 971   (prog1
 972       math-num-regs
 973     (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
 974           math-num-regs (1+ math-num-regs))))
 975
 976 (defun math-rwcomp-reg-entry (num)
 977   (nth (1- (- math-num-regs num)) math-regs))
 978
 979
 980 (defun math-rwcomp-pattern (expr part &optional not-direct)
 981   (cond ((or (math-rwcomp-no-vars expr)
 982              (and (eq (car expr) 'calcFunc-quote)
 983                   (= (length expr) 2)
 984                   (setq expr (nth 1 expr))))
 985          (if (eq (car-safe expr) 'calcFunc-register)
 986              (math-rwcomp-same-instr part (nth 1 expr) nil)
 987            (let ((reg (math-rwcomp-reg)))
 988              (setcar (nthcdr 3 (car math-regs)) expr)
 989              (math-rwcomp-same-instr part reg nil))))
 990         ((eq (car expr) 'var)
 991          (let ((entry (assq (nth 2 expr) math-regs)))
 992            (if entry
 993                (math-rwcomp-same-instr part (nth 1 entry) nil)
 994              (if not-direct
 995                  (let ((reg (math-rwcomp-reg)))
 996                    (math-rwcomp-pattern expr reg)
 997                    (math-rwcomp-copy-instr part reg nil))
 998                (if (setq entry (assq (nth 2 expr) math-aliased-vars))
 999                    (progn
1000                      (setcar (math-rwcomp-reg-entry (nth 1 entry))
1001                              (nth 2 expr))
1002                      (setcar entry nil)
1003                      (math-rwcomp-copy-instr part (nth 1 entry) nil))
1004                  (math-rwcomp-bind-var part expr))))))
1005         ((and (eq (car expr) 'calcFunc-select)
1006               (= (length expr) 2))
1007          (let ((reg (math-rwcomp-reg)))
1008            (math-rwcomp-instr 'select part reg)
1009            (math-rwcomp-pattern (nth 1 expr) reg)))
1010         ((and (eq (car expr) 'calcFunc-opt)
1011               (memq (length expr) '(2 3)))
1012          (error "opt( ) occurs in context where it is not allowed"))
1013         ((eq (car expr) 'neg)
1014          (if (eq (car (nth 1 expr)) 'var)
1015              (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
1016                (if entry
1017                    (math-rwcomp-same-instr part (nth 1 entry) t)
1018                  (if math-copy-neg
1019                      (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
1020                        (math-rwcomp-copy-instr part reg t)
1021                        (math-rwcomp-pattern (nth 1 expr) reg))
1022                    (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
1023                    (math-rwcomp-pattern (nth 1 expr) part))))
1024            (if (math-rwcomp-is-algebraic (nth 1 expr))
1025                (math-rwcomp-cond-instr (list 'calcFunc-eq
1026                                              (math-rwcomp-register-expr part)
1027                                              expr))
1028              (let ((reg (math-rwcomp-reg)))
1029                (math-rwcomp-instr 'func part 'neg reg)
1030                (math-rwcomp-pattern (nth 1 expr) reg)))))
1031         ((and (eq (car expr) 'calcFunc-apply)
1032               (= (length expr) 3))
1033          (let ((reg1 (math-rwcomp-reg))
1034                (reg2 (math-rwcomp-reg)))
1035            (math-rwcomp-instr 'apply part reg1 reg2)
1036            (math-rwcomp-pattern (nth 1 expr) reg1)
1037            (math-rwcomp-pattern (nth 2 expr) reg2)))
1038         ((and (eq (car expr) 'calcFunc-cons)
1039               (= (length expr) 3))
1040          (let ((reg1 (math-rwcomp-reg))
1041                (reg2 (math-rwcomp-reg)))
1042            (math-rwcomp-instr 'cons part reg1 reg2)
1043            (math-rwcomp-pattern (nth 1 expr) reg1)
1044            (math-rwcomp-pattern (nth 2 expr) reg2)))
1045         ((and (eq (car expr) 'calcFunc-rcons)
1046               (= (length expr) 3))
1047          (let ((reg1 (math-rwcomp-reg))
1048                (reg2 (math-rwcomp-reg)))
1049            (math-rwcomp-instr 'rcons part reg1 reg2)
1050            (math-rwcomp-pattern (nth 1 expr) reg1)
1051            (math-rwcomp-pattern (nth 2 expr) reg2)))
1052         ((and (eq (car expr) 'calcFunc-condition)
1053               (>= (length expr) 3))
1054          (math-rwcomp-pattern (nth 1 expr) part)
1055          (setq expr (cdr expr))
1056          (while (setq expr (cdr expr))
1057            (let ((cond (math-flatten-lands (car expr))))
1058              (while cond
1059                (if (math-rwcomp-all-regs-done (car cond))
1060                    (math-rwcomp-cond-instr (car cond))
1061                  (setq math-conds (cons (car cond) math-conds)))
1062                (setq cond (cdr cond))))))
1063         ((and (eq (car expr) 'calcFunc-pand)
1064               (= (length expr) 3))
1065          (math-rwcomp-pattern (nth 1 expr) part)
1066          (math-rwcomp-pattern (nth 2 expr) part))
1067         ((and (eq (car expr) 'calcFunc-por)
1068               (= (length expr) 3))
1069          (math-rwcomp-instr 'alt nil nil [nil nil 4])
1070          (let ((math-conds nil)
1071                (head math-prog-last)
1072                (mark math-bound-vars)
1073                (math-copy-neg t))
1074            (math-rwcomp-pattern (nth 1 expr) part t)
1075            (let ((amark math-aliased-vars)
1076                  (math-aliased-vars math-aliased-vars)
1077                  (tail math-prog-last)
1078                  (p math-bound-vars)
1079                  entry)
1080              (while (not (eq p mark))
1081                (setq entry (assq (car p) math-regs)
1082                      math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
1083                                              math-aliased-vars)
1084                      p (cdr p))
1085                (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
1086              (setcar (cdr (car head)) (cdr head))
1087              (setcdr head nil)
1088              (setq math-prog-last head)
1089              (math-rwcomp-pattern (nth 2 expr) part)
1090              (math-rwcomp-instr 'same 0 0)
1091              (setcdr tail math-prog-last)
1092              (setq p math-aliased-vars)
1093              (while (not (eq p amark))
1094                (if (car (car p))
1095                    (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
1096                            (car (car p))))
1097                (setq p (cdr p)))))
1098          (math-rwcomp-do-conditions))
1099         ((and (eq (car expr) 'calcFunc-pnot)
1100               (= (length expr) 2))
1101          (math-rwcomp-instr 'alt nil nil [nil nil 4])
1102          (let ((head math-prog-last)
1103                (mark math-bound-vars))
1104            (math-rwcomp-pattern (nth 1 expr) part)
1105            (math-rwcomp-unbind-vars mark)
1106            (math-rwcomp-instr 'end-alt head)
1107            (math-rwcomp-instr 'backtrack)
1108            (setcar (cdr (car head)) (cdr head))
1109            (setcdr head nil)
1110            (setq math-prog-last head)))
1111         (t (let ((props (get (car expr) 'math-rewrite-props)))
1112              (if (and (eq (car expr) 'calcFunc-plain)
1113                       (= (length expr) 2)
1114                       (not (math-primp (nth 1 expr))))
1115                  (setq expr (nth 1 expr))) ; but "props" is still nil
1116              (if (and (memq 'algebraic props)
1117                       (math-rwcomp-is-algebraic expr))
1118                  (math-rwcomp-cond-instr (list 'calcFunc-eq
1119                                                (math-rwcomp-register-expr part)
1120                                                expr))
1121                (if (and (memq 'commut props)
1122                         (= (length expr) 3))
1123                    (let ((arg1 (nth 1 expr))
1124                          (arg2 (nth 2 expr))
1125                          try1 def code head (flip nil))
1126                      (if (eq (car expr) '-)
1127                          (setq arg2 (math-rwcomp-neg arg2)))
1128                      (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
1129                            arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
1130                      (or (math-rwcomp-order arg1 arg2)
1131                          (setq def arg1 arg1 arg2 arg2 def flip t))
1132                      (if (math-rwcomp-optional-arg (car expr) arg1)
1133                          (error "Too many opt( ) arguments in this context"))
1134                      (setq def (math-rwcomp-optional-arg (car expr) arg2)
1135                            head (if (memq (car expr) '(+ -))
1136                                     '(+ -)
1137                                   (if (eq (car expr) '*)
1138                                       '(* /)
1139                                     (list (car expr))))
1140                            code (if (math-rwcomp-is-constrained
1141                                      (car arg1) head)
1142                                     (if (math-rwcomp-is-constrained
1143                                          (car arg2) head)
1144                                         0 1)
1145                                   2))
1146                      (math-rwcomp-multi-instr (and def (list def))
1147                                               'try part head
1148                                               (vector nil nil nil code flip)
1149                                               (cdr arg1))
1150                      (setq try1 (car math-prog-last))
1151                      (math-rwcomp-pattern (car arg1) (cdr arg1))
1152                      (math-rwcomp-instr 'try2 try1 (cdr arg2))
1153                      (if (and (= part 0) (not def) (not math-rewrite-whole)
1154                               (not (eq math-rhs t))
1155                               (setq def (get (car expr)
1156                                              'math-rewrite-default)))
1157                          (let ((reg1 (math-rwcomp-reg))
1158                                (reg2 (math-rwcomp-reg)))
1159                            (if (= (aref (nth 3 try1) 3) 0)
1160                                (aset (nth 3 try1) 3 1))
1161                            (math-rwcomp-instr 'try (cdr arg2)
1162                                               (if (equal head '(* /))
1163                                                   '(*) head)
1164                                               (vector nil nil nil
1165                                                       (if (= code 0)
1166                                                           1 2)
1167                                                       nil)
1168                                               reg1 def)
1169                            (setq try1 (car math-prog-last))
1170                            (math-rwcomp-pattern (car arg2) reg1)
1171                            (math-rwcomp-instr 'try2 try1 reg2)
1172                            (setq math-rhs (list (if (eq (car expr) '-)
1173                                                     '+ (car expr))
1174                                                 math-rhs
1175                                                 (list 'calcFunc-register
1176                                                       reg2))))
1177                        (math-rwcomp-pattern (car arg2) (cdr arg2))))
1178                  (let* ((args (mapcar (function
1179                                        (lambda (x)
1180                                          (cons x (math-rwcomp-best-reg x))))
1181                                       (cdr expr)))
1182                         (args2 (copy-sequence args))
1183                         (argp (reverse args2))
1184                         (defs nil)
1185                         (num 1))
1186                    (while argp
1187                      (let ((def (math-rwcomp-optional-arg (car expr)
1188                                                           (car argp))))
1189                        (if def
1190                            (progn
1191                              (setq args2 (delq (car argp) args2)
1192                                    defs (cons (cons def (cdr (car argp)))
1193                                               defs))
1194                              (math-rwcomp-multi-instr
1195                               (mapcar 'cdr args2)
1196                               (if (or (and (memq 'unary1 props)
1197                                            (= (length args2) 1)
1198                                            (eq (car args2) (car args)))
1199                                       (and (memq 'unary2 props)
1200                                            (= (length args) 2)
1201                                            (eq (car args2) (nth 1 args))))
1202                                   'func-opt
1203                                 'func-def)
1204                               part (car expr)
1205                               defs))))
1206                      (setq argp (cdr argp)))
1207                    (math-rwcomp-multi-instr (mapcar 'cdr args)
1208                                             'func part (car expr))
1209                    (setq args (sort args 'math-rwcomp-order))
1210                    (while args
1211                      (math-rwcomp-pattern (car (car args)) (cdr (car args)))
1212                      (setq num (1+ num)
1213                            args (cdr args))))))))))
1214
1215 (defun math-rwcomp-best-reg (x)
1216   (or (and (eq (car-safe x) 'var)
1217            (let ((entry (assq (nth 2 x) math-aliased-vars)))
1218              (and entry
1219                   (not (nth 2 entry))
1220                   (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
1221                   (progn
1222                     (setcar (cdr (cdr entry)) t)
1223                     (nth 1 entry)))))
1224       (math-rwcomp-reg)))
1225
1226 (defun math-rwcomp-all-regs-done (expr)
1227   (if (Math-primp expr)
1228       (or (not (eq (car-safe expr) 'var))
1229           (assq (nth 2 expr) math-regs)
1230           (eq (nth 2 expr) 'var-remember)
1231           (math-const-var expr))
1232     (if (and (eq (car expr) 'calcFunc-let)
1233              (= (length expr) 3))
1234         (math-rwcomp-all-regs-done (nth 2 expr))
1235       (if (and (eq (car expr) 'calcFunc-let)
1236                (= (length expr) 2)
1237                (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
1238                (= (length (nth 1 expr)) 3))
1239           (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
1240         (while (and (setq expr (cdr expr))
1241                     (math-rwcomp-all-regs-done (car expr))))
1242         (null expr)))))
1243
1244 (defun math-rwcomp-no-vars (expr)
1245   (if (Math-primp expr)
1246       (or (not (eq (car-safe expr) 'var))
1247           (math-const-var expr))
1248     (and (not (memq (car expr) '(calcFunc-condition
1249                                  calcFunc-select calcFunc-quote
1250                                  calcFunc-plain calcFunc-opt
1251                                  calcFunc-por calcFunc-pand
1252                                  calcFunc-pnot calcFunc-apply
1253                                  calcFunc-cons calcFunc-rcons)))
1254          (progn
1255            (while (and (setq expr (cdr expr))
1256                        (math-rwcomp-no-vars (car expr))))
1257            (null expr)))))
1258
1259 (defun math-rwcomp-is-algebraic (expr)
1260   (if (Math-primp expr)
1261       (or (not (eq (car-safe expr) 'var))
1262           (math-const-var expr)
1263           (assq (nth 2 expr) math-regs))
1264     (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
1265          (progn
1266            (while (and (setq expr (cdr expr))
1267                        (math-rwcomp-is-algebraic (car expr))))
1268            (null expr)))))
1269
1270 (defun math-rwcomp-is-constrained (expr not-these)
1271   (if (Math-primp expr)
1272       (not (eq (car-safe expr) 'var))
1273     (if (eq (car expr) 'calcFunc-plain)
1274         (math-rwcomp-is-constrained (nth 1 expr) not-these)
1275       (not (or (memq (car expr) '(neg calcFunc-select))
1276                (memq (car expr) not-these)
1277                (and (memq 'commut (get (car expr) 'math-rewrite-props))
1278                     (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
1279                         (eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))))
1280
1281 (defun math-rwcomp-optional-arg (head argp)
1282   (let ((arg (car argp)))
1283     (if (eq (car-safe arg) 'calcFunc-opt)
1284         (and (memq (length arg) '(2 3))
1285              (progn
1286                (or (eq (car-safe (nth 1 arg)) 'var)
1287                    (error "First argument of opt( ) must be a variable"))
1288                (setcar argp (nth 1 arg))
1289                (if (= (length arg) 2)
1290                    (or (get head 'math-rewrite-default)
1291                        (error "opt( ) must include a default in this context"))
1292                  (nth 2 arg))))
1293       (and (eq (car-safe arg) 'neg)
1294            (let* ((part (list (nth 1 arg)))
1295                   (partp (math-rwcomp-optional-arg head part)))
1296              (and partp
1297                   (setcar argp (math-rwcomp-neg (car part)))
1298                   (math-neg partp)))))))
1299
1300 (defun math-rwcomp-neg (expr)
1301   (if (memq (car-safe expr) '(* /))
1302       (if (eq (car-safe (nth 1 expr)) 'var)
1303           (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
1304         (if (eq (car-safe (nth 2 expr)) 'var)
1305             (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
1306           (math-neg expr)))
1307     (math-neg expr)))
1308
1309 (defun math-rwcomp-assoc-args (expr)
1310   (if (and (eq (car-safe (nth 1 expr)) (car expr))
1311            (= (length (nth 1 expr)) 3))
1312       (math-rwcomp-assoc-args (nth 1 expr)))
1313   (if (and (eq (car-safe (nth 2 expr)) (car expr))
1314            (= (length (nth 2 expr)) 3))
1315       (math-rwcomp-assoc-args (nth 2 expr))))
1316
1317 (defun math-rwcomp-addsub-args (expr)
1318   (if (memq (car-safe (nth 1 expr)) '(+ -))
1319       (math-rwcomp-addsub-args (nth 1 expr)))
1320   (if (eq (car expr) '-)
1321       ()
1322     (if (eq (car-safe (nth 2 expr)) '+)
1323         (math-rwcomp-addsub-args (nth 2 expr)))))
1324
1325 (defun math-rwcomp-order (a b)
1326   (< (math-rwcomp-priority (car a))
1327      (math-rwcomp-priority (car b))))
1328
1329 ;; Order of priority:    0 Constants and other exact matches (first)
1330 ;;                       10 Functions (except below)
1331 ;;                       20 Meta-variables which occur more than once
1332 ;;                       30 Algebraic functions
1333 ;;                       40 Commutative/associative functions
1334 ;;                       50 Meta-variables which occur only once
1335 ;;                     +100 for every "!!!" (pnot) in the pattern
1336 ;;                    10000 Optional arguments (last)
1337
1338 (defun math-rwcomp-priority (expr)
1339   (+ (math-rwcomp-count-pnots expr)
1340      (cond ((eq (car-safe expr) 'calcFunc-opt)
1341             10000)
1342            ((math-rwcomp-no-vars expr)
1343             0)
1344            ((eq (car expr) 'calcFunc-quote)
1345             0)
1346            ((eq (car expr) 'var)
1347             (if (assq (nth 2 expr) math-regs)
1348                 0
1349               (if (= (math-rwcomp-count-refs expr) 1)
1350                   50
1351                 20)))
1352            (t (let ((props (get (car expr) 'math-rewrite-props)))
1353                 (if (or (memq 'commut props)
1354                         (memq 'assoc props))
1355                     40
1356                   (if (memq 'algebraic props)
1357                       30
1358                     10)))))))
1359
1360 (defun math-rwcomp-count-refs (var)
1361   (let ((count (or (math-expr-contains-count math-pattern var) 0))
1362         (p math-conds))
1363     (while p
1364       (if (eq (car-safe (car p)) 'calcFunc-let)
1365           (if (= (length (car p)) 3)
1366               (setq count (+ count
1367                              (or (math-expr-contains-count (nth 2 (car p)) var)
1368                                  0)))
1369             (if (and (= (length (car p)) 2)
1370                      (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
1371                      (= (length (nth 1 (car p))) 3))
1372                 (setq count (+ count
1373                                (or (math-expr-contains-count
1374                                     (nth 2 (nth 1 (car p))) var) 0))))))
1375       (setq p (cdr p)))
1376     count))
1377
1378 (defun math-rwcomp-count-pnots (expr)
1379   (if (Math-primp expr)
1380       0
1381     (if (eq (car expr) 'calcFunc-pnot)
1382         100
1383       (let ((count 0))
1384         (while (setq expr (cdr expr))
1385           (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
1386         count))))
1387
1388 ;; In the current implementation, all associative functions must
1389 ;; also be commutative.
1390
1391 (put '+              'math-rewrite-props '(algebraic assoc commut))
1392 (put '-              'math-rewrite-props '(algebraic assoc commut)) ; see below
1393 (put '*              'math-rewrite-props '(algebraic assoc commut)) ; see below
1394 (put '/              'math-rewrite-props '(algebraic unary1))
1395 (put '^              'math-rewrite-props '(algebraic unary1))
1396 (put '%              'math-rewrite-props '(algebraic))
1397 (put 'neg            'math-rewrite-props '(algebraic))
1398 (put 'calcFunc-idiv  'math-rewrite-props '(algebraic))
1399 (put 'calcFunc-abs   'math-rewrite-props '(algebraic))
1400 (put 'calcFunc-sign  'math-rewrite-props '(algebraic))
1401 (put 'calcFunc-round 'math-rewrite-props '(algebraic))
1402 (put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
1403 (put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
1404 (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
1405 (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
1406 (put 'calcFunc-ceil  'math-rewrite-props '(algebraic))
1407 (put 'calcFunc-re    'math-rewrite-props '(algebraic))
1408 (put 'calcFunc-im    'math-rewrite-props '(algebraic))
1409 (put 'calcFunc-conj  'math-rewrite-props '(algebraic))
1410 (put 'calcFunc-arg   'math-rewrite-props '(algebraic))
1411 (put 'calcFunc-and   'math-rewrite-props '(assoc commut))
1412 (put 'calcFunc-or    'math-rewrite-props '(assoc commut))
1413 (put 'calcFunc-xor   'math-rewrite-props '(assoc commut))
1414 (put 'calcFunc-eq    'math-rewrite-props '(commut))
1415 (put 'calcFunc-neq   'math-rewrite-props '(commut))
1416 (put 'calcFunc-land  'math-rewrite-props '(assoc commut))
1417 (put 'calcFunc-lor   'math-rewrite-props '(assoc commut))
1418 (put 'calcFunc-beta  'math-rewrite-props '(commut))
1419 (put 'calcFunc-gcd   'math-rewrite-props '(assoc commut))
1420 (put 'calcFunc-lcm   'math-rewrite-props '(assoc commut))
1421 (put 'calcFunc-max   'math-rewrite-props '(algebraic assoc commut))
1422 (put 'calcFunc-min   'math-rewrite-props '(algebraic assoc commut))
1423 (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
1424 (put 'calcFunc-vint  'math-rewrite-props '(assoc commut))
1425 (put 'calcFunc-vxor  'math-rewrite-props '(assoc commut))
1426
1427 ;; Note: "*" is not commutative for matrix args, but we pretend it is.
1428 ;; Also, "-" is not commutative but the code tweaks things so that it is.
1429
1430 (put '+              'math-rewrite-default  0)
1431 (put '-              'math-rewrite-default  0)
1432 (put '*              'math-rewrite-default  1)
1433 (put '/              'math-rewrite-default  1)
1434 (put '^              'math-rewrite-default  1)
1435 (put 'calcFunc-land  'math-rewrite-default  1)
1436 (put 'calcFunc-lor   'math-rewrite-default  0)
1437 (put 'calcFunc-vunion 'math-rewrite-default '(vec))
1438 (put 'calcFunc-vint  'math-rewrite-default '(vec))
1439 (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
1440 (put 'calcFunc-vxor  'math-rewrite-default '(vec))
1441
1442 (defmacro math-rwfail (&optional back)
1443   (list 'setq 'pc
1444         (list 'and
1445               (if back
1446                   '(setq btrack (cdr btrack))
1447                 'btrack)
1448               ''((backtrack)))))
1449
1450 ;; This monstrosity is necessary because the use of static vectors of
1451 ;; registers makes rewrite rules non-reentrant.  Yucko!
1452 (defmacro math-rweval (form)
1453   (list 'let '((orig (car rules)))
1454         '(setcar rules (quote (nil nil nil no-phase)))
1455         (list 'unwind-protect
1456               form
1457               '(setcar rules orig))))
1458
1459 (defvar math-rewrite-phase 1)
1460
1461 ;; The variable math-apply-rw-regs is local to math-apply-rewrites,
1462 ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
1463 ;; which are called by math-apply-rewrites.
1464 (defvar math-apply-rw-regs)
1465
1466 ;; The variable math-apply-rw-ruleset is local to math-apply-rewrites,
1467 ;; but is used by math-rwapply-remember.
1468 (defvar math-apply-rw-ruleset)
1469
1470 (defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
1471   (and
1472    (setq rules (cdr (or (assq (car-safe expr) rules)
1473                         (assq nil rules))))
1474    (let ((result nil)
1475          op math-apply-rw-regs inst part pc mark btrack
1476          (tracing math-rwcomp-tracing)
1477          (phase math-rewrite-phase))
1478      (while rules
1479        (or
1480         (and (setq part (nth 2 (car rules)))
1481              heads
1482              (not (memq part heads)))
1483         (and (setq part (nth 3 (car rules)))
1484              (not (memq phase part)))
1485         (progn
1486           (setq math-apply-rw-regs (car (car rules))
1487                 pc (nth 1 (car rules))
1488                 btrack nil)
1489           (aset math-apply-rw-regs 0 expr)
1490           (while pc
1491
1492             (and tracing
1493                  (progn (terpri) (princ (car pc))
1494                         (if (and (natnump (nth 1 (car pc)))
1495                                  (< (nth 1 (car pc)) (length math-apply-rw-regs)))
1496                             (princ
1497                              (format "\n  part = %s"
1498                                      (aref math-apply-rw-regs (nth 1 (car pc))))))))
1499
1500             (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
1501                    (if (and (consp
1502                              (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1503                             (eq (car part)
1504                                 (car (setq inst (cdr (cdr inst)))))
1505                             (progn
1506                               (while (and (setq inst (cdr inst)
1507                                                 part (cdr part))
1508                                           inst)
1509                                 (aset math-apply-rw-regs (car inst) (car part)))
1510                               (not (or inst part))))
1511                        (setq pc (cdr pc))
1512                      (math-rwfail)))
1513
1514                   ((eq op 'same)
1515                    (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1516                                   (setq mark (aref math-apply-rw-regs (nth 2 inst))))
1517                            (Math-equal part mark))
1518                        (setq pc (cdr pc))
1519                      (math-rwfail)))
1520
1521                   ((and (eq op 'try)
1522                         calc-matrix-mode
1523                         (not (eq calc-matrix-mode 'scalar))
1524                         (eq (car (nth 2 inst)) '*)
1525                         (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1526                         (eq (car part) '*)
1527                         (not (math-known-scalarp part)))
1528                    (setq mark (nth 3 inst)
1529                          pc (cdr pc))
1530                    (if (aref mark 4)
1531                        (progn
1532                          (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
1533                          (aset mark 1 (cdr (cdr part))))
1534                      (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1535                      (aset mark 1 (cdr part)))
1536                    (aset mark 0 (cdr part))
1537                    (aset mark 2 0))
1538
1539                   ((eq op 'try)
1540                    (if (and (consp (setq part
1541                                          (aref math-apply-rw-regs (car (cdr inst)))))
1542                             (memq (car part) (nth 2 inst))
1543                             (= (length part) 3)
1544                             (or (not (eq (car part) '/))
1545                                 (Math-objectp (nth 2 part))))
1546                        (progn
1547                          (setq op nil
1548                                mark (car (cdr (setq inst (cdr (cdr inst))))))
1549                          (and
1550                           (memq 'assoc (get (car part) 'math-rewrite-props))
1551                           (not (= (aref mark 3) 0))
1552                           (while (if (and (consp (nth 1 part))
1553                                           (memq (car (nth 1 part)) (car inst)))
1554                                      (setq op (cons (if (eq (car part) '-)
1555                                                         (math-rwapply-neg
1556                                                          (nth 2 part))
1557                                                       (nth 2 part))
1558                                                     op)
1559                                            part (nth 1 part))
1560                                    (if (and (consp (nth 2 part))
1561                                             (memq (car (nth 2 part))
1562                                                   (car inst))
1563                                             (not (eq (car (nth 2 part)) '-)))
1564                                        (setq op (cons (nth 1 part) op)
1565                                              part (nth 2 part))))))
1566                          (setq op (cons (nth 1 part)
1567                                         (cons (if (eq (car part) '-)
1568                                                   (math-rwapply-neg
1569                                                    (nth 2 part))
1570                                                 (if (eq (car part) '/)
1571                                                     (math-rwapply-inv
1572                                                      (nth 2 part))
1573                                                   (nth 2 part)))
1574                                               op))
1575                                btrack (cons pc btrack)
1576                                pc (cdr pc))
1577                          (aset math-apply-rw-regs (nth 2 inst) (car op))
1578                          (aset mark 0 op)
1579                          (aset mark 1 op)
1580                          (aset mark 2 (if (cdr (cdr op)) 1 0)))
1581                      (if (nth 5 inst)
1582                          (if (and (consp part)
1583                                   (eq (car part) 'neg)
1584                                   (eq (car (nth 2 inst)) '*)
1585                                   (eq (nth 5 inst) 1))
1586                              (progn
1587                                (setq mark (nth 3 inst)
1588                                      pc (cdr pc))
1589                                (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1590                                (aset mark 1 -1)
1591                                (aset mark 2 4))
1592                            (setq mark (nth 3 inst)
1593                                  pc (cdr pc))
1594                            (aset math-apply-rw-regs (nth 4 inst) part)
1595                            (aset mark 2 3))
1596                        (math-rwfail))))
1597
1598                   ((eq op 'try2)
1599                    (setq part (nth 1 inst)   ; try instr
1600                          mark (nth 3 part)
1601                          op (aref mark 2)
1602                          pc (cdr pc))
1603                    (aset math-apply-rw-regs (nth 2 inst)
1604                          (cond
1605                           ((eq op 0)
1606                            (if (eq (aref mark 0) (aref mark 1))
1607                                (nth 1 (aref mark 0))
1608                              (car (aref mark 0))))
1609                           ((eq op 1)
1610                            (setq mark (delq (car (aref mark 1))
1611                                             (copy-sequence (aref mark 0)))
1612                                  op (car (nth 2 part)))
1613                            (if (eq op '*)
1614                                (progn
1615                                  (setq mark (nreverse mark)
1616                                        part (list '* (nth 1 mark) (car mark))
1617                                        mark (cdr mark))
1618                                  (while (setq mark (cdr mark))
1619                                    (setq part (list '* (car mark) part))))
1620                              (setq part (car mark)
1621                                    mark (cdr mark)
1622                                    part (if (and (eq op '+)
1623                                                  (consp (car mark))
1624                                                  (eq (car (car mark)) 'neg))
1625                                             (list '- part
1626                                                   (nth 1 (car mark)))
1627                                           (list op part (car mark))))
1628                              (while (setq mark (cdr mark))
1629                                (setq part (if (and (eq op '+)
1630                                                    (consp (car mark))
1631                                                    (eq (car (car mark)) 'neg))
1632                                               (list '- part
1633                                                     (nth 1 (car mark)))
1634                                             (list op part (car mark))))))
1635                            part)
1636                           ((eq op 2)
1637                            (car (aref mark 1)))
1638                           ((eq op 3) (nth 5 part))
1639                           (t (aref mark 1)))))
1640
1641                   ((eq op 'select)
1642                    (setq pc (cdr pc))
1643                    (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1644                             (eq (car part) 'calcFunc-select))
1645                        (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1646                      (if math-rewrite-selections
1647                          (math-rwfail)
1648                        (aset math-apply-rw-regs (nth 2 inst) part))))
1649
1650                   ((eq op 'same-neg)
1651                    (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1652                                   (setq mark (math-neg
1653                                               (aref math-apply-rw-regs (nth 2 inst)))))
1654                            (Math-equal part mark))
1655                        (setq pc (cdr pc))
1656                      (math-rwfail)))
1657
1658                   ((eq op 'backtrack)
1659                    (setq inst (car (car btrack))   ; "try" or "alt" instr
1660                          pc (cdr (car btrack))
1661                          mark (or (nth 3 inst) [nil nil 4])
1662                          op (aref mark 2))
1663                    (cond ((eq op 0)
1664                           (if (setq op (cdr (aref mark 1)))
1665                               (aset math-apply-rw-regs (nth 4 inst)
1666                                     (car (aset mark 1 op)))
1667                             (if (nth 5 inst)
1668                                 (progn
1669                                   (aset mark 2 3)
1670                                   (aset math-apply-rw-regs (nth 4 inst)
1671                                         (aref math-apply-rw-regs (nth 1 inst))))
1672                               (math-rwfail t))))
1673                          ((eq op 1)
1674                           (if (setq op (cdr (aref mark 1)))
1675                               (aset math-apply-rw-regs (nth 4 inst)
1676                                     (car (aset mark 1 op)))
1677                             (if (= (aref mark 3) 1)
1678                                 (if (nth 5 inst)
1679                                     (progn
1680                                       (aset mark 2 3)
1681                                       (aset math-apply-rw-regs (nth 4 inst)
1682                                             (aref math-apply-rw-regs (nth 1 inst))))
1683                                   (math-rwfail t))
1684                               (aset mark 2 2)
1685                               (aset mark 1 (cons nil (aref mark 0)))
1686                               (math-rwfail))))
1687                          ((eq op 2)
1688                           (if (setq op (cdr (aref mark 1)))
1689                               (progn
1690                                 (setq mark (delq (car (aset mark 1 op))
1691                                                  (copy-sequence
1692                                                   (aref mark 0)))
1693                                       op (car (nth 2 inst)))
1694                                 (if (eq op '*)
1695                                     (progn
1696                                       (setq mark (nreverse mark)
1697                                             part (list '* (nth 1 mark)
1698                                                        (car mark))
1699                                             mark (cdr mark))
1700                                       (while (setq mark (cdr mark))
1701                                         (setq part (list '* (car mark)
1702                                                          part))))
1703                                   (setq part (car mark)
1704                                         mark (cdr mark)
1705                                         part (if (and (eq op '+)
1706                                                       (consp (car mark))
1707                                                       (eq (car (car mark))
1708                                                           'neg))
1709                                                  (list '- part
1710                                                        (nth 1 (car mark)))
1711                                                (list op part (car mark))))
1712                                   (while (setq mark (cdr mark))
1713                                     (setq part (if (and (eq op '+)
1714                                                         (consp (car mark))
1715                                                         (eq (car (car mark))
1716                                                             'neg))
1717                                                    (list '- part
1718                                                          (nth 1 (car mark)))
1719                                                  (list op part (car mark))))))
1720                                 (aset math-apply-rw-regs (nth 4 inst) part))
1721                             (if (nth 5 inst)
1722                                 (progn
1723                                   (aset mark 2 3)
1724                                   (aset math-apply-rw-regs (nth 4 inst)
1725                                         (aref math-apply-rw-regs (nth 1 inst))))
1726                               (math-rwfail t))))
1727                          ((eq op 4)
1728                           (setq btrack (cdr btrack)))
1729                          (t (math-rwfail t))))
1730
1731                   ((eq op 'integer)
1732                    (if (Math-integerp (setq part
1733                                             (aref math-apply-rw-regs (nth 1 inst))))
1734                        (setq pc (cdr pc))
1735                      (if (Math-primp part)
1736                          (math-rwfail)
1737                        (setq part (math-rweval (math-simplify part)))
1738                        (if (Math-integerp part)
1739                            (setq pc (cdr pc))
1740                          (math-rwfail)))))
1741
1742                   ((eq op 'real)
1743                    (if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1744                        (setq pc (cdr pc))
1745                      (if (Math-primp part)
1746                          (math-rwfail)
1747                        (setq part (math-rweval (math-simplify part)))
1748                        (if (Math-realp part)
1749                            (setq pc (cdr pc))
1750                          (math-rwfail)))))
1751
1752                   ((eq op 'constant)
1753                    (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1754                        (setq pc (cdr pc))
1755                      (if (Math-primp part)
1756                          (math-rwfail)
1757                        (setq part (math-rweval (math-simplify part)))
1758                        (if (math-constp part)
1759                            (setq pc (cdr pc))
1760                          (math-rwfail)))))
1761
1762                   ((eq op 'negative)
1763                    (if (math-looks-negp (setq part
1764                                               (aref math-apply-rw-regs (nth 1 inst))))
1765                        (setq pc (cdr pc))
1766                      (if (Math-primp part)
1767                          (math-rwfail)
1768                        (setq part (math-rweval (math-simplify part)))
1769                        (if (math-looks-negp part)
1770                            (setq pc (cdr pc))
1771                          (math-rwfail)))))
1772
1773                   ((eq op 'rel)
1774                    (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
1775                                             (aref math-apply-rw-regs (nth 3 inst)))
1776                          op (nth 2 inst))
1777                    (if (= part 2)
1778                        (setq part (math-rweval
1779                                    (math-simplify
1780                                     (calcFunc-sign
1781                                      (math-sub
1782                                       (aref math-apply-rw-regs (nth 1 inst))
1783                                       (aref math-apply-rw-regs (nth 3 inst))))))))
1784                    (if (cond ((eq op 'calcFunc-eq)
1785                               (eq part 0))
1786                              ((eq op 'calcFunc-neq)
1787                               (memq part '(-1 1)))
1788                              ((eq op 'calcFunc-lt)
1789                               (eq part -1))
1790                              ((eq op 'calcFunc-leq)
1791                               (memq part '(-1 0)))
1792                              ((eq op 'calcFunc-gt)
1793                               (eq part 1))
1794                              ((eq op 'calcFunc-geq)
1795                               (memq part '(0 1))))
1796                        (setq pc (cdr pc))
1797                      (math-rwfail)))
1798
1799                   ((eq op 'func-def)
1800                    (if (and
1801                         (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1802                         (eq (car part)
1803                             (car (setq inst (cdr (cdr inst))))))
1804                        (progn
1805                          (setq inst (cdr inst)
1806                                mark (car inst))
1807                          (while (and (setq inst (cdr inst)
1808                                            part (cdr part))
1809                                      inst)
1810                            (aset math-apply-rw-regs (car inst) (car part)))
1811                          (if (or inst part)
1812                              (setq pc (cdr pc))
1813                            (while (eq (car (car (setq pc (cdr pc))))
1814                                       'func-def))
1815                            (setq pc (cdr pc))   ; skip over "func"
1816                            (while mark
1817                              (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1818                              (setq mark (cdr mark)))))
1819                      (math-rwfail)))
1820
1821                   ((eq op 'func-opt)
1822                    (if (or (not
1823                             (and
1824                              (consp
1825                               (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1826                              (eq (car part) (nth 2 inst))))
1827                            (and (= (length part) 2)
1828                                 (setq part (nth 1 part))))
1829                        (progn
1830                          (setq mark (nth 3 inst))
1831                          (aset math-apply-rw-regs (nth 4 inst) part)
1832                          (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
1833                          (setq pc (cdr pc))   ; skip over "func"
1834                          (while mark
1835                            (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1836                            (setq mark (cdr mark))))
1837                      (setq pc (cdr pc))))
1838
1839                   ((eq op 'mod)
1840                    (if (if (Math-zerop
1841                             (setq part (aref math-apply-rw-regs (nth 1 inst))))
1842                            (Math-zerop (nth 3 inst))
1843                          (and (not (Math-zerop (nth 2 inst)))
1844                               (progn
1845                                 (setq part (math-mod part (nth 2 inst)))
1846                                 (or (Math-numberp part)
1847                                     (setq part (math-rweval
1848                                                 (math-simplify part))))
1849                                 (Math-equal part (nth 3 inst)))))
1850                        (setq pc (cdr pc))
1851                      (math-rwfail)))
1852
1853                   ((eq op 'apply)
1854                    (if (and (consp
1855                              (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1856                             (not (Math-objvecp part))
1857                             (not (eq (car part) 'var)))
1858                        (progn
1859                          (aset math-apply-rw-regs (nth 2 inst)
1860                                (math-calcFunc-to-var (car part)))
1861                          (aset math-apply-rw-regs (nth 3 inst)
1862                                (cons 'vec (cdr part)))
1863                          (setq pc (cdr pc)))
1864                      (math-rwfail)))
1865
1866                   ((eq op 'cons)
1867                    (if (and (consp
1868                              (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1869                             (eq (car part) 'vec)
1870                             (cdr part))
1871                        (progn
1872                          (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1873                          (aset math-apply-rw-regs (nth 3 inst)
1874                                (cons 'vec (cdr (cdr part))))
1875                          (setq pc (cdr pc)))
1876                      (math-rwfail)))
1877
1878                   ((eq op 'rcons)
1879                    (if (and (consp
1880                              (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1881                             (eq (car part) 'vec)
1882                             (cdr part))
1883                        (progn
1884                          (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
1885                          (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
1886                          (setq pc (cdr pc)))
1887                      (math-rwfail)))
1888
1889                   ((eq op 'cond)
1890                    (if (math-is-true
1891                         (math-rweval
1892                          (math-simplify
1893                           (math-rwapply-replace-regs (nth 1 inst)))))
1894                        (setq pc (cdr pc))
1895                      (math-rwfail)))
1896
1897                   ((eq op 'let)
1898                    (aset math-apply-rw-regs (nth 1 inst)
1899                          (math-rweval
1900                           (math-normalize
1901                            (math-rwapply-replace-regs (nth 2 inst)))))
1902                    (setq pc (cdr pc)))
1903
1904                   ((eq op 'copy)
1905                    (aset math-apply-rw-regs (nth 2 inst)
1906                          (aref math-apply-rw-regs (nth 1 inst)))
1907                    (setq pc (cdr pc)))
1908
1909                   ((eq op 'copy-neg)
1910                    (aset math-apply-rw-regs (nth 2 inst)
1911                          (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
1912                    (setq pc (cdr pc)))
1913
1914                   ((eq op 'alt)
1915                    (setq btrack (cons pc btrack)
1916                          pc (nth 1 inst)))
1917
1918                   ((eq op 'end-alt)
1919                    (while (and btrack (not (eq (car btrack) (nth 1 inst))))
1920                      (setq btrack (cdr btrack)))
1921                    (setq btrack (cdr btrack)
1922                          pc (cdr pc)))
1923
1924                   ((eq op 'done)
1925                    (setq result (math-rwapply-replace-regs (nth 1 inst)))
1926                    (if (or (and (eq (car-safe result) '+)
1927                                 (eq (nth 2 result) 0))
1928                            (and (eq (car-safe result) '*)
1929                                 (eq (nth 2 result) 1)))
1930                        (setq result (nth 1 result)))
1931                    (setq part (and (nth 2 inst)
1932                                    (math-is-true
1933                                     (math-rweval
1934                                      (math-simplify
1935                                       (math-rwapply-replace-regs
1936                                        (nth 2 inst)))))))
1937                    (if (or (equal result expr)
1938                            (equal (setq result (math-normalize result)) expr))
1939                        (setq result nil)
1940                      (if part (math-rwapply-remember expr result))
1941                      (setq rules nil))
1942                    (setq pc nil))
1943
1944                   (t (error "%s is not a valid rewrite opcode" op))))))
1945        (setq rules (cdr rules)))
1946      result)))
1947
1948 (defun math-rwapply-neg (expr)
1949   (if (and (consp expr)
1950            (memq (car expr) '(* /)))
1951       (if (Math-objectp (nth 2 expr))
1952           (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
1953         (list (car expr)
1954               (if (Math-objectp (nth 1 expr))
1955                   (math-neg (nth 1 expr))
1956                 (list '* -1 (nth 1 expr)))
1957               (nth 2 expr)))
1958     (math-neg expr)))
1959
1960 (defun math-rwapply-inv (expr)
1961   (if (and (Math-integerp expr)
1962            calc-prefer-frac)
1963       (math-make-frac 1 expr)
1964     (list '/ 1 expr)))
1965
1966 (defun math-rwapply-replace-regs (expr)
1967   (cond ((Math-primp expr)
1968          expr)
1969         ((eq (car expr) 'calcFunc-register)
1970          (setq expr (aref math-apply-rw-regs (nth 1 expr)))
1971          (if (eq (car-safe expr) '*)
1972              (if (eq (nth 1 expr) -1)
1973                  (math-neg (nth 2 expr))
1974                (if (eq (nth 1 expr) 1)
1975                    (nth 2 expr)
1976                  expr))
1977            expr))
1978         ((and (eq (car expr) 'calcFunc-eval)
1979               (= (length expr) 2))
1980          (calc-with-default-simplification
1981           (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
1982         ((and (eq (car expr) 'calcFunc-evalsimp)
1983               (= (length expr) 2))
1984          (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
1985         ((and (eq (car expr) 'calcFunc-evalextsimp)
1986               (= (length expr) 2))
1987          (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
1988         ((and (eq (car expr) 'calcFunc-apply)
1989               (= (length expr) 3))
1990          (let ((func (math-rwapply-replace-regs (nth 1 expr)))
1991                (args (math-rwapply-replace-regs (nth 2 expr)))
1992                call)
1993            (if (and (math-vectorp args)
1994                     (not (eq (car-safe (setq call (math-build-call
1995                                                    (math-var-to-calcFunc func)
1996                                                    (cdr args))))
1997                              'calcFunc-call)))
1998                call
1999              (list 'calcFunc-apply func args))))
2000         ((and (eq (car expr) 'calcFunc-cons)
2001               (= (length expr) 3))
2002          (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2003                (tail (math-rwapply-replace-regs (nth 2 expr))))
2004            (if (math-vectorp tail)
2005                (cons 'vec (cons head (cdr tail)))
2006              (list 'calcFunc-cons head tail))))
2007         ((and (eq (car expr) 'calcFunc-rcons)
2008               (= (length expr) 3))
2009          (let ((head (math-rwapply-replace-regs (nth 1 expr)))
2010                (tail (math-rwapply-replace-regs (nth 2 expr))))
2011            (if (math-vectorp head)
2012                (append head (list tail))
2013              (list 'calcFunc-rcons head tail))))
2014         ((and (eq (car expr) 'neg)
2015               (math-rwapply-reg-looks-negp (nth 1 expr)))
2016          (math-rwapply-reg-neg (nth 1 expr)))
2017         ((and (eq (car expr) 'neg)
2018               (eq (car-safe (nth 1 expr)) 'calcFunc-register)
2019               (math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr)))))
2020          (math-neg (math-rwapply-replace-regs (nth 1 expr))))
2021         ((and (eq (car expr) '+)
2022               (math-rwapply-reg-looks-negp (nth 1 expr)))
2023          (list '- (math-rwapply-replace-regs (nth 2 expr))
2024                (math-rwapply-reg-neg (nth 1 expr))))
2025         ((and (eq (car expr) '+)
2026               (math-rwapply-reg-looks-negp (nth 2 expr)))
2027          (list '- (math-rwapply-replace-regs (nth 1 expr))
2028                (math-rwapply-reg-neg (nth 2 expr))))
2029         ((and (eq (car expr) '-)
2030               (math-rwapply-reg-looks-negp (nth 2 expr)))
2031          (list '+ (math-rwapply-replace-regs (nth 1 expr))
2032                (math-rwapply-reg-neg (nth 2 expr))))
2033         ((eq (car expr) '*)
2034          (cond ((eq (nth 1 expr) -1)
2035                 (if (math-rwapply-reg-looks-negp (nth 2 expr))
2036                     (math-rwapply-reg-neg (nth 2 expr))
2037                   (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
2038                ((eq (nth 1 expr) 1)
2039                 (math-rwapply-replace-regs (nth 2 expr)))
2040                ((eq (nth 2 expr) -1)
2041                 (if (math-rwapply-reg-looks-negp (nth 1 expr))
2042                     (math-rwapply-reg-neg (nth 1 expr))
2043                   (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
2044                ((eq (nth 2 expr) 1)
2045                 (math-rwapply-replace-regs (nth 1 expr)))
2046                (t
2047                 (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2048                       (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2049                   (cond ((and (eq (car-safe arg1) '/)
2050                               (eq (nth 1 arg1) 1))
2051                          (list '/ arg2 (nth 2 arg1)))
2052                         ((and (eq (car-safe arg2) '/)
2053                               (eq (nth 1 arg2) 1))
2054                          (list '/ arg1 (nth 2 arg2)))
2055                         (t (list '* arg1 arg2)))))))
2056         ((eq (car expr) '/)
2057          (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
2058                (arg2 (math-rwapply-replace-regs (nth 2 expr))))
2059            (if (eq (car-safe arg2) '/)
2060                (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
2061              (list '/ arg1 arg2))))
2062         ((and (eq (car expr) 'calcFunc-plain)
2063               (= (length expr) 2))
2064          (if (Math-primp (nth 1 expr))
2065              (nth 1 expr)
2066            (if (eq (car (nth 1 expr)) 'calcFunc-register)
2067                (aref math-apply-rw-regs (nth 1 (nth 1 expr)))
2068              (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
2069                                               (cdr (nth 1 expr)))))))
2070         (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
2071
2072 (defun math-rwapply-reg-looks-negp (expr)
2073   (if (eq (car-safe expr) 'calcFunc-register)
2074       (math-looks-negp (aref math-apply-rw-regs (nth 1 expr)))
2075     (if (memq (car-safe expr) '(* /))
2076         (or (math-rwapply-reg-looks-negp (nth 1 expr))
2077             (math-rwapply-reg-looks-negp (nth 2 expr))))))
2078
2079 (defun math-rwapply-reg-neg (expr)  ; expr must satisfy rwapply-reg-looks-negp
2080   (if (eq (car expr) 'calcFunc-register)
2081       (math-neg (math-rwapply-replace-regs expr))
2082     (if (math-rwapply-reg-looks-negp (nth 1 expr))
2083         (math-rwapply-replace-regs (list (car expr)
2084                                          (math-rwapply-reg-neg (nth 1 expr))
2085                                          (nth 2 expr)))
2086       (math-rwapply-replace-regs (list (car expr)
2087                                        (nth 1 expr)
2088                                        (math-rwapply-reg-neg (nth 2 expr)))))))
2089
2090 (defun math-rwapply-remember (old new)
2091   (let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset))))
2092         (rules (assq (car-safe old) math-apply-rw-ruleset)))
2093     (if (and (eq (car-safe varval) 'vec)
2094              (not (memq (car-safe old) '(nil schedule + -)))
2095              rules)
2096         (progn
2097           (setcdr varval (cons (list 'calcFunc-assign
2098                                      (if (math-rwcomp-no-vars old)
2099                                          old
2100                                        (list 'calcFunc-quote old))
2101                                      new)
2102                                (cdr varval)))
2103           (setcdr rules (cons (list (vector nil old)
2104                                     (list (list 'same 0 1)
2105                                           (list 'done new nil))
2106                                     nil nil)
2107                               (cdr rules)))))))
2108
2109 (provide 'calc-rewr)
2110
2111 ;; arch-tag: ca8d7b7d-bff1-4535-90f3-e2241f5e786b
2112 ;;; calc-rewr.el ends here