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. |
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) |
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 |
|
|
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") |
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 |
|
|
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) |
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) |
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) |
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 |
|
|
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 |
|
|
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) |
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) |
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 |
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) |
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) |
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) |
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)) |
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) |
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)) |
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)) |
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) |
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) |
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) |
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) |
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) |
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) |
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))) |
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) '(* /)) |
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)) |
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)) '(+ -)) |
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) |
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)) |
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) |
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. |
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! |
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 |
|
|
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) |
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) |
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) |
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)))) |
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 |
|
|