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[])
|
