/[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.4 by pj, Fri Nov 23 06:06:41 2001 UTC revision 1.4.4.1 by miles, Fri Apr 4 06:20:15 2003 UTC
# Line 3  Line 3 
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    
# Line 1441  Line 1442 
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)
# Line 1461  Line 1462 
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))
# Line 1486  Line 1487 
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))
# Line 1544  Line 1545 
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)
# Line 1587  Line 1588 
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))))
# Line 1596  Line 1597 
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
# Line 1604  Line 1605 
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))
# Line 1675  Line 1676 
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))
# Line 1685  Line 1686 
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))
# Line 1695  Line 1696 
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))
# Line 1705  Line 1706 
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))
# Line 1715  Line 1716 
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)))
# Line 1740  Line 1741 
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)
# Line 1830  Line 1831 
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) '+)
# Line 1876  Line 1877 
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)))

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.4.4.1

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