lisp/calc/calc-rewr.el

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