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 |
;; Maintainer: Colin Walters <walters@debian.org> |
;; Maintainers: D. Goel <deego@gnufans.org> |
7 |
|
;; Colin Walters <walters@debian.org> |
8 |
|
|
9 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
10 |
|
|
1442 |
btrack nil) |
btrack nil) |
1443 |
(aset regs 0 expr) |
(aset regs 0 expr) |
1444 |
(while pc |
(while pc |
1445 |
|
|
1446 |
(and tracing |
(and tracing |
1447 |
(progn (terpri) (princ (car pc)) |
(progn (terpri) (princ (car pc)) |
1448 |
(if (and (natnump (nth 1 (car pc))) |
(if (and (natnump (nth 1 (car pc))) |
1449 |
(< (nth 1 (car pc)) (length regs))) |
(< (nth 1 (car pc)) (length regs))) |
1450 |
(princ (format "\n part = %s" |
(princ (format "\n part = %s" |
1451 |
(aref regs (nth 1 (car pc)))))))) |
(aref regs (nth 1 (car pc)))))))) |
1452 |
|
|
1453 |
(cond ((eq (setq op (car (setq inst (car pc)))) 'func) |
(cond ((eq (setq op (car (setq inst (car pc)))) 'func) |
1454 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
1455 |
(eq (car part) |
(eq (car part) |
1462 |
(not (or inst part)))) |
(not (or inst part)))) |
1463 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1464 |
(math-rwfail))) |
(math-rwfail))) |
1465 |
|
|
1466 |
((eq op 'same) |
((eq op 'same) |
1467 |
(if (or (equal (setq part (aref regs (nth 1 inst))) |
(if (or (equal (setq part (aref regs (nth 1 inst))) |
1468 |
(setq mark (aref regs (nth 2 inst)))) |
(setq mark (aref regs (nth 2 inst)))) |
1469 |
(Math-equal part mark)) |
(Math-equal part mark)) |
1470 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1471 |
(math-rwfail))) |
(math-rwfail))) |
1472 |
|
|
1473 |
((and (eq op 'try) |
((and (eq op 'try) |
1474 |
calc-matrix-mode |
calc-matrix-mode |
1475 |
(not (eq calc-matrix-mode 'scalar)) |
(not (eq calc-matrix-mode 'scalar)) |
1487 |
(aset mark 1 (cdr part))) |
(aset mark 1 (cdr part))) |
1488 |
(aset mark 0 (cdr part)) |
(aset mark 0 (cdr part)) |
1489 |
(aset mark 2 0)) |
(aset mark 2 0)) |
1490 |
|
|
1491 |
((eq op 'try) |
((eq op 'try) |
1492 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
1493 |
(memq (car part) (nth 2 inst)) |
(memq (car part) (nth 2 inst)) |
1545 |
(aset regs (nth 4 inst) part) |
(aset regs (nth 4 inst) part) |
1546 |
(aset mark 2 3)) |
(aset mark 2 3)) |
1547 |
(math-rwfail)))) |
(math-rwfail)))) |
1548 |
|
|
1549 |
((eq op 'try2) |
((eq op 'try2) |
1550 |
(setq part (nth 1 inst) ; try instr |
(setq part (nth 1 inst) ; try instr |
1551 |
mark (nth 3 part) |
mark (nth 3 part) |
1588 |
(car (aref mark 1))) |
(car (aref mark 1))) |
1589 |
((eq op 3) (nth 5 part)) |
((eq op 3) (nth 5 part)) |
1590 |
(t (aref mark 1))))) |
(t (aref mark 1))))) |
1591 |
|
|
1592 |
((eq op 'select) |
((eq op 'select) |
1593 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1594 |
(if (and (consp (setq part (aref regs (nth 1 inst)))) |
(if (and (consp (setq part (aref regs (nth 1 inst)))) |
1597 |
(if math-rewrite-selections |
(if math-rewrite-selections |
1598 |
(math-rwfail) |
(math-rwfail) |
1599 |
(aset regs (nth 2 inst) part)))) |
(aset regs (nth 2 inst) part)))) |
1600 |
|
|
1601 |
((eq op 'same-neg) |
((eq op 'same-neg) |
1602 |
(if (or (equal (setq part (aref regs (nth 1 inst))) |
(if (or (equal (setq part (aref regs (nth 1 inst))) |
1603 |
(setq mark (math-neg |
(setq mark (math-neg |
1605 |
(Math-equal part mark)) |
(Math-equal part mark)) |
1606 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1607 |
(math-rwfail))) |
(math-rwfail))) |
1608 |
|
|
1609 |
((eq op 'backtrack) |
((eq op 'backtrack) |
1610 |
(setq inst (car (car btrack)) ; "try" or "alt" instr |
(setq inst (car (car btrack)) ; "try" or "alt" instr |
1611 |
pc (cdr (car btrack)) |
pc (cdr (car btrack)) |
1676 |
((eq op 4) |
((eq op 4) |
1677 |
(setq btrack (cdr btrack))) |
(setq btrack (cdr btrack))) |
1678 |
(t (math-rwfail t)))) |
(t (math-rwfail t)))) |
1679 |
|
|
1680 |
((eq op 'integer) |
((eq op 'integer) |
1681 |
(if (Math-integerp (setq part (aref regs (nth 1 inst)))) |
(if (Math-integerp (setq part (aref regs (nth 1 inst)))) |
1682 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1686 |
(if (Math-integerp part) |
(if (Math-integerp part) |
1687 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1688 |
(math-rwfail))))) |
(math-rwfail))))) |
1689 |
|
|
1690 |
((eq op 'real) |
((eq op 'real) |
1691 |
(if (Math-realp (setq part (aref regs (nth 1 inst)))) |
(if (Math-realp (setq part (aref regs (nth 1 inst)))) |
1692 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1696 |
(if (Math-realp part) |
(if (Math-realp part) |
1697 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1698 |
(math-rwfail))))) |
(math-rwfail))))) |
1699 |
|
|
1700 |
((eq op 'constant) |
((eq op 'constant) |
1701 |
(if (math-constp (setq part (aref regs (nth 1 inst)))) |
(if (math-constp (setq part (aref regs (nth 1 inst)))) |
1702 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1706 |
(if (math-constp part) |
(if (math-constp part) |
1707 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1708 |
(math-rwfail))))) |
(math-rwfail))))) |
1709 |
|
|
1710 |
((eq op 'negative) |
((eq op 'negative) |
1711 |
(if (math-looks-negp (setq part (aref regs (nth 1 inst)))) |
(if (math-looks-negp (setq part (aref regs (nth 1 inst)))) |
1712 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1716 |
(if (math-looks-negp part) |
(if (math-looks-negp part) |
1717 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1718 |
(math-rwfail))))) |
(math-rwfail))))) |
1719 |
|
|
1720 |
((eq op 'rel) |
((eq op 'rel) |
1721 |
(setq part (math-compare (aref regs (nth 1 inst)) |
(setq part (math-compare (aref regs (nth 1 inst)) |
1722 |
(aref regs (nth 3 inst))) |
(aref regs (nth 3 inst))) |
1741 |
(memq part '(0 1)))) |
(memq part '(0 1)))) |
1742 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1743 |
(math-rwfail))) |
(math-rwfail))) |
1744 |
|
|
1745 |
((eq op 'func-def) |
((eq op 'func-def) |
1746 |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
(if (and (consp (setq part (aref regs (car (cdr inst))))) |
1747 |
(eq (car part) |
(eq (car part) |
1831 |
(math-rwapply-replace-regs (nth 1 inst))))) |
(math-rwapply-replace-regs (nth 1 inst))))) |
1832 |
(setq pc (cdr pc)) |
(setq pc (cdr pc)) |
1833 |
(math-rwfail))) |
(math-rwfail))) |
1834 |
|
|
1835 |
((eq op 'let) |
((eq op 'let) |
1836 |
(aset regs (nth 1 inst) |
(aset regs (nth 1 inst) |
1837 |
(math-rweval |
(math-rweval |
1838 |
(math-normalize |
(math-normalize |
1839 |
(math-rwapply-replace-regs (nth 2 inst))))) |
(math-rwapply-replace-regs (nth 2 inst))))) |
1840 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1841 |
|
|
1842 |
((eq op 'copy) |
((eq op 'copy) |
1843 |
(aset regs (nth 2 inst) (aref regs (nth 1 inst))) |
(aset regs (nth 2 inst) (aref regs (nth 1 inst))) |
1844 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1845 |
|
|
1846 |
((eq op 'copy-neg) |
((eq op 'copy-neg) |
1847 |
(aset regs (nth 2 inst) |
(aset regs (nth 2 inst) |
1848 |
(math-rwapply-neg (aref regs (nth 1 inst)))) |
(math-rwapply-neg (aref regs (nth 1 inst)))) |
1849 |
(setq pc (cdr pc))) |
(setq pc (cdr pc))) |
1850 |
|
|
1851 |
((eq op 'alt) |
((eq op 'alt) |
1852 |
(setq btrack (cons pc btrack) |
(setq btrack (cons pc btrack) |
1853 |
pc (nth 1 inst))) |
pc (nth 1 inst))) |
1854 |
|
|
1855 |
((eq op 'end-alt) |
((eq op 'end-alt) |
1856 |
(while (and btrack (not (eq (car btrack) (nth 1 inst)))) |
(while (and btrack (not (eq (car btrack) (nth 1 inst)))) |
1857 |
(setq btrack (cdr btrack))) |
(setq btrack (cdr btrack))) |
1858 |
(setq btrack (cdr btrack) |
(setq btrack (cdr btrack) |
1859 |
pc (cdr pc))) |
pc (cdr pc))) |
1860 |
|
|
1861 |
((eq op 'done) |
((eq op 'done) |
1862 |
(setq result (math-rwapply-replace-regs (nth 1 inst))) |
(setq result (math-rwapply-replace-regs (nth 1 inst))) |
1863 |
(if (or (and (eq (car-safe result) '+) |
(if (or (and (eq (car-safe result) '+) |
1877 |
(if part (math-rwapply-remember expr result)) |
(if part (math-rwapply-remember expr result)) |
1878 |
(setq rules nil)) |
(setq rules nil)) |
1879 |
(setq pc nil)) |
(setq pc nil)) |
1880 |
|
|
1881 |
(t (error "%s is not a valid rewrite opcode" op)))))) |
(t (error "%s is not a valid rewrite opcode" op)))))) |
1882 |
(setq rules (cdr rules))) |
(setq rules (cdr rules))) |
1883 |
result))) |
result))) |