Thread: [Wisp-cvs] wisp/tools worth,1.35,1.36
Status: Alpha
Brought to you by:
digg
Menu
▾
▴
wisp-cvs
|
From: <di...@us...> - 2002-09-30 18:24:58
|
Update of /cvsroot/wisp/wisp/tools
In directory usw-pr-cvs1:/tmp/cvs-serv25684/tools
Modified Files:
worth
Log Message:
Created the beginnings of Worth-level assemblying.
Index: worth
===================================================================
RCS file: /cvsroot/wisp/wisp/tools/worth,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- worth 30 Sep 2002 18:24:37 -0000 1.35
+++ worth 30 Sep 2002 18:24:56 -0000 1.36
@@ -15,8 +15,10 @@
unix)
(define builtin-words
- '(->synstack < <-synstack <= <> = > >= ?jump annihilate gen-label
- stack=! stick-label u< u<= u> u>=))
+ '(->synstack < <-synstack <= <> = > >= ?jump annihilate byte#
+ decode-register gen-label is? literal-integer? register?
+ regstack-depth stack=! stick-label synstack tetra# u< u<= u> u>=
+ wyde#))
(define (other op c)
(cond
@@ -83,8 +85,6 @@
(define (word-class word)
(cond
((cpu-register? word) 'register)
- ((and (>= (symbol-length word) 3)
- (broketed? word)) 'broketed)
((memq word known-procedure-box[]) 'procedure)
((assq word macro-box[]) 'macro)
((memq word builtin-words) 'builtin)
@@ -117,7 +117,7 @@
(modulo i #x100000000))
(define (reduce-to-stetra i)
- (set! i (reduce-to-utetra))
+ (set! i (reduce-to-utetra i))
(if (>= i #x80000000)
(decr! i #x100000000))
i)
@@ -200,6 +200,14 @@
(list 'tetra datum))
(else (signal 'cell? datum)))) body))
+(define register-data
+ '((%eax 0 0) (%ecx 0 1) (%edx 0 2) (%ebx 0 3)
+ (%esp 0 4) (%ebp 0 5) (%esi 0 6) (%edi 0 7)
+ (%ax 1 0) (%cx 1 1) (%dx 1 2) (%bx 1 3)
+ (%sp 1 4) (%bp 1 5) (%si 1 6) (%si 1 7)
+ (%al 2 0) (%cl 2 1) (%dl 2 2) (%bl 2 3)
+ (%ah 2 4) (%ch 2 5) (%dh 2 6) (%bh 2 7)))
+
(define (worth->ia32 name body)
(if (word-class name)
(raise 'duplicate-word name))
@@ -207,8 +215,7 @@
(let ((gen-label (my c (make-counter)
(lambda (prefix)
(string->symbol "$,[prefix].L$(c)"))))
- (rcode '())
- (reminder '()))
+ (rcode '()))
(my emit (my skip? #f
(lambda (x) ; the postprocessor
(cond
@@ -222,7 +229,8 @@
(let ((regstack '()) ; FIXME: regstack should be a deque
(synstack '())
(regref# (map (cut cons <> 0)
- '(%eax %ebx %ecx %edx %esi %edi))))
+ '(%eax %ebx %ecx %edx %esi %edi)))
+ (mode #f))
(letrec (((process-word-list word-list (suppress? #f))
(for-each (cut process-word <> suppress?)
word-list))
@@ -398,11 +406,6 @@
((->non-expression i)
(if (cons? (list-ref regstack i))
(->register i)))
- ((copy i)
- (stack>=! (+ i 1))
- (my object (list-ref regstack i)
- (use++ object)
- (cons! regstack object)))
((delete i)
(stack>=! (+ i 1))
(use-- (list-ref regstack i))
@@ -438,218 +441,104 @@
(delete 0)
(delete 0)
(delete 0)))))
+ ((get-dollar-list)
+ (and (memq '$ synstack) -> sep
+ (my dl synstack
+ (set! synstack (cdr sep))
+ (set! (cdr sep) '())
+ (drop-right dl 1))))
((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 (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)))))))
- ((stack=!)
- (if (null? regstack)
- (raise 'invalid-context 'stack=!))
- (my depth (car regstack)
- (cdr! regstack)
- (type integer depth)
- (stack<=! depth)
- (stack>=! depth)))
- ((gen-label)
- (cons! regstack (gen-label name)))
- ((stick-label)
- (if (null? regstack)
- (raise 'invalid-context 'stick-label))
- (my label (car regstack)
- ; FIXME: check integrity of the label here
- (cdr! regstack)
- (emit label)))
- ((->synstack)
- (if (null? regstack)
- (raise 'invalid-context '->synstack))
- (my item (car regstack)
- (cdr! regstack)
- (cons! synstack item)))
- ((<-synstack)
- (if (null? synstack)
- (raise 'invalid-context '<-synstack))
- (my item (car synstack)
- (cdr! synstack)
- (cons! regstack item)))
- ((annihilate)
- (cond
- ((null? synstack)
- (raise 'invalid-context 'annihilate))
- ((null? (cdr synstack))
- (raise 'invalid-context
- (list (car synstack) 'annihilate)))
- (else
- (my (etalon actual . rest) synstack
- (set! synstack rest)
- (if (not (eq? actual etalon))
- (raise 'syntax-mismatch
- (list actual etalon)))))))
- ((?jump)
- ; Note that |?jump| just jumps disregarding
- ; any register usage mismatches
- (if (null? regstack)
- (raise 'invalid-context '?jump))
- (my l (car regstack)
- (cdr! regstack)
- (conditional-jump l)))
- (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)
- ; FIXME: report a suitable error if the stack is too shallow
- ((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))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (->unaliased-register (second word)))
- ((->/expr) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (->non-expression (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))
- (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?)))
- ((conform) (my reqs (cdr word)
+ (cond
+ ((eq? mode 'syn)
+ (if (char? word)
+ (set! word (char->integer word)))
+ (if (or (integer? word)
+ (symbol? word))
+ (if (not (and (cons? synstack)
+ (eq? (car synstack) '<mute>)))
+ (cons! synstack word))
+ (raise 'synstackable? word))
+ (set! mode #f))
+ ((and (cons? synstack)
+ (eq? (car synstack) '<mute>))
+ (case word
+ ((if) (cons! synstack '<mute>))
+ ((else) (if (not (and (cons? (cdr synstack))
+ (eq? (cadr synstack) '<mute>)))
+ (set! (car synstack) '<unmute>)))
+ ((then) (cdr! synstack))
+ ((thens)
+ (while (and (cons? synstack)
+ (memq (car synstack)
+ '(<mute> <unmute> <if>)))
+ (cdr! synstack))
+ (if (and (cons? synstack)
+ (eq? (car synstack) '<cond>))
+ (cdr! synstack)
+ (raise 'invalid-context 'thens)))
+ ; Ignore these in order to avoid infinite recursion
+ ((dig))
+ ((syn) (set! mode 'syn))
+ ; Although we won't generate any code, we will
+ ; still want to expand macros since the block
+ ; delimiters may be in these expansions.
+ (else (and (assq word macro-box[]) -> c
+ (process-word-list (cdr c) #t)))))
+ ((and (cons? synstack)
+ (eq? (car synstack) '<unmute>)
+ (or (eq? word 'else) (eq? word 'then)))
+ (case word
+ ((else) (set! (car synstack) '<mute>))
+ ((then) (cdr! synstack))))
+ ((and (eq? word 'dig)
+ (cons? regstack)
+ (integer? (car regstack))
+ (> (length (cdr regstack))
+ (reduce-to-utetra (car regstack))))
+ (my object (list-ref (cdr regstack)
+ (reduce-to-utetra
+ (car regstack)))
+ (set! (car regstack) object)
+ (use++ object)))
+ (else
+ (case word
+ (integer? (case mode
+ ((synstack syn)
+ (cons! synstack word))
+ (else
+ (cons! regstack word))))
+ (char? (process-word (char->integer word) #t))
+ (string? (case mode
+ ((synstack syn)
+ (raise 'invalid-context word))
+ (else
+ (my name (genname)
+ (add-string name word)
+ (cons! regstack name)
+ (cons! regstack (length word))))))
+ ((syn synstack) (set! mode word))
+ ((regstack) (set! mode #f))
+ ((believe) (set! regstack '())
+ (set! regref#
+ (map (cut cons <> 0)
+ '(%eax %ebx %ecx %edi
+ %edx %esi))))
+ ((conform) (set! mode #f) ; for convenience
+ (my reqs (or (get-dollar-list)
+ (raise 'invalid-context
+ word))
(cond
((null? reqs) (flush))
((and (cons? reqs)
(null? (cdr reqs))
reqs -> (reg)
(assq reg regref#))
- (my (reg) reqs
- (->register 0 reg)
- (stack=! 1)))
+ (my (reg) reqs
+ (->register 0 reg)
+ (stack=! 1)))
((and (cons? reqs)
(cons? (cdr reqs))
(null? (cddr reqs))
@@ -657,10 +546,10 @@
(assq reg1 regref#)
(assq reg2 regref#)
(not (eq? reg1 reg2)))
- (my (reg1 reg2) reqs
- (stack<=! 2)
- (->register 0 reg2)
- (->register 1 reg1)))
+ (my (reg1 reg2) reqs
+ (stack<=! 2)
+ (->register 0 reg1)
+ (->register 1 reg2)))
((and (cons? reqs)
(cons? (cdr reqs))
(cons? (cddr reqs))
@@ -672,67 +561,321 @@
(not (eq? reg1 reg2))
(not (eq? reg1 reg3))
(not (eq? reg2 reg3)))
- (my (reg1 reg2 reg3) reqs
- (stack<=! 3)
- (->register 0 reg3)
- (->register 1 reg2)
- (->register 2 reg1)))
+ (my (reg1 reg2 reg3) reqs
+ (stack<=! 3)
+ (->register 0 reg1)
+ (->register 1 reg2)
+ (->register 2 reg3)))
(else (raise 'unable-to-conform
reqs)))))
- ((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)))
- (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 word
- ((+) (+ 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 'huh? word)))
- rest))))
+ ((decode-register)
+ (stack>=! 1)
+ (my obj (car regstack)
+ (cdr! regstack)
+ (my c (assq obj register-data)
+ (if (not c)
+ (raise 'register? obj))
+ (cdr! c)
+ (cons! regstack (first c))
+ (cons! regstack (second c)))))
+ ((literal-integer?)
+ (stack>=! 1)
+ (my obj (car regstack)
+ (set! (car regstack)
+ (if (integer? obj)
+ -1 0))
+ (use-- obj)))
+ ((register?)
+ (stack>=! 1)
+ (my obj (car regstack)
+ (set! (car regstack)
+ (if (cpu-register? obj)
+ -1 0))
+ (use-- obj)))
+ ((is?)
+ (stack>=! 2)
+ (my (a b . rest) regstack
+ (set! regstack rest)
+ (cons! regstack (if (equal? a b)
+ -1 0))
+ (use-- a)
+ (use-- b)))
+ ((regstack-depth)
+ (cons! regstack (length regstack)))
+ ((thens)
+ (while (and (cons? synstack)
+ (eq? (car synstack) '<if>))
+ (process-word 'then #t))
+ (if (and (cons? synstack)
+ (eq? (car synstack) '<cond>))
+ (cdr! synstack)
+ (raise 'invalid-context 'thens)))
+ ((bug)
+ (raise 'bug-occurred (reverse regstack)))
+ ((stack=!)
+ (if (null? regstack)
+ (raise 'invalid-context 'stack=!))
+ (my depth (car regstack)
+ (cdr! regstack)
+ (type integer depth)
+ (stack<=! depth)
+ (stack>=! depth)))
+ ((gen-label)
+ (cons! regstack (gen-label name)))
+ ((stick-label)
+ (if (null? regstack)
+ (raise 'invalid-context 'stick-label))
+ (my label (car regstack)
+ ; FIXME: check integrity of the label here
+ (cdr! regstack)
+ (emit label)))
+ ((byte#)
+ (if (or (null? regstack)
+ (not (integer? (car regstack))))
+ (raise 'invalid-context 'byte#))
+ (emit (list 'byte (car regstack)))
+ (cdr! regstack))
+ ((wyde#)
+ (if (or (null? regstack)
+ (not (integer? (car regstack))))
+ (raise 'invalid-context 'wyde#))
+ (emit (list 'wyde (car regstack)))
+ (cdr! regstack))
+ ((tetra#)
+ (if (or (null? regstack)
+ (not (or (integer? (car regstack))
+ (symbol? (car regstack)))))
+ (raise 'invalid-context 'wyde#))
+ (emit (list 'tetra (car regstack)))
+ (cdr! regstack))
+ ((->synstack)
+ (if (null? regstack)
+ (raise 'invalid-context '->synstack))
+ (my item (car regstack)
+ (cdr! regstack)
+ (cons! synstack item)
+ (use-- item)))
+ ((<-synstack)
+ (if (null? synstack)
+ (raise 'invalid-context '<-synstack))
+ (my item (car synstack)
+ (cdr! synstack)
+ (cons! regstack item)
+ (use++ item)))
+ ((annihilate)
+ (cond
+ ((null? synstack)
+ (raise 'invalid-context 'annihilate))
+ ((null? (cdr synstack))
+ (raise 'invalid-context
+ (list (car synstack) 'annihilate)))
(else
- (raise 'huh? word))))
- ((eq? (word-class word) 'broketed)
- (cons! synstack word))
- ((assq word macro-box[])
- => (serial cdr (cut process-word-list <> #t)))
- ((memq word known-procedure-box[])
- (flush)
- (emit `(call ,word)))
+ (my (etalon actual . rest) synstack
+ (set! synstack rest)
+ (if (not (eq? actual etalon))
+ (raise 'syntax-mismatch
+ (list actual etalon)))))))
+ ((?jump)
+ ; Note that |?jump| just jumps disregarding
+ ; any register usage mismatches
+ (if (null? regstack)
+ (raise 'invalid-context '?jump))
+ (my l (car regstack)
+ (cdr! regstack)
+ (conditional-jump l)))
+ (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)
+ ; FIXME: report a suitable error if the stack is too shallow
+ ((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))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (->unaliased-register (second word)))
+ ((->/expr) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (->non-expression (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))
+ (stack=! (second word)))
+ (else (raise 'worth-word? word))))
(else
- (raise 'worth-word? word)))))
- (if (and (not suppress?)
- skip-assembly?[] => (cut >= <> 3))
- (emit (list '() 'stack (reverse regstack))))
- (if (and (not suppress?)
- skip-assembly?[] => (cut >= <> 4))
- (emit (list '() 'synstack (reverse synstack))))))
+ (cond
+ ((and (eq? word 'if)
+ (cons? regstack)
+ (integer? (car regstack)))
+ (set! (car regstack)
+ (reduce-to-stetra (car regstack)))
+ (cons! synstack
+ (if (zero? (car regstack))
+ '<mute>
+ '<unmute>))
+ (cdr! regstack))
+ ((and (memq word
+ '(* + - / < <= <> = > >=
+ lshift mod rshift u< u<=
+ u> u>=))
+ (cons? regstack)
+ (integer? (car regstack))
+ (cons? (cdr regstack))
+ (integer? (cadr regstack)))
+ (case word
+ ((* + - / < <= <> = > >= lshift mod
+ rshift u< u<= u> u>=)
+ (my (b a . rest) regstack
+ (set! a (reduce-to-stetra a))
+ (set! b (reduce-to-stetra b))
+ (set! regstack
+ (cons
+ (case word
+ ((+) (+ a b))
+ ((-) (- a b))
+ ((*) (* a b))
+ ((/) (quotient a b))
+ ((mod) (remainder a b))
+ ((lshift) (<< (reduce-to-utetra a)
+ (reduce-to-utetra b)))
+ ((rshift) (>> (reduce-to-utetra a)
+ (reduce-to-utetra b)))
+ ((=) (if (= a b) -1 0))
+ ((<) (if (< a b) -1 0))
+ ((>) (if (> a b) -1 0))
+ ((<=) (if (<= a b) -1 0))
+ ((>=) (if (>= a b) -1 0))
+ ((u<) (if (< (reduce-to-utetra a)
+ (reduce-to-utetra b))
+ -1 0))
+ ((u>) (if (> (reduce-to-utetra a)
+ (reduce-to-utetra b))
+ -1 0))
+ ((u<=) (if (<= (reduce-to-utetra a)
+ (reduce-to-utetra b))
+ -1 0))
+ ((u>=) (if (>= (reduce-to-utetra a)
+ (reduce-to-utetra b))
+ -1 0))
+ (else (raise 'huh? word)))
+ rest))))
+ (else
+ (raise 'huh? word))))
+ ((memq 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)))))))
+
+ ((assq word macro-box[])
+ => (serial cdr (cut process-word-list <> #t)))
+ ((eq? mode 'synstack)
+ (cons! synstack word))
+ ((cpu-register? word)
+ (cons! regstack word)
+ (use++ word))
+ ((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))))))
+ (if (and (not suppress?)
+ skip-assembly?[] => (cut >= <> 4))
+ (emit (list '() 'synstack (reverse synstack))))))
(for-each (cut process-word <> #f) body)
(if (eq? name '_start)
(begin
|
×
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