Function: math-compile-rewrites
math-compile-rewrites is an autoloaded and byte-compiled function
defined in calc-rewr.el.gz.
Signature
(math-compile-rewrites RULES &optional NAME)
Source Code
;; Defined in /usr/src/emacs/lisp/calc/calc-rewr.el.gz
(defun math-compile-rewrites (rules &optional name)
(if (eq (car-safe rules) 'var)
(let ((prop (get (nth 2 rules) 'math-rewrite-cache))
(math-import-list nil)
(math-make-import-list t)
p)
(or (calc-var-value (nth 2 rules))
(error "Rules variable %s has no stored value" (nth 1 rules)))
(or prop
(put (nth 2 rules) 'math-rewrite-cache
(setq prop (list (list (cons (nth 2 rules) nil))))))
(setq p (car prop))
(while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
(setq p (cdr p)))
(or (null p)
(progn
(message "Compiling rule set %s..." (nth 1 rules))
(setcdr prop (math-compile-rewrites
(symbol-value (nth 2 rules))
(nth 2 rules)))
(message "Compiling rule set %s...done" (nth 1 rules))
(setcar prop (cons (cons (nth 2 rules)
(symbol-value (nth 2 rules)))
math-import-list))))
(cdr prop))
(if (or (not (eq (car-safe rules) 'vec))
(and (memq (length rules) '(3 4))
(let ((p rules))
(while (and (setq p (cdr p))
(memq (car-safe (car p))
'(vec
calcFunc-assign
calcFunc-condition
calcFunc-import
calcFunc-phase
calcFunc-schedule
calcFunc-iterations))))
p)))
(setq rules (list rules))
(setq rules (cdr rules)))
(if (assq 'calcFunc-import rules)
(let ((pp (setq rules (copy-sequence rules)))
p part)
(while (setq p (car (cdr pp)))
(if (eq (car-safe p) 'calcFunc-import)
(progn
(setcdr pp (cdr (cdr pp)))
(or (and (eq (car-safe (nth 1 p)) 'var)
(setq part (calc-var-value (nth 2 (nth 1 p))))
(memq (car-safe part) '(vec
calcFunc-assign
calcFunc-condition)))
(error "Argument of import() must be a rules variable"))
(if math-make-import-list
(setq math-import-list
(cons (cons (nth 2 (nth 1 p))
(symbol-value (nth 2 (nth 1 p))))
math-import-list)))
(while (setq p (cdr (cdr p)))
(or (cdr p)
(error "import() must have odd number of arguments"))
(setq part (math-rwcomp-substitute part
(car p) (nth 1 p))))
(if (eq (car-safe part) 'vec)
(setq part (cdr part))
(setq part (list part)))
(setcdr pp (append part (cdr pp))))
(setq pp (cdr pp))))))
(let ((rule-set nil)
(all-heads nil)
(nil-rules nil)
;; (rule-count 0)
(math-schedule nil)
(math-iterations nil)
(math-phases nil)
(math-all-phases nil)
(math-remembering nil)
math-pattern math-rhs math-conds)
(while rules
(cond
((and (eq (car-safe (car rules)) 'calcFunc-iterations)
(= (length (car rules)) 2))
(or (integerp (nth 1 (car rules)))
(equal (nth 1 (car rules)) '(var inf var-inf))
(equal (nth 1 (car rules)) '(neg (var inf var-inf)))
(error "Invalid argument for iterations(n)"))
(or math-iterations
(setq math-iterations (nth 1 (car rules)))))
((eq (car-safe (car rules)) 'calcFunc-schedule)
(or math-schedule
(setq math-schedule (math-parse-schedule (cdr (car rules))))))
((eq (car-safe (car rules)) 'calcFunc-phase)
(setq math-phases (cdr (car rules)))
(if (equal math-phases '((var all var-all)))
(setq math-phases nil))
(let ((p math-phases))
(while p
(or (integerp (car p))
(error "Phase numbers must be small integers"))
(or (memq (car p) math-all-phases)
(setq math-all-phases (cons (car p) math-all-phases)))
(setq p (cdr p)))))
((or (and (eq (car-safe (car rules)) 'vec)
(cdr (cdr (car rules)))
(not (nthcdr 4 (car rules)))
(setq math-conds (nth 3 (car rules))
math-rhs (nth 2 (car rules))
math-pattern (nth 1 (car rules))))
(progn
(setq math-conds nil
math-pattern (car rules))
(while (and (eq (car-safe math-pattern) 'calcFunc-condition)
(= (length math-pattern) 3))
(let ((cond (nth 2 math-pattern)))
(setq math-conds (if math-conds
(list 'calcFunc-land math-conds cond)
cond)
math-pattern (nth 1 math-pattern))))
(and (eq (car-safe math-pattern) 'calcFunc-assign)
(= (length math-pattern) 3)
(setq math-rhs (nth 2 math-pattern)
math-pattern (nth 1 math-pattern)))))
(let* ((math-prog (list nil))
(math-prog-last math-prog)
(math-num-regs 1)
(math-regs (list (list nil 0 nil nil)))
(math-bound-vars nil)
(math-aliased-vars nil)
(math-copy-neg nil))
(setq math-conds (and math-conds (math-flatten-lands math-conds)))
(math-rwcomp-pattern math-pattern 0)
(while math-conds
(let ((expr (car math-conds)))
(setq math-conds (cdr math-conds))
(math-rwcomp-cond-instr expr)))
(math-rwcomp-instr 'done
(if (eq math-rhs t)
(cons 'vec
(delq
nil
(nreverse
(mapcar
(lambda (v)
(and (car v)
(list
'calcFunc-assign
(math-build-var-name
(car v))
(math-rwcomp-register-expr
(nth 1 v)))))
math-regs))))
(math-rwcomp-match-vars math-rhs))
math-remembering)
(setq math-prog (cdr math-prog))
(let* ((heads (math-rewrite-heads math-pattern))
(rule (list (vconcat
(nreverse
(mapcar (lambda (x) (nth 3 x))
math-regs)))
math-prog
heads
math-phases))
(head (and (not (Math-primp math-pattern))
(not (and (eq (car (car math-prog)) 'try)
(nth 5 (car math-prog))))
(not (memq (car (car math-prog)) '(func-opt
apply
select
alt)))
(if (memq (car (car math-prog)) '(func
func-def))
(nth 2 (car math-prog))
(if (eq (car math-pattern) 'calcFunc-quote)
(car-safe (nth 1 math-pattern))
(car math-pattern))))))
(let (found)
(while heads
(if (setq found (assq (car heads) all-heads))
(setcdr found (1+ (cdr found)))
(setq all-heads (cons (cons (car heads) 1) all-heads)))
(setq heads (cdr heads))))
(if (eq head '-) (setq head '+))
(if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
(if head
(progn
(nconc (or (assq head rule-set)
(car (setq rule-set (cons (cons head
(copy-sequence
nil-rules))
rule-set))))
(list rule))
(if (eq head '*)
(nconc (or (assq '/ rule-set)
(car (setq rule-set (cons (cons
'/
(copy-sequence
nil-rules))
rule-set))))
(list rule))))
(setq nil-rules (nconc nil-rules (list rule)))
(let ((ptr rule-set))
(while ptr
(nconc (car ptr) (list rule))
(setq ptr (cdr ptr))))))))
(t
(error "Rewrite rule set must be a vector of A := B rules")))
(setq rules (cdr rules)))
(if nil-rules
(setq rule-set (cons (cons nil nil-rules) rule-set)))
(setq all-heads (mapcar #'car
(sort all-heads (lambda (x y)
(< (cdr x) (cdr y))))))
(let ((set rule-set)
rule heads ptr)
(while set
(setq rule (cdr (car set)))
(while rule
(if (consp (setq heads (nth 2 (car rule))))
(progn
(setq heads (delq (car (car set)) heads)
ptr all-heads)
(while (and ptr (not (memq (car ptr) heads)))
(setq ptr (cdr ptr)))
(setcar (nthcdr 2 (car rule)) (car ptr))))
(setq rule (cdr rule)))
(setq set (cdr set))))
(let ((plus (assq '+ rule-set)))
(if plus
(setq rule-set (cons (cons '- (cdr plus)) rule-set))))
(cons (list 'schedule math-iterations name
(or math-schedule
(sort math-all-phases '<)
(list 1)))
rule-set))))