[Wisp-cvs] wisp/tools worth,1.33,1.34

[<di...@us...>]

Update of /cvsroot/wisp/wisp/tools
In directory usw-pr-cvs1:/tmp/cvs-serv29289/tools

Modified Files:
	worth 
Log Message:
Dropped the (binary ...) Worth construct.

Index: worth
===================================================================
RCS file: /cvsroot/wisp/wisp/tools/worth,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- worth	26 Sep 2002 18:22:38 -0000	1.33
+++ worth	26 Sep 2002 18:22:47 -0000	1.34
@@ -640,29 +640,6 @@
                                              pos
                                              neg)
                                            suppress?)))
-                           ((binary) (if (not (cons? (cdr word)))
-                                       (raise 'worth-word? word))
-                                     (my (oper . code) (cdr word)
-                                       (if (and (cons? regstack)
-                                                (integer? (car regstack))
-                                                (cons? (cdr regstack))
-                                                (integer? (cadr regstack)))
-                                         (my (b a . rest) regstack
-                                           (set! regstack
-                                             (cons
-                                               (case oper
-                                                 ((+) (+ a b))
-                                                 ((-) (- a b))
-                                                 ((*) (* a b))
-                                                 ((/) (quotient a b))
-                                                 ((mod) (remainder a b))
-                                                 ((lshift) (<< (reduce-to-utetra a)
-                                                               b))
-                                                 ((rshift) (>> (reduce-to-utetra a)
-                                                               b))
-                                                 (else (raise 'binary-operator? oper)))
-                                               rest)))
-                                         (process-word-list code #t))))
                            ((conform) (my reqs (cdr word)
                                         (cond
                                           ((null? reqs) (flush))
@@ -716,6 +693,31 @@
                            (else (raise 'worth-word? word))))
                        (else
                          (cond
+                           ((and (memq word '(+ - * / mod lshift rshift))
+                                 (cons? regstack)
+                                 (integer? (car regstack))
+                                 (cons? (cdr regstack))
+                                 (integer? (cadr regstack)))
+                             (case word
+                               ((+ - * / mod lshift rshift)
+                                 (my (b a . rest) regstack
+                                   (set! regstack
+                                     (cons
+                                       (case oper
+                                         ((+) (+ a b))
+                                         ((-) (- a b))
+                                         ((*) (* a b))
+                                         ((/) (quotient a b))
+                                         ((mod) (remainder a b))
+                                         ((lshift) (reduce-to-utetra
+                                                     (<< (reduce-to-utetra a)
+                                                         b)))
+                                         ((rshift) (>> (reduce-to-utetra a)
+                                                       b))
+                                         (else (raise 'binary-operator? oper)))
+                                       rest))))
+                               (else
+                                 (raise 'huh? word))))
                            ((eq? (word-class word) 'broketed)
                              (cons! synstack word))
                            ((assq word macro-box[])