cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-rewr.el

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