Function: math-rwcomp-pattern
math-rwcomp-pattern is a byte-compiled function defined in
calc-rewr.el.gz.
Signature
(math-rwcomp-pattern EXPR PART &optional NOT-DIRECT)
Source Code
;; Defined in /usr/src/emacs/lisp/calc/calc-rewr.el.gz
(defun math-rwcomp-pattern (expr part &optional not-direct)
(cond ((or (math-rwcomp-no-vars expr)
(and (eq (car expr) 'calcFunc-quote)
(= (length expr) 2)
(setq expr (nth 1 expr))))
(if (eq (car-safe expr) 'calcFunc-register)
(math-rwcomp-same-instr part (nth 1 expr) nil)
(let ((reg (math-rwcomp-reg)))
(setcar (nthcdr 3 (car math-regs)) expr)
(math-rwcomp-same-instr part reg nil))))
((eq (car expr) 'var)
(let ((entry (assq (nth 2 expr) math-regs)))
(if entry
(math-rwcomp-same-instr part (nth 1 entry) nil)
(if not-direct
(let ((reg (math-rwcomp-reg)))
(math-rwcomp-pattern expr reg)
(math-rwcomp-copy-instr part reg nil))
(if (setq entry (assq (nth 2 expr) math-aliased-vars))
(progn
(setcar (math-rwcomp-reg-entry (nth 1 entry))
(nth 2 expr))
(setcar entry nil)
(math-rwcomp-copy-instr part (nth 1 entry) nil))
(math-rwcomp-bind-var part expr))))))
((and (eq (car expr) 'calcFunc-select)
(= (length expr) 2))
(let ((reg (math-rwcomp-reg)))
(math-rwcomp-instr 'select part reg)
(math-rwcomp-pattern (nth 1 expr) reg)))
((and (eq (car expr) 'calcFunc-opt)
(memq (length expr) '(2 3)))
(error "opt( ) occurs in context where it is not allowed"))
((eq (car expr) 'neg)
(if (eq (car (nth 1 expr)) 'var)
(let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
(if entry
(math-rwcomp-same-instr part (nth 1 entry) t)
(if math-copy-neg
(let ((reg (math-rwcomp-best-reg (nth 1 expr))))
(math-rwcomp-copy-instr part reg t)
(math-rwcomp-pattern (nth 1 expr) reg))
(setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
(math-rwcomp-pattern (nth 1 expr) part))))
(if (math-rwcomp-is-algebraic (nth 1 expr))
(math-rwcomp-cond-instr (list 'calcFunc-eq
(math-rwcomp-register-expr part)
expr))
(let ((reg (math-rwcomp-reg)))
(math-rwcomp-instr 'func part 'neg reg)
(math-rwcomp-pattern (nth 1 expr) reg)))))
((and (eq (car expr) 'calcFunc-apply)
(= (length expr) 3))
(let ((reg1 (math-rwcomp-reg))
(reg2 (math-rwcomp-reg)))
(math-rwcomp-instr 'apply part reg1 reg2)
(math-rwcomp-pattern (nth 1 expr) reg1)
(math-rwcomp-pattern (nth 2 expr) reg2)))
((and (eq (car expr) 'calcFunc-cons)
(= (length expr) 3))
(let ((reg1 (math-rwcomp-reg))
(reg2 (math-rwcomp-reg)))
(math-rwcomp-instr 'cons part reg1 reg2)
(math-rwcomp-pattern (nth 1 expr) reg1)
(math-rwcomp-pattern (nth 2 expr) reg2)))
((and (eq (car expr) 'calcFunc-rcons)
(= (length expr) 3))
(let ((reg1 (math-rwcomp-reg))
(reg2 (math-rwcomp-reg)))
(math-rwcomp-instr 'rcons part reg1 reg2)
(math-rwcomp-pattern (nth 1 expr) reg1)
(math-rwcomp-pattern (nth 2 expr) reg2)))
((and (eq (car expr) 'calcFunc-condition)
(>= (length expr) 3))
(math-rwcomp-pattern (nth 1 expr) part)
(setq expr (cdr expr))
(while (setq expr (cdr expr))
(let ((cond (math-flatten-lands (car expr))))
(while cond
(if (math-rwcomp-all-regs-done (car cond))
(math-rwcomp-cond-instr (car cond))
(setq math-conds (cons (car cond) math-conds)))
(setq cond (cdr cond))))))
((and (eq (car expr) 'calcFunc-pand)
(= (length expr) 3))
(math-rwcomp-pattern (nth 1 expr) part)
(math-rwcomp-pattern (nth 2 expr) part))
((and (eq (car expr) 'calcFunc-por)
(= (length expr) 3))
(math-rwcomp-instr 'alt nil nil [nil nil 4])
(let ((math-conds nil)
(head math-prog-last)
(mark math-bound-vars)
(math-copy-neg t))
(math-rwcomp-pattern (nth 1 expr) part t)
(let ((amark math-aliased-vars)
(math-aliased-vars math-aliased-vars)
(tail math-prog-last)
(p math-bound-vars)
entry)
(while (not (eq p mark))
(setq entry (assq (car p) math-regs)
math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
math-aliased-vars)
p (cdr p))
(setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
(setcar (cdr (car head)) (cdr head))
(setcdr head nil)
(setq math-prog-last head)
(math-rwcomp-pattern (nth 2 expr) part)
(math-rwcomp-instr 'same 0 0)
(setcdr tail math-prog-last)
(setq p math-aliased-vars)
(while (not (eq p amark))
(if (car (car p))
(setcar (math-rwcomp-reg-entry (nth 1 (car p)))
(car (car p))))
(setq p (cdr p)))))
(math-rwcomp-do-conditions))
((and (eq (car expr) 'calcFunc-pnot)
(= (length expr) 2))
(math-rwcomp-instr 'alt nil nil [nil nil 4])
(let ((head math-prog-last)
(mark math-bound-vars))
(math-rwcomp-pattern (nth 1 expr) part)
(math-rwcomp-unbind-vars mark)
(math-rwcomp-instr 'end-alt head)
(math-rwcomp-instr 'backtrack)
(setcar (cdr (car head)) (cdr head))
(setcdr head nil)
(setq math-prog-last head)))
(t (let ((props (get (car expr) 'math-rewrite-props)))
(if (and (eq (car expr) 'calcFunc-plain)
(= (length expr) 2)
(not (math-primp (nth 1 expr))))
(setq expr (nth 1 expr))) ; but "props" is still nil
(if (and (memq 'algebraic props)
(math-rwcomp-is-algebraic expr))
(math-rwcomp-cond-instr (list 'calcFunc-eq
(math-rwcomp-register-expr part)
expr))
(if (and (memq 'commut props)
(= (length expr) 3))
(let ((arg1 (nth 1 expr))
(arg2 (nth 2 expr))
try1 def code head (flip nil))
(if (eq (car expr) '-)
(setq arg2 (math-rwcomp-neg arg2)))
(setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
(or (math-rwcomp-order arg1 arg2)
(setq def arg1 arg1 arg2 arg2 def flip t))
(if (math-rwcomp-optional-arg (car expr) arg1)
(error "Too many opt( ) arguments in this context"))
(setq def (math-rwcomp-optional-arg (car expr) arg2)
head (if (memq (car expr) '(+ -))
'(+ -)
(if (eq (car expr) '*)
'(* /)
(list (car expr))))
code (if (math-rwcomp-is-constrained
(car arg1) head)
(if (math-rwcomp-is-constrained
(car arg2) head)
0 1)
2))
(math-rwcomp-multi-instr (and def (list def))
'try part head
(vector nil nil nil code flip)
(cdr arg1))
(setq try1 (car math-prog-last))
(math-rwcomp-pattern (car arg1) (cdr arg1))
(math-rwcomp-instr 'try2 try1 (cdr arg2))
(if (and (= part 0) (not def) (not math-rewrite-whole)
(not (eq math-rhs t))
(setq def (get (car expr)
'math-rewrite-default)))
(let ((reg1 (math-rwcomp-reg))
(reg2 (math-rwcomp-reg)))
(if (= (aref (nth 3 try1) 3) 0)
(aset (nth 3 try1) 3 1))
(math-rwcomp-instr 'try (cdr arg2)
(if (equal head '(* /))
'(*) head)
(vector nil nil nil
(if (= code 0)
1 2)
nil)
reg1 def)
(setq try1 (car math-prog-last))
(math-rwcomp-pattern (car arg2) reg1)
(math-rwcomp-instr 'try2 try1 reg2)
(setq math-rhs (list (if (eq (car expr) '-)
'+ (car expr))
math-rhs
(list 'calcFunc-register
reg2))))
(math-rwcomp-pattern (car arg2) (cdr arg2))))
(let* ((args (mapcar (lambda (x)
(cons x (math-rwcomp-best-reg x)))
(cdr expr)))
(args2 (copy-sequence args))
(argp (reverse args2))
(defs nil)
(num 1))
(while argp
(let ((def (math-rwcomp-optional-arg (car expr)
(car argp))))
(if def
(progn
(setq args2 (delq (car argp) args2)
defs (cons (cons def (cdr (car argp)))
defs))
(math-rwcomp-multi-instr
(mapcar 'cdr args2)
(if (or (and (memq 'unary1 props)
(= (length args2) 1)
(eq (car args2) (car args)))
(and (memq 'unary2 props)
(= (length args) 2)
(eq (car args2) (nth 1 args))))
'func-opt
'func-def)
part (car expr)
defs))))
(setq argp (cdr argp)))
(math-rwcomp-multi-instr (mapcar 'cdr args)
'func part (car expr))
(setq args (sort args 'math-rwcomp-order))
(while args
(math-rwcomp-pattern (car (car args)) (cdr (car args)))
(setq num (1+ num)
args (cdr args))))))))))