/[emacs]/emacs/lisp/calc/calc-rewr.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-rewr.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by jpb, Tue Nov 9 20:31:12 2004 UTC revision 1.10 by jpb, Fri Nov 19 21:03:48 2004 UTC
# Line 3  Line 3 
3  ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.  ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
4    
5  ;; Author: David Gillespie <daveg@synaptics.com>  ;; Author: David Gillespie <daveg@synaptics.com>
6  ;; Maintainers: D. Goel <deego@gnufans.org>  ;; Maintainer: Jay Belanger <belanger@truman.edu>
 ;;              Colin Walters <walters@debian.org>  
7    
8  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
9    
# Line 36  Line 35 
35    
36    
37  (defvar math-rewrite-default-iters 100)  (defvar math-rewrite-default-iters 100)
38    
39    ;; The variable calc-rewr-sel is local to calc-rewrite-selection and
40    ;; calc-rewrite, but is used by calc-locate-selection-marker.
41    (defvar calc-rewr-sel)
42    
43  (defun calc-rewrite-selection (rules-str &optional many prefix)  (defun calc-rewrite-selection (rules-str &optional many prefix)
44    (interactive "sRewrite rule(s): \np")    (interactive "sRewrite rule(s): \np")
45    (calc-slow-wrapper    (calc-slow-wrapper
# Line 43  Line 47 
47     (let* ((num (max 1 (calc-locate-cursor-element (point))))     (let* ((num (max 1 (calc-locate-cursor-element (point))))
48            (reselect t)            (reselect t)
49            (pop-rules nil)            (pop-rules nil)
50              rules
51            (entry (calc-top num 'entry))            (entry (calc-top num 'entry))
52            (expr (car entry))            (expr (car entry))
53            (sel (calc-auto-selection entry))            (calc-rewr-sel (calc-auto-selection entry))
54            (math-rewrite-selections t)            (math-rewrite-selections t)
55            (math-rewrite-default-iters 1))            (math-rewrite-default-iters 1))
56       (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))       (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
# Line 73  Line 78 
78       (if (eq many 0)       (if (eq many 0)
79           (setq many '(var inf var-inf))           (setq many '(var inf var-inf))
80         (if many (setq many (prefix-numeric-value many))))         (if many (setq many (prefix-numeric-value many))))
81       (if sel       (if calc-rewr-sel
82           (setq expr (calc-replace-sub-formula (car entry)           (setq expr (calc-replace-sub-formula (car entry)
83                                                sel                                                calc-rewr-sel
84                                                (list 'calcFunc-select sel)))                                                (list 'calcFunc-select calc-rewr-sel)))
85         (setq expr (car entry)         (setq expr (car entry)
86               reselect nil               reselect nil
87               math-rewrite-selections nil))               math-rewrite-selections nil))
# Line 85  Line 90 
90                    (math-rewrite                    (math-rewrite
91                     (calc-normalize expr)                     (calc-normalize expr)
92                     rules many)))                     rules many)))
93             sel nil             calc-rewr-sel nil
94             expr (calc-locate-select-marker expr))             expr (calc-locate-select-marker expr))
95       (or (consp sel) (setq sel nil))       (or (consp calc-rewr-sel) (setq calc-rewr-sel nil))
96       (if pop-rules (calc-pop-stack 1))       (if pop-rules (calc-pop-stack 1))
97       (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)       (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
98                                  (- num (if pop-rules 1 0))                                  (- num (if pop-rules 1 0))
99                                  (list (and reselect sel))))                                  (list (and reselect calc-rewr-sel))))
100     (calc-handle-whys)))     (calc-handle-whys)))
101    
102  (defun calc-locate-select-marker (expr)    ; changes "sel"  (defun calc-locate-select-marker (expr)
103    (if (Math-primp expr)    (if (Math-primp expr)
104        expr        expr
105      (if (and (eq (car expr) 'calcFunc-select)      (if (and (eq (car expr) 'calcFunc-select)
106               (= (length expr) 2))               (= (length expr) 2))
107          (progn          (progn
108            (setq sel (if sel t (nth 1 expr)))            (setq calc-rewr-sel (if calc-rewr-sel t (nth 1 expr)))
109            (nth 1 expr))            (nth 1 expr))
110        (cons (car expr)        (cons (car expr)
111              (mapcar 'calc-locate-select-marker (cdr expr))))))              (mapcar 'calc-locate-select-marker (cdr expr))))))
# Line 138  Line 143 
143           (setq many '(var inf var-inf))           (setq many '(var inf var-inf))
144         (if many (setq many (prefix-numeric-value many))))         (if many (setq many (prefix-numeric-value many))))
145       (setq expr (calc-normalize (math-rewrite expr rules many)))       (setq expr (calc-normalize (math-rewrite expr rules many)))
146       (let (sel)       (let (calc-rewr-sel)
147         (setq expr (calc-locate-select-marker expr)))         (setq expr (calc-locate-select-marker expr)))
148       (calc-pop-push-record-list n "rwrt" (list expr)))       (calc-pop-push-record-list n "rwrt" (list expr)))
149     (calc-handle-whys)))     (calc-handle-whys)))
# Line 165  Line 170 
170         (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))         (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
171    
172    
173    (defvar math-mt-many)
174    
175  (defun math-rewrite (whole-expr rules &optional math-mt-many)  ;; The variable math-rewrite-whole-expr is local to math-rewrite,
176    (let ((crules (math-compile-rewrites rules))  ;; but is used by math-rewrite-phase
177          (heads (math-rewrite-heads whole-expr))  (defvar math-rewrite-whole-expr)
178          (trace-buffer (get-buffer "*Trace*"))  
179          (calc-display-just 'center)  (defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
180          (calc-display-origin 39)    (let* ((crules (math-compile-rewrites rules))
181          (calc-line-breaking 78)           (heads (math-rewrite-heads math-rewrite-whole-expr))
182          (calc-line-numbering nil)           (trace-buffer (get-buffer "*Trace*"))
183          (calc-show-selections t)           (calc-display-just 'center)
184          (calc-why nil)           (calc-display-origin 39)
185          (math-mt-func (function           (calc-line-breaking 78)
186                         (lambda (x)           (calc-line-numbering nil)
187                           (let ((result (math-apply-rewrites x (cdr crules)           (calc-show-selections t)
188                                                              heads crules)))           (calc-why nil)
189                             (if result           (math-mt-func (function
190                                 (progn                          (lambda (x)
191                                   (if trace-buffer                            (let ((result (math-apply-rewrites x (cdr crules)
192                                       (let ((fmt (math-format-stack-value                                                               heads crules)))
193                                                   (list result nil nil))))                              (if result
194                                         (save-excursion                                  (progn
195                                           (set-buffer trace-buffer)                                    (if trace-buffer
196                                           (insert "\nrewrite to\n" fmt "\n"))))                                        (let ((fmt (math-format-stack-value
197                                   (setq heads (math-rewrite-heads result heads t))))                                                    (list result nil nil))))
198                             result)))))                                          (save-excursion
199                                              (set-buffer trace-buffer)
200                                              (insert "\nrewrite to\n" fmt "\n"))))
201                                      (setq heads (math-rewrite-heads result heads t))))
202                                result)))))
203      (if trace-buffer      (if trace-buffer
204          (let ((fmt (math-format-stack-value (list whole-expr nil nil))))          (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
205            (save-excursion            (save-excursion
206              (set-buffer trace-buffer)              (set-buffer trace-buffer)
207              (setq truncate-lines t)              (setq truncate-lines t)
# Line 203  Line 213 
213      (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))      (if (equal math-mt-many '(neg (var inf var-inf))) (setq math-mt-many -1000000))
214      (math-rewrite-phase (nth 3 (car crules)))      (math-rewrite-phase (nth 3 (car crules)))
215      (if trace-buffer      (if trace-buffer
216          (let ((fmt (math-format-stack-value (list whole-expr nil nil))))          (let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
217            (save-excursion            (save-excursion
218              (set-buffer trace-buffer)              (set-buffer trace-buffer)
219              (insert "\nDone rewriting"              (insert "\nDone rewriting"
220                      (if (= math-mt-many 0) " (reached iteration limit)" "")                      (if (= math-mt-many 0) " (reached iteration limit)" "")
221                      ":\n" fmt "\n"))))                      ":\n" fmt "\n"))))
222      whole-expr))      math-rewrite-whole-expr))
223    
224  (defun math-rewrite-phase (sched)  (defun math-rewrite-phase (sched)
225    (while (and sched (/= math-mt-many 0))    (while (and sched (/= math-mt-many 0))
226      (if (listp (car sched))      (if (listp (car sched))
227          (while (let ((save-expr whole-expr))          (while (let ((save-expr math-rewrite-whole-expr))
228                   (math-rewrite-phase (car sched))                   (math-rewrite-phase (car sched))
229                   (not (equal whole-expr save-expr))))                   (not (equal math-rewrite-whole-expr save-expr))))
230        (if (symbolp (car sched))        (if (symbolp (car sched))
231            (progn            (progn
232              (setq whole-expr (math-normalize (list (car sched) whole-expr)))              (setq math-rewrite-whole-expr
233                      (math-normalize (list (car sched) math-rewrite-whole-expr)))
234              (if trace-buffer              (if trace-buffer
235                  (let ((fmt (math-format-stack-value                  (let ((fmt (math-format-stack-value
236                              (list whole-expr nil nil))))                              (list math-rewrite-whole-expr nil nil))))
237                    (save-excursion                    (save-excursion
238                      (set-buffer trace-buffer)                      (set-buffer trace-buffer)
239                      (insert "\ncall "                      (insert "\ncall "
# Line 233  Line 244 
244                (save-excursion                (save-excursion
245                  (set-buffer trace-buffer)                  (set-buffer trace-buffer)
246                  (insert (format "\n(Phase %d)\n" math-rewrite-phase))))                  (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
247            (while (let ((save-expr whole-expr))            (while (let ((save-expr math-rewrite-whole-expr))
248                     (setq whole-expr (math-normalize                     (setq math-rewrite-whole-expr (math-normalize
249                                       (math-map-tree-rec whole-expr)))                                       (math-map-tree-rec math-rewrite-whole-expr)))
250                     (not (equal whole-expr save-expr)))))))                     (not (equal math-rewrite-whole-expr save-expr)))))))
251      (setq sched (cdr sched))))      (setq sched (cdr sched))))
252    
253  (defun calcFunc-rewrite (expr rules &optional many)  (defun calcFunc-rewrite (expr rules &optional many)
# Line 488  Line 499 
499    
500  (defvar math-rewrite-whole nil)  (defvar math-rewrite-whole nil)
501  (defvar math-make-import-list nil)  (defvar math-make-import-list nil)
502    
503    ;; The variable math-import-list is local to part of math-compile-rewrites,
504    ;; but is also used in a different part, and so the local version could
505    ;; be affected by the non-local version when math-compile-rewrites calls itself.
506    (defvar math-import-list nil)
507    
508    ;; The variables math-regs, math-num-regs, math-prog-last, math-bound-vars,
509    ;; math-conds, math-copy-neg, math-rhs, math-pattern, math-remembering and
510    ;; math-aliased-vars are local to math-compile-rewrites,
511    ;; but are used by many functions math-rwcomp-*, which are called by
512    ;; math-compile-rewrites.
513    (defvar math-regs)
514    (defvar math-num-regs)
515    (defvar math-prog-last)
516    (defvar math-bound-vars)
517    (defvar math-conds)
518    (defvar math-copy-neg)
519    (defvar math-rhs)
520    (defvar math-pattern)
521    (defvar math-remembering)
522    (defvar math-aliased-vars)
523    
524  (defun math-compile-rewrites (rules &optional name)  (defun math-compile-rewrites (rules &optional name)
525    (if (eq (car-safe rules) 'var)    (if (eq (car-safe rules) 'var)
526        (let ((prop (get (nth 2 rules) 'math-rewrite-cache))        (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
# Line 731  Line 764 
764                (math-flatten-lands (nth 2 expr)))                (math-flatten-lands (nth 2 expr)))
765      (list expr)))      (list expr)))
766    
767    ;; The variables math-rewrite-heads-heads (i.e.; heads for math-rewrite-heads)
768    ;; math-rewrite-heads-blanks and math-rewrite-heads-skips are local to
769    ;; math-rewrite-heads, but used by math-rewrite-heads-rec, which is called by
770    ;; math-rewrite-heads.
771    (defvar math-rewrite-heads-heads)
772    (defvar math-rewrite-heads-skips)
773    (defvar math-rewrite-heads-blanks)
774    
775  (defun math-rewrite-heads (expr &optional more all)  (defun math-rewrite-heads (expr &optional more all)
776    (let ((heads more)    (let ((math-rewrite-heads-heads more)
777          (skips (and (not all)          (math-rewrite-heads-skips (and (not all)
778                      '(calcFunc-apply calcFunc-condition calcFunc-opt                      '(calcFunc-apply calcFunc-condition calcFunc-opt
779                                       calcFunc-por calcFunc-pnot)))                                       calcFunc-por calcFunc-pnot)))
780          (blanks (and (not all)          (math-rewrite-heads-blanks (and (not all)
781                       '(calcFunc-quote calcFunc-plain calcFunc-select                       '(calcFunc-quote calcFunc-plain calcFunc-select
782                                        calcFunc-cons calcFunc-rcons                                        calcFunc-cons calcFunc-rcons
783                                        calcFunc-pand))))                                        calcFunc-pand))))
784      (or (Math-primp expr)      (or (Math-primp expr)
785          (math-rewrite-heads-rec expr))          (math-rewrite-heads-rec expr))
786      heads))      math-rewrite-heads-heads))
787    
788  (defun math-rewrite-heads-rec (expr)  (defun math-rewrite-heads-rec (expr)
789    (or (memq (car expr) skips)    (or (memq (car expr) math-rewrite-heads-skips)
790        (progn        (progn
791          (or (memq (car expr) heads)          (or (memq (car expr) math-rewrite-heads-heads)
792              (memq (car expr) blanks)              (memq (car expr) math-rewrite-heads-blanks)
793              (memq 'algebraic (get (car expr) 'math-rewrite-props))              (memq 'algebraic (get (car expr) 'math-rewrite-props))
794              (setq heads (cons (car expr) heads)))              (setq math-rewrite-heads-heads (cons (car expr) math-rewrite-heads-heads)))
795          (while (setq expr (cdr expr))          (while (setq expr (cdr expr))
796            (or (Math-primp (car expr))            (or (Math-primp (car expr))
797                (math-rewrite-heads-rec (car expr)))))))                (math-rewrite-heads-rec (car expr)))))))
# Line 793  Line 834 
834          (list 'neg (list 'calcFunc-register (nth 1 entry)))          (list 'neg (list 'calcFunc-register (nth 1 entry)))
835        (list 'calcFunc-register (nth 1 entry)))))        (list 'calcFunc-register (nth 1 entry)))))
836    
837  (defun math-rwcomp-substitute (expr old new)  ;; The variables math-rwcomp-subst-old, math-rwcomp-subst-new,
838    (if (and (eq (car-safe old) 'var)  ;; math-rwcomp-subst-old-func and math-rwcomp-subst-new-func
839             (memq (car-safe new) '(var calcFunc-lambda)))  ;; are local to math-rwcomp-substitute, but are used by
840        (let ((old-func (math-var-to-calcFunc old))  ;; math-rwcomp-subst-rec, which is called by math-rwcomp-substitute.
841              (new-func (math-var-to-calcFunc new)))  (defvar math-rwcomp-subst-new)
842    (defvar math-rwcomp-subst-old)
843    (defvar math-rwcomp-subst-new-func)
844    (defvar math-rwcomp-subst-old-func)
845    
846    (defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new)
847      (if (and (eq (car-safe math-rwcomp-subst-old) 'var)
848               (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda)))
849          (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old))
850                (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new)))
851          (math-rwcomp-subst-rec expr))          (math-rwcomp-subst-rec expr))
852      (let ((old-func nil))      (let ((math-rwcomp-subst-old-func nil))
853        (math-rwcomp-subst-rec expr))))        (math-rwcomp-subst-rec expr))))
854    
855  (defun math-rwcomp-subst-rec (expr)  (defun math-rwcomp-subst-rec (expr)
856    (cond ((equal expr old) new)    (cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
857          ((Math-primp expr) expr)          ((Math-primp expr) expr)
858          (t (if (eq (car expr) old-func)          (t (if (eq (car expr) math-rwcomp-subst-old-func)
859                 (math-build-call new-func (mapcar 'math-rwcomp-subst-rec                 (math-build-call math-rwcomp-subst-new-func
860                                                   (cdr expr)))                                  (mapcar 'math-rwcomp-subst-rec
861                                            (cdr expr)))
862               (cons (car expr)               (cons (car expr)
863                     (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))                     (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
864    
# Line 1268  Line 1319 
1319  (defun math-rwcomp-assoc-args (expr)  (defun math-rwcomp-assoc-args (expr)
1320    (if (and (eq (car-safe (nth 1 expr)) (car expr))    (if (and (eq (car-safe (nth 1 expr)) (car expr))
1321             (= (length (nth 1 expr)) 3))             (= (length (nth 1 expr)) 3))
1322        (math-rwcomp-assoc-args (nth 1 expr))        (math-rwcomp-assoc-args (nth 1 expr)))
     (setq math-args (cons (nth 1 expr) math-args)))  
1323    (if (and (eq (car-safe (nth 2 expr)) (car expr))    (if (and (eq (car-safe (nth 2 expr)) (car expr))
1324             (= (length (nth 2 expr)) 3))             (= (length (nth 2 expr)) 3))
1325        (math-rwcomp-assoc-args (nth 2 expr))        (math-rwcomp-assoc-args (nth 2 expr))))
     (setq math-args (cons (nth 2 expr) math-args))))  
1326    
1327  (defun math-rwcomp-addsub-args (expr)  (defun math-rwcomp-addsub-args (expr)
1328    (if (memq (car-safe (nth 1 expr)) '(+ -))    (if (memq (car-safe (nth 1 expr)) '(+ -))
1329        (math-rwcomp-addsub-args (nth 1 expr))        (math-rwcomp-addsub-args (nth 1 expr)))
     (setq math-args (cons (nth 1 expr) math-args)))  
1330    (if (eq (car expr) '-)    (if (eq (car expr) '-)
1331        (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))        ()
1332      (if (eq (car-safe (nth 2 expr)) '+)      (if (eq (car-safe (nth 2 expr)) '+)
1333          (math-rwcomp-addsub-args (nth 2 expr))          (math-rwcomp-addsub-args (nth 2 expr)))))
       (setq math-args (cons (nth 2 expr) math-args)))))  
1334    
1335  (defun math-rwcomp-order (a b)  (defun math-rwcomp-order (a b)
1336    (< (math-rwcomp-priority (car a))    (< (math-rwcomp-priority (car a))
# Line 1419  Line 1466 
1466                form                form
1467                '(setcar rules orig))))                '(setcar rules orig))))
1468    
1469  (setq math-rewrite-phase 1)  (defvar math-rewrite-phase 1)
1470    
1471    ;; The variable math-apply-rw-regs is local to math-apply-rewrites,
1472    ;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
1473    ;; which are called by math-apply-rewrites.
1474    (defvar math-apply-rw-regs)
1475    
1476    ;; The variable math-apply-rw-ruleset is local to math-apply-rewrites,
1477    ;; but is used by math-rwapply-remember.
1478    (defvar math-apply-rw-ruleset)
1479    
1480  (defun math-apply-rewrites (expr rules &optional heads ruleset)  (defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
1481    (and    (and
1482     (setq rules (cdr (or (assq (car-safe expr) rules)     (setq rules (cdr (or (assq (car-safe expr) rules)
1483                          (assq nil rules))))                          (assq nil rules))))
1484     (let ((result nil)     (let ((result nil)
1485           op regs inst part pc mark btrack           op math-apply-rw-regs inst part pc mark btrack
1486           (tracing math-rwcomp-tracing)           (tracing math-rwcomp-tracing)
1487           (phase math-rewrite-phase))           (phase math-rewrite-phase))
1488       (while rules       (while rules
# Line 1437  Line 1493 
1493          (and (setq part (nth 3 (car rules)))          (and (setq part (nth 3 (car rules)))
1494               (not (memq phase part)))               (not (memq phase part)))
1495          (progn          (progn
1496            (setq regs (car (car rules))            (setq math-apply-rw-regs (car (car rules))
1497                  pc (nth 1 (car rules))                  pc (nth 1 (car rules))
1498                  btrack nil)                  btrack nil)
1499            (aset regs 0 expr)            (aset math-apply-rw-regs 0 expr)
1500            (while pc            (while pc
1501    
1502              (and tracing              (and tracing
1503                   (progn (terpri) (princ (car pc))                   (progn (terpri) (princ (car pc))
1504                          (if (and (natnump (nth 1 (car pc)))                          (if (and (natnump (nth 1 (car pc)))
1505                                   (< (nth 1 (car pc)) (length regs)))                                   (< (nth 1 (car pc)) (length math-apply-rw-regs)))
1506                              (princ (format "\n  part = %s"                              (princ
1507                                             (aref regs (nth 1 (car pc))))))))                               (format "\n  part = %s"
1508                                         (aref math-apply-rw-regs (nth 1 (car pc))))))))
1509    
1510              (cond ((eq (setq op (car (setq inst (car pc)))) 'func)              (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
1511                     (if (and (consp (setq part (aref regs (car (cdr inst)))))                     (if (and (consp
1512                                 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1513                              (eq (car part)                              (eq (car part)
1514                                  (car (setq inst (cdr (cdr inst)))))                                  (car (setq inst (cdr (cdr inst)))))
1515                              (progn                              (progn
1516                                (while (and (setq inst (cdr inst)                                (while (and (setq inst (cdr inst)
1517                                                  part (cdr part))                                                  part (cdr part))
1518                                            inst)                                            inst)
1519                                  (aset regs (car inst) (car part)))                                  (aset math-apply-rw-regs (car inst) (car part)))
1520                                (not (or inst part))))                                (not (or inst part))))
1521                         (setq pc (cdr pc))                         (setq pc (cdr pc))
1522                       (math-rwfail)))                       (math-rwfail)))
1523    
1524                    ((eq op 'same)                    ((eq op 'same)
1525                     (if (or (equal (setq part (aref regs (nth 1 inst)))                     (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1526                                    (setq mark (aref regs (nth 2 inst))))                                    (setq mark (aref math-apply-rw-regs (nth 2 inst))))
1527                             (Math-equal part mark))                             (Math-equal part mark))
1528                         (setq pc (cdr pc))                         (setq pc (cdr pc))
1529                       (math-rwfail)))                       (math-rwfail)))
# Line 1474  Line 1532 
1532                          calc-matrix-mode                          calc-matrix-mode
1533                          (not (eq calc-matrix-mode 'scalar))                          (not (eq calc-matrix-mode 'scalar))
1534                          (eq (car (nth 2 inst)) '*)                          (eq (car (nth 2 inst)) '*)
1535                          (consp (setq part (aref regs (car (cdr inst)))))                          (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1536                          (eq (car part) '*)                          (eq (car part) '*)
1537                          (not (math-known-scalarp part)))                          (not (math-known-scalarp part)))
1538                     (setq mark (nth 3 inst)                     (setq mark (nth 3 inst)
1539                           pc (cdr pc))                           pc (cdr pc))
1540                     (if (aref mark 4)                     (if (aref mark 4)
1541                         (progn                         (progn
1542                           (aset regs (nth 4 inst) (nth 2 part))                           (aset math-apply-rw-regs (nth 4 inst) (nth 2 part))
1543                           (aset mark 1 (cdr (cdr part))))                           (aset mark 1 (cdr (cdr part))))
1544                       (aset regs (nth 4 inst) (nth 1 part))                       (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1545                       (aset mark 1 (cdr part)))                       (aset mark 1 (cdr part)))
1546                     (aset mark 0 (cdr part))                     (aset mark 0 (cdr part))
1547                     (aset mark 2 0))                     (aset mark 2 0))
1548    
1549                    ((eq op 'try)                    ((eq op 'try)
1550                     (if (and (consp (setq part (aref regs (car (cdr inst)))))                     (if (and (consp (setq part
1551                                             (aref math-apply-rw-regs (car (cdr inst)))))
1552                              (memq (car part) (nth 2 inst))                              (memq (car part) (nth 2 inst))
1553                              (= (length part) 3)                              (= (length part) 3)
1554                              (or (not (eq (car part) '/))                              (or (not (eq (car part) '/))
# Line 1525  Line 1584 
1584                                                op))                                                op))
1585                                 btrack (cons pc btrack)                                 btrack (cons pc btrack)
1586                                 pc (cdr pc))                                 pc (cdr pc))
1587                           (aset regs (nth 2 inst) (car op))                           (aset math-apply-rw-regs (nth 2 inst) (car op))
1588                           (aset mark 0 op)                           (aset mark 0 op)
1589                           (aset mark 1 op)                           (aset mark 1 op)
1590                           (aset mark 2 (if (cdr (cdr op)) 1 0)))                           (aset mark 2 (if (cdr (cdr op)) 1 0)))
# Line 1537  Line 1596 
1596                               (progn                               (progn
1597                                 (setq mark (nth 3 inst)                                 (setq mark (nth 3 inst)
1598                                       pc (cdr pc))                                       pc (cdr pc))
1599                                 (aset regs (nth 4 inst) (nth 1 part))                                 (aset math-apply-rw-regs (nth 4 inst) (nth 1 part))
1600                                 (aset mark 1 -1)                                 (aset mark 1 -1)
1601                                 (aset mark 2 4))                                 (aset mark 2 4))
1602                             (setq mark (nth 3 inst)                             (setq mark (nth 3 inst)
1603                                   pc (cdr pc))                                   pc (cdr pc))
1604                             (aset regs (nth 4 inst) part)                             (aset math-apply-rw-regs (nth 4 inst) part)
1605                             (aset mark 2 3))                             (aset mark 2 3))
1606                         (math-rwfail))))                         (math-rwfail))))
1607    
# Line 1551  Line 1610 
1610                           mark (nth 3 part)                           mark (nth 3 part)
1611                           op (aref mark 2)                           op (aref mark 2)
1612                           pc (cdr pc))                           pc (cdr pc))
1613                     (aset regs (nth 2 inst)                     (aset math-apply-rw-regs (nth 2 inst)
1614                           (cond                           (cond
1615                            ((eq op 0)                            ((eq op 0)
1616                             (if (eq (aref mark 0) (aref mark 1))                             (if (eq (aref mark 0) (aref mark 1))
# Line 1591  Line 1650 
1650    
1651                    ((eq op 'select)                    ((eq op 'select)
1652                     (setq pc (cdr pc))                     (setq pc (cdr pc))
1653                     (if (and (consp (setq part (aref regs (nth 1 inst))))                     (if (and (consp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1654                              (eq (car part) 'calcFunc-select))                              (eq (car part) 'calcFunc-select))
1655                         (aset regs (nth 2 inst) (nth 1 part))                         (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1656                       (if math-rewrite-selections                       (if math-rewrite-selections
1657                           (math-rwfail)                           (math-rwfail)
1658                         (aset regs (nth 2 inst) part))))                         (aset math-apply-rw-regs (nth 2 inst) part))))
1659    
1660                    ((eq op 'same-neg)                    ((eq op 'same-neg)
1661                     (if (or (equal (setq part (aref regs (nth 1 inst)))                     (if (or (equal (setq part (aref math-apply-rw-regs (nth 1 inst)))
1662                                    (setq mark (math-neg                                    (setq mark (math-neg
1663                                                (aref regs (nth 2 inst)))))                                                (aref math-apply-rw-regs (nth 2 inst)))))
1664                             (Math-equal part mark))                             (Math-equal part mark))
1665                         (setq pc (cdr pc))                         (setq pc (cdr pc))
1666                       (math-rwfail)))                       (math-rwfail)))
# Line 1613  Line 1672 
1672                           op (aref mark 2))                           op (aref mark 2))
1673                     (cond ((eq op 0)                     (cond ((eq op 0)
1674                            (if (setq op (cdr (aref mark 1)))                            (if (setq op (cdr (aref mark 1)))
1675                                (aset regs (nth 4 inst) (car (aset mark 1 op)))                                (aset math-apply-rw-regs (nth 4 inst)
1676                                        (car (aset mark 1 op)))
1677                              (if (nth 5 inst)                              (if (nth 5 inst)
1678                                  (progn                                  (progn
1679                                    (aset mark 2 3)                                    (aset mark 2 3)
1680                                    (aset regs (nth 4 inst)                                    (aset math-apply-rw-regs (nth 4 inst)
1681                                          (aref regs (nth 1 inst))))                                          (aref math-apply-rw-regs (nth 1 inst))))
1682                                (math-rwfail t))))                                (math-rwfail t))))
1683                           ((eq op 1)                           ((eq op 1)
1684                            (if (setq op (cdr (aref mark 1)))                            (if (setq op (cdr (aref mark 1)))
1685                                (aset regs (nth 4 inst) (car (aset mark 1 op)))                                (aset math-apply-rw-regs (nth 4 inst)
1686                                        (car (aset mark 1 op)))
1687                              (if (= (aref mark 3) 1)                              (if (= (aref mark 3) 1)
1688                                  (if (nth 5 inst)                                  (if (nth 5 inst)
1689                                      (progn                                      (progn
1690                                        (aset mark 2 3)                                        (aset mark 2 3)
1691                                        (aset regs (nth 4 inst)                                        (aset math-apply-rw-regs (nth 4 inst)
1692                                              (aref regs (nth 1 inst))))                                              (aref math-apply-rw-regs (nth 1 inst))))
1693                                    (math-rwfail t))                                    (math-rwfail t))
1694                                (aset mark 2 2)                                (aset mark 2 2)
1695                                (aset mark 1 (cons nil (aref mark 0)))                                (aset mark 1 (cons nil (aref mark 0)))
# Line 1666  Line 1727 
1727                                                     (list '- part                                                     (list '- part
1728                                                           (nth 1 (car mark)))                                                           (nth 1 (car mark)))
1729                                                   (list op part (car mark))))))                                                   (list op part (car mark))))))
1730                                  (aset regs (nth 4 inst) part))                                  (aset math-apply-rw-regs (nth 4 inst) part))
1731                              (if (nth 5 inst)                              (if (nth 5 inst)
1732                                  (progn                                  (progn
1733                                    (aset mark 2 3)                                    (aset mark 2 3)
1734                                    (aset regs (nth 4 inst)                                    (aset math-apply-rw-regs (nth 4 inst)
1735                                          (aref regs (nth 1 inst))))                                          (aref math-apply-rw-regs (nth 1 inst))))
1736                                (math-rwfail t))))                                (math-rwfail t))))
1737                           ((eq op 4)                           ((eq op 4)
1738                            (setq btrack (cdr btrack)))                            (setq btrack (cdr btrack)))
1739                           (t (math-rwfail t))))                           (t (math-rwfail t))))
1740    
1741                    ((eq op 'integer)                    ((eq op 'integer)
1742                     (if (Math-integerp (setq part (aref regs (nth 1 inst))))                     (if (Math-integerp (setq part
1743                                                (aref math-apply-rw-regs (nth 1 inst))))
1744                         (setq pc (cdr pc))                         (setq pc (cdr pc))
1745                       (if (Math-primp part)                       (if (Math-primp part)
1746                           (math-rwfail)                           (math-rwfail)
# Line 1688  Line 1750 
1750                           (math-rwfail)))))                           (math-rwfail)))))
1751    
1752                    ((eq op 'real)                    ((eq op 'real)
1753                     (if (Math-realp (setq part (aref regs (nth 1 inst))))                     (if (Math-realp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1754                         (setq pc (cdr pc))                         (setq pc (cdr pc))
1755                       (if (Math-primp part)                       (if (Math-primp part)
1756                           (math-rwfail)                           (math-rwfail)
# Line 1698  Line 1760 
1760                           (math-rwfail)))))                           (math-rwfail)))))
1761    
1762                    ((eq op 'constant)                    ((eq op 'constant)
1763                     (if (math-constp (setq part (aref regs (nth 1 inst))))                     (if (math-constp (setq part (aref math-apply-rw-regs (nth 1 inst))))
1764                         (setq pc (cdr pc))                         (setq pc (cdr pc))
1765                       (if (Math-primp part)                       (if (Math-primp part)
1766                           (math-rwfail)                           (math-rwfail)
# Line 1708  Line 1770 
1770                           (math-rwfail)))))                           (math-rwfail)))))
1771    
1772                    ((eq op 'negative)                    ((eq op 'negative)
1773                     (if (math-looks-negp (setq part (aref regs (nth 1 inst))))                     (if (math-looks-negp (setq part
1774                                                  (aref math-apply-rw-regs (nth 1 inst))))
1775                         (setq pc (cdr pc))                         (setq pc (cdr pc))
1776                       (if (Math-primp part)                       (if (Math-primp part)
1777                           (math-rwfail)                           (math-rwfail)
# Line 1718  Line 1781 
1781                           (math-rwfail)))))                           (math-rwfail)))))
1782    
1783                    ((eq op 'rel)                    ((eq op 'rel)
1784                     (setq part (math-compare (aref regs (nth 1 inst))                     (setq part (math-compare (aref math-apply-rw-regs (nth 1 inst))
1785                                              (aref regs (nth 3 inst)))                                              (aref math-apply-rw-regs (nth 3 inst)))
1786                           op (nth 2 inst))                           op (nth 2 inst))
1787                     (if (= part 2)                     (if (= part 2)
1788                         (setq part (math-rweval                         (setq part (math-rweval
1789                                     (math-simplify                                     (math-simplify
1790                                      (calcFunc-sign                                      (calcFunc-sign
1791                                       (math-sub (aref regs (nth 1 inst))                                       (math-sub
1792                                                 (aref regs (nth 3 inst))))))))                                        (aref math-apply-rw-regs (nth 1 inst))
1793                                          (aref math-apply-rw-regs (nth 3 inst))))))))
1794                     (if (cond ((eq op 'calcFunc-eq)                     (if (cond ((eq op 'calcFunc-eq)
1795                                (eq part 0))                                (eq part 0))
1796                               ((eq op 'calcFunc-neq)                               ((eq op 'calcFunc-neq)
# Line 1743  Line 1807 
1807                       (math-rwfail)))                       (math-rwfail)))
1808    
1809                    ((eq op 'func-def)                    ((eq op 'func-def)
1810                     (if (and (consp (setq part (aref regs (car (cdr inst)))))                     (if (and
1811                              (eq (car part)                          (consp (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1812                                  (car (setq inst (cdr (cdr inst))))))                          (eq (car part)
1813                                (car (setq inst (cdr (cdr inst))))))
1814                         (progn                         (progn
1815                           (setq inst (cdr inst)                           (setq inst (cdr inst)
1816                                 mark (car inst))                                 mark (car inst))
1817                           (while (and (setq inst (cdr inst)                           (while (and (setq inst (cdr inst)
1818                                             part (cdr part))                                             part (cdr part))
1819                                       inst)                                       inst)
1820                             (aset regs (car inst) (car part)))                             (aset math-apply-rw-regs (car inst) (car part)))
1821                           (if (or inst part)                           (if (or inst part)
1822                               (setq pc (cdr pc))                               (setq pc (cdr pc))
1823                             (while (eq (car (car (setq pc (cdr pc))))                             (while (eq (car (car (setq pc (cdr pc))))
1824                                        'func-def))                                        'func-def))
1825                             (setq pc (cdr pc))   ; skip over "func"                             (setq pc (cdr pc))   ; skip over "func"
1826                             (while mark                             (while mark
1827                               (aset regs (cdr (car mark)) (car (car mark)))                               (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1828                               (setq mark (cdr mark)))))                               (setq mark (cdr mark)))))
1829                       (math-rwfail)))                       (math-rwfail)))
1830    
1831                    ((eq op 'func-opt)                    ((eq op 'func-opt)
1832                     (if (or (not (and (consp                     (if (or (not
1833                                        (setq part (aref regs (car (cdr inst)))))                              (and
1834                                       (eq (car part) (nth 2 inst))))                               (consp
1835                                  (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1836                                 (eq (car part) (nth 2 inst))))
1837                             (and (= (length part) 2)                             (and (= (length part) 2)
1838                                  (setq part (nth 1 part))))                                  (setq part (nth 1 part))))
1839                         (progn                         (progn
1840                           (setq mark (nth 3 inst))                           (setq mark (nth 3 inst))
1841                           (aset regs (nth 4 inst) part)                           (aset math-apply-rw-regs (nth 4 inst) part)
1842                           (while (eq (car (car (setq pc (cdr pc)))) 'func-def))                           (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
1843                           (setq pc (cdr pc))   ; skip over "func"                           (setq pc (cdr pc))   ; skip over "func"
1844                           (while mark                           (while mark
1845                             (aset regs (cdr (car mark)) (car (car mark)))                             (aset math-apply-rw-regs (cdr (car mark)) (car (car mark)))
1846                             (setq mark (cdr mark))))                             (setq mark (cdr mark))))
1847                       (setq pc (cdr pc))))                       (setq pc (cdr pc))))
1848    
1849                    ((eq op 'mod)                    ((eq op 'mod)
1850                     (if (if (Math-zerop (setq part (aref regs (nth 1 inst))))                     (if (if (Math-zerop
1851                                (setq part (aref math-apply-rw-regs (nth 1 inst))))
1852                             (Math-zerop (nth 3 inst))                             (Math-zerop (nth 3 inst))
1853                           (and (not (Math-zerop (nth 2 inst)))                           (and (not (Math-zerop (nth 2 inst)))
1854                                (progn                                (progn
# Line 1793  Line 1861 
1861                       (math-rwfail)))                       (math-rwfail)))
1862    
1863                    ((eq op 'apply)                    ((eq op 'apply)
1864                     (if (and (consp (setq part (aref regs (car (cdr inst)))))                     (if (and (consp
1865                                 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1866                              (not (Math-objvecp part))                              (not (Math-objvecp part))
1867                              (not (eq (car part) 'var)))                              (not (eq (car part) 'var)))
1868                         (progn                         (progn
1869                           (aset regs (nth 2 inst)                           (aset math-apply-rw-regs (nth 2 inst)
1870                                 (math-calcFunc-to-var (car part)))                                 (math-calcFunc-to-var (car part)))
1871                           (aset regs (nth 3 inst)                           (aset math-apply-rw-regs (nth 3 inst)
1872                                 (cons 'vec (cdr part)))                                 (cons 'vec (cdr part)))
1873                           (setq pc (cdr pc)))                           (setq pc (cdr pc)))
1874                       (math-rwfail)))                       (math-rwfail)))
1875    
1876                    ((eq op 'cons)                    ((eq op 'cons)
1877                     (if (and (consp (setq part (aref regs (car (cdr inst)))))                     (if (and (consp
1878                                 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1879                              (eq (car part) 'vec)                              (eq (car part) 'vec)
1880                              (cdr part))                              (cdr part))
1881                         (progn                         (progn
1882                           (aset regs (nth 2 inst) (nth 1 part))                           (aset math-apply-rw-regs (nth 2 inst) (nth 1 part))
1883                           (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part))))                           (aset math-apply-rw-regs (nth 3 inst)
1884                                   (cons 'vec (cdr (cdr part))))
1885                           (setq pc (cdr pc)))                           (setq pc (cdr pc)))
1886                       (math-rwfail)))                       (math-rwfail)))
1887    
1888                    ((eq op 'rcons)                    ((eq op 'rcons)
1889                     (if (and (consp (setq part (aref regs (car (cdr inst)))))                     (if (and (consp
1890                                 (setq part (aref math-apply-rw-regs (car (cdr inst)))))
1891                              (eq (car part) 'vec)                              (eq (car part) 'vec)
1892                              (cdr part))                              (cdr part))
1893                         (progn                         (progn
1894                           (aset regs (nth 2 inst) (calcFunc-rhead part))                           (aset math-apply-rw-regs (nth 2 inst) (calcFunc-rhead part))
1895                           (aset regs (nth 3 inst) (calcFunc-rtail part))                           (aset math-apply-rw-regs (nth 3 inst) (calcFunc-rtail part))
1896                           (setq pc (cdr pc)))                           (setq pc (cdr pc)))
1897                       (math-rwfail)))                       (math-rwfail)))
1898    
# Line 1833  Line 1905 
1905                       (math-rwfail)))                       (math-rwfail)))
1906    
1907                    ((eq op 'let)                    ((eq op 'let)
1908                     (aset regs (nth 1 inst)                     (aset math-apply-rw-regs (nth 1 inst)
1909                           (math-rweval                           (math-rweval
1910                            (math-normalize                            (math-normalize
1911                             (math-rwapply-replace-regs (nth 2 inst)))))                             (math-rwapply-replace-regs (nth 2 inst)))))
1912                     (setq pc (cdr pc)))                     (setq pc (cdr pc)))
1913    
1914                    ((eq op 'copy)                    ((eq op 'copy)
1915                     (aset regs (nth 2 inst) (aref regs (nth 1 inst)))                     (aset math-apply-rw-regs (nth 2 inst)
1916                             (aref math-apply-rw-regs (nth 1 inst)))
1917                     (setq pc (cdr pc)))                     (setq pc (cdr pc)))
1918    
1919                    ((eq op 'copy-neg)                    ((eq op 'copy-neg)
1920                     (aset regs (nth 2 inst)                     (aset math-apply-rw-regs (nth 2 inst)
1921                           (math-rwapply-neg (aref regs (nth 1 inst))))                           (math-rwapply-neg (aref math-apply-rw-regs (nth 1 inst))))
1922                     (setq pc (cdr pc)))                     (setq pc (cdr pc)))
1923    
1924                    ((eq op 'alt)                    ((eq op 'alt)
# Line 1904  Line 1977 
1977    (cond ((Math-primp expr)    (cond ((Math-primp expr)
1978           expr)           expr)
1979          ((eq (car expr) 'calcFunc-register)          ((eq (car expr) 'calcFunc-register)
1980           (setq expr (aref regs (nth 1 expr)))           (setq expr (aref math-apply-rw-regs (nth 1 expr)))
1981           (if (eq (car-safe expr) '*)           (if (eq (car-safe expr) '*)
1982               (if (eq (nth 1 expr) -1)               (if (eq (nth 1 expr) -1)
1983                   (math-neg (nth 2 expr))                   (math-neg (nth 2 expr))
# Line 1953  Line 2026 
2026           (math-rwapply-reg-neg (nth 1 expr)))           (math-rwapply-reg-neg (nth 1 expr)))
2027          ((and (eq (car expr) 'neg)          ((and (eq (car expr) 'neg)
2028                (eq (car-safe (nth 1 expr)) 'calcFunc-register)                (eq (car-safe (nth 1 expr)) 'calcFunc-register)
2029                (math-scalarp (aref regs (nth 1 (nth 1 expr)))))                (math-scalarp (aref math-apply-rw-regs (nth 1 (nth 1 expr)))))
2030           (math-neg (math-rwapply-replace-regs (nth 1 expr))))           (math-neg (math-rwapply-replace-regs (nth 1 expr))))
2031          ((and (eq (car expr) '+)          ((and (eq (car expr) '+)
2032                (math-rwapply-reg-looks-negp (nth 1 expr)))                (math-rwapply-reg-looks-negp (nth 1 expr)))
# Line 2001  Line 2074 
2074           (if (Math-primp (nth 1 expr))           (if (Math-primp (nth 1 expr))
2075               (nth 1 expr)               (nth 1 expr)
2076             (if (eq (car (nth 1 expr)) 'calcFunc-register)             (if (eq (car (nth 1 expr)) 'calcFunc-register)
2077                 (aref regs (nth 1 (nth 1 expr)))                 (aref math-apply-rw-regs (nth 1 (nth 1 expr)))
2078               (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs               (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
2079                                                (cdr (nth 1 expr)))))))                                                (cdr (nth 1 expr)))))))
2080          (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))          (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
2081    
2082  (defun math-rwapply-reg-looks-negp (expr)  (defun math-rwapply-reg-looks-negp (expr)
2083    (if (eq (car-safe expr) 'calcFunc-register)    (if (eq (car-safe expr) 'calcFunc-register)
2084        (math-looks-negp (aref regs (nth 1 expr)))        (math-looks-negp (aref math-apply-rw-regs (nth 1 expr)))
2085      (if (memq (car-safe expr) '(* /))      (if (memq (car-safe expr) '(* /))
2086          (or (math-rwapply-reg-looks-negp (nth 1 expr))          (or (math-rwapply-reg-looks-negp (nth 1 expr))
2087              (math-rwapply-reg-looks-negp (nth 2 expr))))))              (math-rwapply-reg-looks-negp (nth 2 expr))))))
# Line 2025  Line 2098 
2098                                         (math-rwapply-reg-neg (nth 2 expr)))))))                                         (math-rwapply-reg-neg (nth 2 expr)))))))
2099    
2100  (defun math-rwapply-remember (old new)  (defun math-rwapply-remember (old new)
2101    (let ((varval (symbol-value (nth 2 (car ruleset))))    (let ((varval (symbol-value (nth 2 (car math-apply-rw-ruleset))))
2102          (rules (assq (car-safe old) ruleset)))          (rules (assq (car-safe old) math-apply-rw-ruleset)))
2103      (if (and (eq (car-safe varval) 'vec)      (if (and (eq (car-safe varval) 'vec)
2104               (not (memq (car-safe old) '(nil schedule + -)))               (not (memq (car-safe old) '(nil schedule + -)))
2105               rules)               rules)

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26