Thread: [Wisp-cvs] wisp/tools worth,1.21,1.22
Status: Alpha
Brought to you by:
digg
Menu
▾
▴
wisp-cvs
|
From: <di...@us...> - 2002-09-04 14:25:44
|
Update of /cvsroot/wisp/wisp/tools
In directory usw-pr-cvs1:/tmp/cvs-serv28382/tools
Modified Files:
worth
Log Message:
Improved Worth's comparison handling.
Index: worth
===================================================================
RCS file: /cvsroot/wisp/wisp/tools/worth,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- worth 31 Aug 2002 14:29:22 -0000 1.21
+++ worth 4 Sep 2002 14:25:41 -0000 1.22
@@ -18,6 +18,63 @@
(define builtin-words
'(< <= <> = > >= begin else if then u< u<= u> u>= until))
+(define (other op c)
+ (cond
+ ((eq? op (car c)) (cdr c))
+ ((eq? op (cdr c)) (car c))
+ (else #f)))
+
+(define (negate-comparison op)
+ (any (cut other op <>)
+ '((= . <>)
+ (< . >=)
+ (> . <=)
+ (u< . u>=)
+ (u> . u<=))))
+
+(define (reverse-comparison op)
+ (any (cut other op <>)
+ '((= . =)
+ (<> . <>)
+ (< . >)
+ (<= . >=)
+ (u< . u>)
+ (u<= . u>=))))
+
+(define (jumpify-comparison op)
+ (cdr (assq op '((= . \=?j)
+ (<> . \<>?j)
+ (< . \<?j)
+ (<= . \<=?j)
+ (> . \>?j)
+ (>= . \>=?j)
+ (u< . \u<?j)
+ (u<= . \u<=?j)
+ (u> . \u>?j)
+ (u>= . \u>=?j)
+ (0= . \0=?j)
+ (0<> . \0<>?j)
+ (0< . \0<?j)
+ (0<= . \0<=?j)
+ (0> . \0>?j)
+ (0>= . \0>=?j)
+ (0u< . \0u<?j)
+ (0u<= . \0u<=?j)
+ (0u> . \0u>?j)
+ (0u>= . \0u>=?j)))))
+
+(define (zerofy-comparison op)
+ (cdr (assq op '((= . 0=)
+ (<> . 0<>)
+ (< . 0<)
+ (<= . 0<=)
+ (> . 0>)
+ (>= . 0>=)
+ (u< . 0u<)
+ (u<= . 0u<=)
+ (u> . 0u>)
+ (u>= . 0u>=)))))
+
(define macro-box (make-box '()))
(define def-box (make-box #f))
(define known-procedure-box (make-box '()))
@@ -26,10 +83,10 @@
(define (word-class word)
(cond
((cpu-register? word) 'register)
- ((keyword? word) 'keyword)
((memq word known-procedure-box[]) 'procedure)
((assq word macro-box[]) 'macro)
((memq word builtin-words) 'builtin)
+ ((keyword? word) 'keyword)
(else #f)))
(define code-box ; a list of codeblocks
@@ -329,215 +386,277 @@
(use-- (list-ref regstack i))
(set! regstack (append (take regstack i)
(drop regstack (+ i 1)))))
+ ((conditional-jump target)
+ (my (op a b) (car regstack)
+ (cdr! regstack)
+ (cond
+ ((and (zero? b)
+ (zerofy-comparison op)
+ => jumpify-comparison -> w
+ (eq? (word-class w) 'macro)
+ w)
+ => (lambda (w)
+ (cons! regstack a)
+ (cons! regstack target)
+ (my sl (length regstack)
+ (process-word w #t)
+ (if (/= (length regstack) sl)
+ (raise 'improper w)))
+ (delete 0)
+ (delete 0)))
+ (else
+ (cons! regstack a)
+ (cons! regstack b)
+ (cons! regstack target)
+ (my sl (length regstack)
+ (my w (jumpify-comparison op)
+ (process-word w #t)
+ (if (/= (length regstack) sl)
+ (raise 'improper w))))
+ (delete 0)
+ (delete 0)
+ (delete 0)))))
((process-word word suppress?)
(if (and (not suppress?)
skip-assembly?[] => (cut >= <> 2))
(emit (list '() 'word word)))
- (case word
- (integer? (cons! regstack word))
- (char? (cons! regstack (char->integer word)))
- (string? (my name (genname)
- (add-string name word)
- (cons! regstack name)
- (cons! regstack (string-length word))))
- ((= <> < <= > >= u< u<= u> u>=)
- ; make an expression
- (stack>=! 2)
- (my b (car regstack)
- (cdr! regstack)
- (my a (car regstack)
- (cdr! regstack)
- (cons! regstack (list word a b)))))
- ((if) (stack=! 1)
- (->register 0)
- (my l (gen-label)
- (cons! synstack (cons 'if l))
-
- (emit `(test ,(car regstack) ,(car regstack)))
- (emit `(jmp %?z ,l)))
- (delete 0))
- ((else) (flush)
- (case (and (cons? synstack) (caar synstack))
- ((if) (my l2 (gen-label)
- (emit `(jmp ,l2))
- (emit (cdar synstack))
- (cdr! synstack)
- (cons! synstack (cons 'else l2))))
- (else (raise 'unexpected-else name))))
- ((then) (flush)
- (case (and (cons? synstack) (caar synstack))
- ((if else) (emit (cdar synstack))
- (cdr! synstack))
- (else (raise 'unexpected-then name))))
- ((begin) (flush)
- (my l (gen-label)
- (emit l)
- (cons! synstack (cons 'begin l))))
- ((until) (stack=! 1)
- (->register 0)
- (my reg (car regstack)
- (case (and (cons? synstack) (caar synstack))
- ((begin) (emit `(test ,reg ,reg))
- (emit `(jmp %?z ,(cdar synstack)))
- (delete 0)
- (cdr! synstack))
- (else (raise 'unexpected-until name)))))
- (cons?
- (case (car word)
- ((quote) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (my sym (second word)
- (type symbol sym)
- (if (memq sym known-procedure-box[])
- (cons! regstack sym)
- (raise 'undefined sym))))
- ((unquote) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (emit (if (symbol? (second word))
- (second word)
- (let (loop (l (second word)))
- (map (lambda (item)
- (cond
- ((not (cons? item))
- item)
- ((eq? (car item)
- 'unquote)
- (list-ref regstack
- (second
- item)))
- (else
- (loop item))))
- l)))))
- ((flush) (if (not (null? (cdr word)))
- (raise 'worth-word? word))
- (flush))
- ((register) (let (loop)
- (my r (pick-register
- (and (cons? (cdr word))
- (cdr word)))
- (if r
- (cons! regstack r)
- (begin
- (if (cons? (last regstack))
- ; We've run out of registers and the bottom
- ; register is an expression. This is bad.
- (raise 'deadlock regstack))
- (enstack)
- (loop))))))
- ((copy) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (copy (second word)))
- ((delete) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (delete (second word)))
- ((->reg) (case (length word)
- ((1) (raise 'worth-word? word))
- ((2) (->register (second word)))
- ((3) (->register (second word)
- (cddr word)))
- (else (raise 'worth-word? word))))
- ((->ureg) (if (not (and (cons? (cdr word))
+ (case word
+ (integer? (cons! regstack word))
+ (char? (cons! regstack (char->integer word)))
+ (string? (my name (genname)
+ (add-string name word)
+ (cons! regstack name)
+ (cons! regstack (string-length word))))
+ ((= <> < <= > >= u< u<= u> u>=)
+ ; force stack depth
+ (stack>=! 2)
+ ; normalize operand order
+ (my (b a) regstack
+ (if (and (cons? b)
+ (or (integer? a)
+ (and (symbol? a)
+ (not (cpu-register? a)))))
+ (begin
+ (set! regstack `(,a ,b ,@(cddr regstack)))
+ (set! word (reverse-comparison word)))))
+ (cond
+ ((and (zero? (car regstack))
+ (or (eq? word '<>)
+ (eq? word '=))
+ (cons? (cadr regstack))
+ (memq (caadr regstack)
+ '(= <> < <= > >= u< u<= u> u>=)))
+ (cdr! regstack) ; drop the zero
+ (if (eq? word '=)
+ (set! (caar regstack)
+ (negate-comparison (caar regstack)))))
+ (else
+ ; reduce subexpressions
+ (if (cons? (second regstack))
+ (->register 1))
+ (if (cons? (first regstack))
+ (->register 0))
+ ; make an expression
+ (my b (car regstack)
+ (cdr! regstack)
+ (my a (car regstack)
+ (cdr! regstack)
+ (cons! regstack (list word a b)))))))
+ ((if)
+ ; booleanize and negate the stacktop
+ (process-word 0 suppress?)
+ (process-word '= suppress?)
+ ; force stack depth
+ (stack=! 1)
+ ; jump
+ (my l (gen-label)
+ (conditional-jump l)
+ (cons! synstack (cons 'if l))))
+ ((else) (flush)
+ (case (and (cons? synstack) (caar synstack))
+ ((if) (my l2 (gen-label)
+ (emit `(jmp ,l2))
+ (emit (cdar synstack))
+ (cdr! synstack)
+ (cons! synstack (cons 'else l2))))
+ (else (raise 'unexpected-else name))))
+ ((then) (flush)
+ (case (and (cons? synstack) (caar synstack))
+ ((if else) (emit (cdar synstack))
+ (cdr! synstack))
+ (else (raise 'unexpected-then name))))
+ ((begin) (flush)
+ (my l (gen-label)
+ (emit l)
+ (cons! synstack (cons 'begin l))))
+ ((until)
+ ; booleanize and negate the stacktop
+ (process-word 0 suppress?)
+ (process-word '= suppress?)
+ ; force stack depth
+ (stack=! 1)
+ ; jump
+ (case (and (cons? synstack) (caar synstack))
+ ((begin)
+ (conditional-jump (cdar synstack))
+ (cdr! synstack))
+ (else (raise 'unexpected-until name))))
+ (cons?
+ (case (car word)
+ ((quote) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (my sym (second word)
+ (type symbol sym)
+ (if (memq sym known-procedure-box[])
+ (cons! regstack sym)
+ (raise 'undefined sym))))
+ ((unquote) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (emit (if (symbol? (second word))
+ (second word)
+ (let (loop (l (second word)))
+ (map (lambda (item)
+ (cond
+ ((not (cons? item))
+ item)
+ ((eq? (car item)
+ 'unquote)
+ (list-ref regstack
+ (second
+ item)))
+ (else
+ (loop item))))
+ l)))))
+ ((flush) (if (not (null? (cdr word)))
+ (raise 'worth-word? word))
+ (flush))
+ ((register) (let (loop)
+ (my r (pick-register
+ (and (cons? (cdr word))
+ (cdr word)))
+ (if r
+ (cons! regstack r)
+ (begin
+ (if (cons? (last regstack))
+ ; We've run out of registers and the bottom
+ ; register is an expression. This is bad.
+ (raise 'deadlock regstack))
+ (enstack)
+ (loop))))))
+ ((copy) (if (not (and (cons? (cdr word))
(null? (cddr word))))
(raise 'worth-word? word))
- (->unaliased-register (second word)))
- ((stack>=!) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (stack>=! (second word)))
- ((stack<=!) (if (not (and (cons? (cdr word))
+ (copy (second word)))
+ ((delete) (if (not (and (cons? (cdr word))
(null? (cddr word))))
(raise 'worth-word? word))
- (stack<=! (second word)))
- ((stack=!) (if (not (and (cons? (cdr word))
+ (delete (second word)))
+ ((->reg) (case (length word)
+ ((1) (raise 'worth-word? word))
+ ((2) (->register (second word)))
+ ((3) (->register (second word)
+ (cddr word)))
+ (else (raise 'worth-word? word))))
+ ((->ureg) (if (not (and (cons? (cdr word))
(null? (cddr word))))
(raise 'worth-word? word))
- (stack=! (second word)))
- ((remember) (if (not (and (cons? (cdr word))
+ (->unaliased-register (second word)))
+ ((stack>=!) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (stack>=! (second word)))
+ ((stack<=!) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (stack<=! (second word)))
+ ((stack=!) (if (not (and (cons? (cdr word))
(null? (cddr word))))
(raise 'worth-word? word))
- (set! reminder (drop regstack
- (second word))))
- ((if-int-const) (if (not (and (cons? (cdr word))
- (cons? (cddr word))
- (cons? (cdddr word))
- (null? (cddddr word))))
- (raise 'worth-word? word))
- (my (i pos neg) (cdr word)
- (process-word-list
- (if (and (> (length regstack) i)
- (integer? (list-ref regstack i)))
- pos
- neg)
- suppress?)))
- ((if-empty) (if (not (and (cons? (cdr word))
- (cons? (cddr word))
- (null? (cdddr word))))
- (raise 'worth-word? word))
- (my (pos neg) (cdr word)
- (process-word-list
- (if (null? regstack)
- 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))))
- ((believe) (my claim (cdr word)
- (set! regstack
- (if (and (not (null? claim))
- (eq? (car claim) '*))
- (append-reverse (cdr claim) reminder)
- (reverse claim)))
- (set! regref#
- (map (cut cons <> 0)
- '(%eax %ebx %ecx %edi
- %edx %esi)))
- (for-each use++ regstack)))
- ((fra) (my l (string->symbol
- "$[name]$,(gen-label)")
- (cons! synstack (cons 'fra l))
- (cons! regstack l)))
- ((here) (my reg (car regstack)
- (case (and (cons? synstack)
- (caar synstack))
- ((fra) (emit (cdar synstack))
- (delete 0)
- (cdr! synstack))
- (else (raise 'unexpected-here name)))))
- (else (raise 'worth-word? word))))
- (else
- (cond
- ((assq word macro-box[])
- => (serial cdr (cut process-word-list <> #t)))
- ((memq word known-procedure-box[])
- (flush)
- (emit `(call ,word)))
- (else
- (raise 'worth-word? word)))))
+ (stack=! (second word)))
+ ((remember) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (set! reminder (drop regstack
+ (second word))))
+ ((if-int-const) (if (not (and (cons? (cdr word))
+ (cons? (cddr word))
+ (cons? (cdddr word))
+ (null? (cddddr word))))
+ (raise 'worth-word? word))
+ (my (i pos neg) (cdr word)
+ (process-word-list
+ (if (and (> (length regstack) i)
+ (integer? (list-ref regstack i)))
+ pos
+ neg)
+ suppress?)))
+ ((if-empty) (if (not (and (cons? (cdr word))
+ (cons? (cddr word))
+ (null? (cdddr word))))
+ (raise 'worth-word? word))
+ (my (pos neg) (cdr word)
+ (process-word-list
+ (if (null? regstack)
+ 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))))
+ ((believe) (my claim (cdr word)
+ (set! regstack
+ (if (and (not (null? claim))
+ (eq? (car claim) '*))
+ (append-reverse (cdr claim) reminder)
+ (reverse claim)))
+ (set! regref#
+ (map (cut cons <> 0)
+ '(%eax %ebx %ecx %edi
+ %edx %esi)))
+ (for-each use++ regstack)))
+ ((fra) (my l (string->symbol
+ "$[name]$,(gen-label)")
+ (cons! synstack (cons 'fra l))
+ (cons! regstack l)))
+ ((here) (my reg (car regstack)
+ (case (and (cons? synstack)
+ (caar synstack))
+ ((fra) (emit (cdar synstack))
+ (delete 0)
+ (cdr! synstack))
+ (else (raise 'unexpected-here name)))))
+ (else (raise 'worth-word? word))))
+ (else
+ (cond
+ ((assq word macro-box[])
+ => (serial cdr (cut process-word-list <> #t)))
+ ((memq word known-procedure-box[])
+ (flush)
+ (emit `(call ,word)))
+ (else
+ (raise 'worth-word? word)))))
(if (and (not suppress?)
skip-assembly?[] => (cut >= <> 3))
(emit (list '() 'stack (reverse regstack))))))
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X