/[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.1 by eliz, Tue Nov 6 18:59:06 2001 UTC revision 1.2 by walters, Wed Nov 14 09:06:50 2001 UTC
# Line 1  Line 1 
1  ;; Calculator for GNU Emacs, part II [calc-rewr.el]  ;; Calculator for GNU Emacs, part II [calc-rewr.el]
2  ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.  ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
3  ;; Written by Dave Gillespie, daveg@synaptics.com.  ;; Written by Dave Gillespie, daveg@synaptics.com.
4    
5  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
# Line 85  Line 85 
85       (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)       (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
86                                  (- num (if pop-rules 1 0))                                  (- num (if pop-rules 1 0))
87                                  (list (and reselect sel))))                                  (list (and reselect sel))))
88     (calc-handle-whys))     (calc-handle-whys)))
 )  
89    
90  (defun calc-locate-select-marker (expr)    ; changes "sel"  (defun calc-locate-select-marker (expr)    ; changes "sel"
91    (if (Math-primp expr)    (if (Math-primp expr)
# Line 97  Line 96 
96            (setq sel (if sel t (nth 1 expr)))            (setq sel (if sel t (nth 1 expr)))
97            (nth 1 expr))            (nth 1 expr))
98        (cons (car expr)        (cons (car expr)
99              (mapcar 'calc-locate-select-marker (cdr expr)))))              (mapcar 'calc-locate-select-marker (cdr expr))))))
 )  
100    
101    
102    
# Line 136  Line 134 
134       (let (sel)       (let (sel)
135         (setq expr (calc-locate-select-marker expr)))         (setq expr (calc-locate-select-marker expr)))
136       (calc-pop-push-record-list n "rwrt" (list expr)))       (calc-pop-push-record-list n "rwrt" (list expr)))
137     (calc-handle-whys))     (calc-handle-whys)))
 )  
138    
139  (defun calc-match (pat)  (defun calc-match (pat)
140    (interactive "sPattern: \n")    (interactive "sPattern: \n")
# Line 158  Line 155 
155       (or (math-vectorp expr) (error "Argument must be a vector"))       (or (math-vectorp expr) (error "Argument must be a vector"))
156       (if (calc-is-inverse)       (if (calc-is-inverse)
157           (calc-enter-result n "mtcn" (math-match-patterns pat expr t))           (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
158         (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))         (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
 )  
159    
160    
161    
# Line 206  Line 202 
202              (insert "\nDone rewriting"              (insert "\nDone rewriting"
203                      (if (= mmt-many 0) " (reached iteration limit)" "")                      (if (= mmt-many 0) " (reached iteration limit)" "")
204                      ":\n" fmt "\n"))))                      ":\n" fmt "\n"))))
205      whole-expr)      whole-expr))
 )  
206  (setq math-rewrite-default-iters 100)  (setq math-rewrite-default-iters 100)
207    
208  (defun math-rewrite-phase (sched)  (defun math-rewrite-phase (sched)
# Line 236  Line 231 
231                     (setq whole-expr (math-normalize                     (setq whole-expr (math-normalize
232                                       (math-map-tree-rec whole-expr)))                                       (math-map-tree-rec whole-expr)))
233                     (not (equal whole-expr save-expr)))))))                     (not (equal whole-expr save-expr)))))))
234      (setq sched (cdr sched)))      (setq sched (cdr sched))))
 )  
235    
236  (defun calcFunc-rewrite (expr rules &optional many)  (defun calcFunc-rewrite (expr rules &optional many)
237    (or (null many) (integerp many)    (or (null many) (integerp many)
# Line 245  Line 239 
239        (math-reject-arg many 'fixnump))        (math-reject-arg many 'fixnump))
240    (condition-case err    (condition-case err
241        (math-rewrite expr rules (or many 1))        (math-rewrite expr rules (or many 1))
242      (error (math-reject-arg rules (nth 1 err))))      (error (math-reject-arg rules (nth 1 err)))))
 )  
243    
244  (defun calcFunc-match (pat vec)  (defun calcFunc-match (pat vec)
245    (or (math-vectorp vec) (math-reject-arg vec 'vectorp))    (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
246    (condition-case err    (condition-case err
247        (math-match-patterns pat vec nil)        (math-match-patterns pat vec nil)
248      (error (math-reject-arg pat (nth 1 err))))      (error (math-reject-arg pat (nth 1 err)))))
 )  
249    
250  (defun calcFunc-matchnot (pat vec)  (defun calcFunc-matchnot (pat vec)
251    (or (math-vectorp vec) (math-reject-arg vec 'vectorp))    (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
252    (condition-case err    (condition-case err
253        (math-match-patterns pat vec t)        (math-match-patterns pat vec t)
254      (error (math-reject-arg pat (nth 1 err))))      (error (math-reject-arg pat (nth 1 err)))))
 )  
255    
256  (defun math-match-patterns (pat vec &optional not-flag)  (defun math-match-patterns (pat vec &optional not-flag)
257    (let ((newvec nil)    (let ((newvec nil)
# Line 269  Line 260 
260        (if (eq (not (math-apply-rewrites (car vec) crules))        (if (eq (not (math-apply-rewrites (car vec) crules))
261                not-flag)                not-flag)
262            (setq newvec (cons (car vec) newvec))))            (setq newvec (cons (car vec) newvec))))
263      (cons 'vec (nreverse newvec)))      (cons 'vec (nreverse newvec))))
 )  
264    
265  (defun calcFunc-matches (expr pat)  (defun calcFunc-matches (expr pat)
266    (condition-case err    (condition-case err
267        (if (math-apply-rewrites expr (math-compile-patterns pat))        (if (math-apply-rewrites expr (math-compile-patterns pat))
268            1            1
269          0)          0)
270      (error (math-reject-arg pat (nth 1 err))))      (error (math-reject-arg pat (nth 1 err)))))
 )  
271    
272  (defun calcFunc-vmatches (expr pat)  (defun calcFunc-vmatches (expr pat)
273    (condition-case err    (condition-case err
274        (or (math-apply-rewrites expr (math-compile-patterns pat))        (or (math-apply-rewrites expr (math-compile-patterns pat))
275            0)            0)
276      (error (math-reject-arg pat (nth 1 err))))      (error (math-reject-arg pat (nth 1 err)))))
 )  
277    
278    
279    
# Line 490  Line 478 
478                                                         (list 'vec x t)))                                                         (list 'vec x t)))
479                                             (if (eq (car-safe pats) 'vec)                                             (if (eq (car-safe pats) 'vec)
480                                                 (cdr pats)                                                 (cdr pats)
481                                               (list pats))))))))                                               (list pats)))))))))
 )  
482  (setq math-rewrite-whole nil)  (setq math-rewrite-whole nil)
483  (setq math-make-import-list nil)  (setq math-make-import-list nil)
484    
# Line 730  Line 717 
717                    (or math-schedule                    (or math-schedule
718                        (sort math-all-phases '<)                        (sort math-all-phases '<)
719                        (list 1)))                        (list 1)))
720              rule-set)))              rule-set))))
 )  
721    
722  (defun math-flatten-lands (expr)  (defun math-flatten-lands (expr)
723    (if (eq (car-safe expr) 'calcFunc-land)    (if (eq (car-safe expr) 'calcFunc-land)
724        (append (math-flatten-lands (nth 1 expr))        (append (math-flatten-lands (nth 1 expr))
725                (math-flatten-lands (nth 2 expr)))                (math-flatten-lands (nth 2 expr)))
726      (list expr))      (list expr)))
 )  
727    
728  (defun math-rewrite-heads (expr &optional more all)  (defun math-rewrite-heads (expr &optional more all)
729    (let ((heads more)    (let ((heads more)
# Line 751  Line 736 
736                                        calcFunc-pand))))                                        calcFunc-pand))))
737      (or (Math-primp expr)      (or (Math-primp expr)
738          (math-rewrite-heads-rec expr))          (math-rewrite-heads-rec expr))
739      heads)      heads))
 )  
740    
741  (defun math-rewrite-heads-rec (expr)  (defun math-rewrite-heads-rec (expr)
742    (or (memq (car expr) skips)    (or (memq (car expr) skips)
# Line 763  Line 747 
747              (setq heads (cons (car expr) heads)))              (setq heads (cons (car expr) heads)))
748          (while (setq expr (cdr expr))          (while (setq expr (cdr expr))
749            (or (Math-primp (car expr))            (or (Math-primp (car expr))
750                (math-rewrite-heads-rec (car expr))))))                (math-rewrite-heads-rec (car expr)))))))
 )  
751    
752  (defun math-parse-schedule (sched)  (defun math-parse-schedule (sched)
753    (mapcar (function    (mapcar (function
# Line 776  Line 759 
759                   (if (eq (car-safe s) 'var)                   (if (eq (car-safe s) 'var)
760                       (math-var-to-calcFunc s)                       (math-var-to-calcFunc s)
761                     (error "Improper component in rewrite schedule"))))))                     (error "Improper component in rewrite schedule"))))))
762            sched)            sched))
 )  
763    
764  (defun math-rwcomp-match-vars (expr)  (defun math-rwcomp-match-vars (expr)
765    (if (Math-primp expr)    (if (Math-primp expr)
# Line 797  Line 779 
779                  (cons (car (nth 1 expr))                  (cons (car (nth 1 expr))
780                        (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))                        (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
781          (cons (car expr)          (cons (car expr)
782                (mapcar 'math-rwcomp-match-vars (cdr expr))))))                (mapcar 'math-rwcomp-match-vars (cdr expr)))))))
 )  
783    
784  (defun math-rwcomp-register-expr (num)  (defun math-rwcomp-register-expr (num)
785    (let ((entry (nth (1- (- math-num-regs num)) math-regs)))    (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
786      (if (nth 2 entry)      (if (nth 2 entry)
787          (list 'neg (list 'calcFunc-register (nth 1 entry)))          (list 'neg (list 'calcFunc-register (nth 1 entry)))
788        (list 'calcFunc-register (nth 1 entry))))        (list 'calcFunc-register (nth 1 entry)))))
 )  
789    
790  (defun math-rwcomp-substitute (expr old new)  (defun math-rwcomp-substitute (expr old new)
791    (if (and (eq (car-safe old) 'var)    (if (and (eq (car-safe old) 'var)
# Line 814  Line 794 
794              (new-func (math-var-to-calcFunc new)))              (new-func (math-var-to-calcFunc new)))
795          (math-rwcomp-subst-rec expr))          (math-rwcomp-subst-rec expr))
796      (let ((old-func nil))      (let ((old-func nil))
797        (math-rwcomp-subst-rec expr)))        (math-rwcomp-subst-rec expr))))
 )  
798    
799  (defun math-rwcomp-subst-rec (expr)  (defun math-rwcomp-subst-rec (expr)
800    (cond ((equal expr old) new)    (cond ((equal expr old) new)
# Line 824  Line 803 
803                 (math-build-call new-func (mapcar 'math-rwcomp-subst-rec                 (math-build-call new-func (mapcar 'math-rwcomp-subst-rec
804                                                   (cdr expr)))                                                   (cdr expr)))
805               (cons (car expr)               (cons (car expr)
806                     (mapcar 'math-rwcomp-subst-rec (cdr expr))))))                     (mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
 )  
807    
808  (setq math-rwcomp-tracing nil)  (setq math-rwcomp-tracing nil)
809    
810  (defun math-rwcomp-trace (instr)  (defun math-rwcomp-trace (instr)
811    (if math-rwcomp-tracing (progn (terpri) (princ instr)))    (if math-rwcomp-tracing (progn (terpri) (princ instr)))
812    instr    instr)
 )  
813    
814  (defun math-rwcomp-instr (&rest instr)  (defun math-rwcomp-instr (&rest instr)
815    (setcdr math-prog-last    (setcdr math-prog-last
816            (setq math-prog-last (list (math-rwcomp-trace instr))))            (setq math-prog-last (list (math-rwcomp-trace instr)))))
 )  
817    
818  (defun math-rwcomp-multi-instr (tail &rest instr)  (defun math-rwcomp-multi-instr (tail &rest instr)
819    (setcdr math-prog-last    (setcdr math-prog-last
820            (setq math-prog-last (list (math-rwcomp-trace (append instr tail)))))            (setq math-prog-last (list (math-rwcomp-trace (append instr tail))))))
 )  
821    
822  (defun math-rwcomp-bind-var (reg var)  (defun math-rwcomp-bind-var (reg var)
823    (setcar (math-rwcomp-reg-entry reg) (nth 2 var))    (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
824    (setq math-bound-vars (cons (nth 2 var) math-bound-vars))    (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
825    (math-rwcomp-do-conditions)    (math-rwcomp-do-conditions))
 )  
826    
827  (defun math-rwcomp-unbind-vars (mark)  (defun math-rwcomp-unbind-vars (mark)
828    (while (not (eq math-bound-vars mark))    (while (not (eq math-bound-vars mark))
829      (setcar (assq (car math-bound-vars) math-regs) nil)      (setcar (assq (car math-bound-vars) math-regs) nil)
830      (setq math-bound-vars (cdr math-bound-vars)))      (setq math-bound-vars (cdr math-bound-vars))))
 )  
831    
832  (defun math-rwcomp-do-conditions ()  (defun math-rwcomp-do-conditions ()
833    (let ((cond math-conds))    (let ((cond math-conds))
# Line 864  Line 837 
837              (setq math-conds (delq (car cond) math-conds))              (setq math-conds (delq (car cond) math-conds))
838              (setcar cond 1)              (setcar cond 1)
839              (math-rwcomp-cond-instr expr)))              (math-rwcomp-cond-instr expr)))
840        (setq cond (cdr cond))))        (setq cond (cdr cond)))))
 )  
841    
842  (defun math-rwcomp-cond-instr (expr)  (defun math-rwcomp-cond-instr (expr)
843    (let (op arg)    (let (op arg)
# Line 929  Line 901 
901                                        (list 'calcFunc-lor                                        (list 'calcFunc-lor
902                                              math-remembering (nth 1 expr))                                              math-remembering (nth 1 expr))
903                                      (nth 1 expr))))                                      (nth 1 expr))))
904            (t (math-rwcomp-instr 'cond expr))))            (t (math-rwcomp-instr 'cond expr)))))
 )  
905    
906  (defun math-rwcomp-same-instr (reg1 reg2 neg)  (defun math-rwcomp-same-instr (reg1 reg2 neg)
907    (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))    (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
# Line 938  Line 909 
909                               neg)                               neg)
910                           'same-neg                           'same-neg
911                         'same)                         'same)
912                       reg1 reg2)                       reg1 reg2))
 )  
913    
914  (defun math-rwcomp-copy-instr (reg1 reg2 neg)  (defun math-rwcomp-copy-instr (reg1 reg2 neg)
915    (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))    (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
# Line 947  Line 917 
917            neg)            neg)
918        (math-rwcomp-instr 'copy-neg reg1 reg2)        (math-rwcomp-instr 'copy-neg reg1 reg2)
919      (or (eq reg1 reg2)      (or (eq reg1 reg2)
920          (math-rwcomp-instr 'copy reg1 reg2)))          (math-rwcomp-instr 'copy reg1 reg2))))
 )  
921    
922  (defun math-rwcomp-reg ()  (defun math-rwcomp-reg ()
923    (prog1    (prog1
924        math-num-regs        math-num-regs
925      (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)      (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
926            math-num-regs (1+ math-num-regs)))            math-num-regs (1+ math-num-regs))))
 )  
927    
928  (defun math-rwcomp-reg-entry (num)  (defun math-rwcomp-reg-entry (num)
929    (nth (1- (- math-num-regs num)) math-regs)    (nth (1- (- math-num-regs num)) math-regs))
 )  
930    
931    
932  (defun math-rwcomp-pattern (expr part &optional not-direct)  (defun math-rwcomp-pattern (expr part &optional not-direct)
# Line 1195  Line 1162 
1162                     (while args                     (while args
1163                       (math-rwcomp-pattern (car (car args)) (cdr (car args)))                       (math-rwcomp-pattern (car (car args)) (cdr (car args)))
1164                       (setq num (1+ num)                       (setq num (1+ num)
1165                             args (cdr args)))))))))                             args (cdr args))))))))))
 )  
1166    
1167  (defun math-rwcomp-best-reg (x)  (defun math-rwcomp-best-reg (x)
1168    (or (and (eq (car-safe x) 'var)    (or (and (eq (car-safe x) 'var)
# Line 1207  Line 1173 
1173                    (progn                    (progn
1174                      (setcar (cdr (cdr entry)) t)                      (setcar (cdr (cdr entry)) t)
1175                      (nth 1 entry)))))                      (nth 1 entry)))))
1176        (math-rwcomp-reg))        (math-rwcomp-reg)))
 )  
1177    
1178  (defun math-rwcomp-all-regs-done (expr)  (defun math-rwcomp-all-regs-done (expr)
1179    (if (Math-primp expr)    (if (Math-primp expr)
# Line 1226  Line 1191 
1191            (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))            (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
1192          (while (and (setq expr (cdr expr))          (while (and (setq expr (cdr expr))
1193                      (math-rwcomp-all-regs-done (car expr))))                      (math-rwcomp-all-regs-done (car expr))))
1194          (null expr))))          (null expr)))))
 )  
1195    
1196  (defun math-rwcomp-no-vars (expr)  (defun math-rwcomp-no-vars (expr)
1197    (if (Math-primp expr)    (if (Math-primp expr)
# Line 1242  Line 1206 
1206           (progn           (progn
1207             (while (and (setq expr (cdr expr))             (while (and (setq expr (cdr expr))
1208                         (math-rwcomp-no-vars (car expr))))                         (math-rwcomp-no-vars (car expr))))
1209             (null expr))))             (null expr)))))
 )  
1210    
1211  (defun math-rwcomp-is-algebraic (expr)  (defun math-rwcomp-is-algebraic (expr)
1212    (if (Math-primp expr)    (if (Math-primp expr)
# Line 1254  Line 1217 
1217           (progn           (progn
1218             (while (and (setq expr (cdr expr))             (while (and (setq expr (cdr expr))
1219                         (math-rwcomp-is-algebraic (car expr))))                         (math-rwcomp-is-algebraic (car expr))))
1220             (null expr))))             (null expr)))))
 )  
1221    
1222  (defun math-rwcomp-is-constrained (expr not-these)  (defun math-rwcomp-is-constrained (expr not-these)
1223    (if (Math-primp expr)    (if (Math-primp expr)
# Line 1266  Line 1228 
1228                 (memq (car expr) not-these)                 (memq (car expr) not-these)
1229                 (and (memq 'commut (get (car expr) 'math-rewrite-props))                 (and (memq 'commut (get (car expr) 'math-rewrite-props))
1230                      (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)                      (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
1231                          (eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))                          (eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))))
 )  
1232    
1233  (defun math-rwcomp-optional-arg (head argp)  (defun math-rwcomp-optional-arg (head argp)
1234    (let ((arg (car argp)))    (let ((arg (car argp)))
# Line 1286  Line 1247 
1247                    (partp (math-rwcomp-optional-arg head part)))                    (partp (math-rwcomp-optional-arg head part)))
1248               (and partp               (and partp
1249                    (setcar argp (math-rwcomp-neg (car part)))                    (setcar argp (math-rwcomp-neg (car part)))
1250                    (math-neg partp))))))                    (math-neg partp)))))))
 )  
1251    
1252  (defun math-rwcomp-neg (expr)  (defun math-rwcomp-neg (expr)
1253    (if (memq (car-safe expr) '(* /))    (if (memq (car-safe expr) '(* /))
# Line 1296  Line 1256 
1256          (if (eq (car-safe (nth 2 expr)) 'var)          (if (eq (car-safe (nth 2 expr)) 'var)
1257              (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))              (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
1258            (math-neg expr)))            (math-neg expr)))
1259      (math-neg expr))      (math-neg expr)))
 )  
1260    
1261  (defun math-rwcomp-assoc-args (expr)  (defun math-rwcomp-assoc-args (expr)
1262    (if (and (eq (car-safe (nth 1 expr)) (car expr))    (if (and (eq (car-safe (nth 1 expr)) (car expr))
# Line 1307  Line 1266 
1266    (if (and (eq (car-safe (nth 2 expr)) (car expr))    (if (and (eq (car-safe (nth 2 expr)) (car expr))
1267             (= (length (nth 2 expr)) 3))             (= (length (nth 2 expr)) 3))
1268        (math-rwcomp-assoc-args (nth 2 expr))        (math-rwcomp-assoc-args (nth 2 expr))
1269      (setq math-args (cons (nth 2 expr) math-args)))      (setq math-args (cons (nth 2 expr) math-args))))
 )  
1270    
1271  (defun math-rwcomp-addsub-args (expr)  (defun math-rwcomp-addsub-args (expr)
1272    (if (memq (car-safe (nth 1 expr)) '(+ -))    (if (memq (car-safe (nth 1 expr)) '(+ -))
# Line 1318  Line 1276 
1276        (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))        (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
1277      (if (eq (car-safe (nth 2 expr)) '+)      (if (eq (car-safe (nth 2 expr)) '+)
1278          (math-rwcomp-addsub-args (nth 2 expr))          (math-rwcomp-addsub-args (nth 2 expr))
1279        (setq math-args (cons (nth 2 expr) math-args))))        (setq math-args (cons (nth 2 expr) math-args)))))
 )  
1280    
1281  (defun math-rwcomp-order (a b)  (defun math-rwcomp-order (a b)
1282    (< (math-rwcomp-priority (car a))    (< (math-rwcomp-priority (car a))
1283       (math-rwcomp-priority (car b)))       (math-rwcomp-priority (car b))))
 )  
1284    
1285  ;;; Order of priority:    0 Constants and other exact matches (first)  ;;; Order of priority:    0 Constants and other exact matches (first)
1286  ;;;                      10 Functions (except below)  ;;;                      10 Functions (except below)
# Line 1355  Line 1311 
1311                      40                      40
1312                    (if (memq 'algebraic props)                    (if (memq 'algebraic props)
1313                        30                        30
1314                      10))))))                      10)))))))
 )  
1315    
1316  (defun math-rwcomp-count-refs (var)  (defun math-rwcomp-count-refs (var)
1317    (let ((count (or (math-expr-contains-count math-pattern var) 0))    (let ((count (or (math-expr-contains-count math-pattern var) 0))
# Line 1374  Line 1329 
1329                                 (or (math-expr-contains-count                                 (or (math-expr-contains-count
1330                                      (nth 2 (nth 1 (car p))) var) 0))))))                                      (nth 2 (nth 1 (car p))) var) 0))))))
1331        (setq p (cdr p)))        (setq p (cdr p)))
1332      count)      count))
 )  
1333    
1334  (defun math-rwcomp-count-pnots (expr)  (defun math-rwcomp-count-pnots (expr)
1335    (if (Math-primp expr)    (if (Math-primp expr)
# Line 1385  Line 1339 
1339        (let ((count 0))        (let ((count 0))
1340          (while (setq expr (cdr expr))          (while (setq expr (cdr expr))
1341            (setq count (+ count (math-rwcomp-count-pnots (car expr)))))            (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
1342          count)))          count))))
 )  
1343    
1344  ;;; In the current implementation, all associative functions must  ;;; In the current implementation, all associative functions must
1345  ;;; also be commutative.  ;;; also be commutative.
# Line 1448  Line 1401 
1401                (if back                (if back
1402                    '(setq btrack (cdr btrack))                    '(setq btrack (cdr btrack))
1403                  'btrack)                  'btrack)
1404                ''((backtrack))))                ''((backtrack)))))
 )  
1405    
1406  ;;; This monstrosity is necessary because the use of static vectors of  ;;; This monstrosity is necessary because the use of static vectors of
1407  ;;; registers makes rewrite rules non-reentrant.  Yucko!  ;;; registers makes rewrite rules non-reentrant.  Yucko!
# Line 1458  Line 1410 
1410          '(setcar rules (quote (nil nil nil no-phase)))          '(setcar rules (quote (nil nil nil no-phase)))
1411          (list 'unwind-protect          (list 'unwind-protect
1412                form                form
1413                '(setcar rules orig)))                '(setcar rules orig))))
 )  
1414    
1415  (setq math-rewrite-phase 1)  (setq math-rewrite-phase 1)
1416    
# Line 1922  Line 1873 
1873                                        
1874                    (t (error "%s is not a valid rewrite opcode" op))))))                    (t (error "%s is not a valid rewrite opcode" op))))))
1875         (setq rules (cdr rules)))         (setq rules (cdr rules)))
1876       result))       result)))
 )  
1877    
1878  (defun math-rwapply-neg (expr)  (defun math-rwapply-neg (expr)
1879    (if (and (consp expr)    (if (and (consp expr)
# Line 1935  Line 1885 
1885                    (math-neg (nth 1 expr))                    (math-neg (nth 1 expr))
1886                  (list '* -1 (nth 1 expr)))                  (list '* -1 (nth 1 expr)))
1887                (nth 2 expr)))                (nth 2 expr)))
1888      (math-neg expr))      (math-neg expr)))
 )  
1889    
1890  (defun math-rwapply-inv (expr)  (defun math-rwapply-inv (expr)
1891    (if (and (Math-integerp expr)    (if (and (Math-integerp expr)
1892             calc-prefer-frac)             calc-prefer-frac)
1893        (math-make-frac 1 expr)        (math-make-frac 1 expr)
1894      (list '/ 1 expr))      (list '/ 1 expr)))
 )  
1895    
1896  (defun math-rwapply-replace-regs (expr)  (defun math-rwapply-replace-regs (expr)
1897    (cond ((Math-primp expr)    (cond ((Math-primp expr)
# Line 2049  Line 1997 
1997                 (aref regs (nth 1 (nth 1 expr)))                 (aref regs (nth 1 (nth 1 expr)))
1998               (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs               (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
1999                                                (cdr (nth 1 expr)))))))                                                (cdr (nth 1 expr)))))))
2000          (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))          (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
 )  
2001    
2002  (defun math-rwapply-reg-looks-negp (expr)  (defun math-rwapply-reg-looks-negp (expr)
2003    (if (eq (car-safe expr) 'calcFunc-register)    (if (eq (car-safe expr) 'calcFunc-register)
2004        (math-looks-negp (aref regs (nth 1 expr)))        (math-looks-negp (aref regs (nth 1 expr)))
2005      (if (memq (car-safe expr) '(* /))      (if (memq (car-safe expr) '(* /))
2006          (or (math-rwapply-reg-looks-negp (nth 1 expr))          (or (math-rwapply-reg-looks-negp (nth 1 expr))
2007              (math-rwapply-reg-looks-negp (nth 2 expr)))))              (math-rwapply-reg-looks-negp (nth 2 expr))))))
 )  
2008    
2009  (defun math-rwapply-reg-neg (expr)  ; expr must satisfy rwapply-reg-looks-negp  (defun math-rwapply-reg-neg (expr)  ; expr must satisfy rwapply-reg-looks-negp
2010    (if (eq (car expr) 'calcFunc-register)    (if (eq (car expr) 'calcFunc-register)
# Line 2069  Line 2015 
2015                                           (nth 2 expr)))                                           (nth 2 expr)))
2016        (math-rwapply-replace-regs (list (car expr)        (math-rwapply-replace-regs (list (car expr)
2017                                         (nth 1 expr)                                         (nth 1 expr)
2018                                         (math-rwapply-reg-neg (nth 2 expr))))))                                         (math-rwapply-reg-neg (nth 2 expr)))))))
 )  
2019    
2020  (defun math-rwapply-remember (old new)  (defun math-rwapply-remember (old new)
2021    (let ((varval (symbol-value (nth 2 (car ruleset))))    (let ((varval (symbol-value (nth 2 (car ruleset))))
# Line 2089  Line 2034 
2034                                      (list (list 'same 0 1)                                      (list (list 'same 0 1)
2035                                            (list 'done new nil))                                            (list 'done new nil))
2036                                      nil nil)                                      nil nil)
2037                                (cdr rules))))))                                (cdr rules)))))))
 )  
   
2038    
2039    ;;; calc-rewr.el ends here
2040    
2041    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

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