[Wisp-cvs] wisp/tools worth,1.32,1.33
Status: Alpha
Brought to you by:
digg
Menu
▾
▴
[Wisp-cvs] wisp/tools worth,1.32,1.33
|
From: <di...@us...> - 2002-09-26 18:22:41
|
Update of /cvsroot/wisp/wisp/tools
In directory usw-pr-cvs1:/tmp/cvs-serv28730/tools
Modified Files:
worth
Log Message:
Made Worth's syntax stack visible to the source being translated.
Index: worth
===================================================================
RCS file: /cvsroot/wisp/wisp/tools/worth,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -d -r1.32 -r1.33
--- worth 18 Sep 2002 21:01:03 -0000 1.32
+++ worth 26 Sep 2002 18:22:38 -0000 1.33
@@ -15,8 +15,8 @@
unix)
(define builtin-words
- '(< <= <> = > >= begin else if stack=! then u< u<= u> u>= until
- while))
+ '(->synstack < <-synstack <= <> = > >= ?jump annihilate gen-label
+ stack=! stick-label u< u<= u> u>=))
(define (other op c)
(cond
@@ -83,10 +83,12 @@
(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)
- ((keyword? word) 'keyword)
+ ((keyword? word) 'keyword)
(else #f)))
(define code-box ; a list of codeblocks
@@ -121,58 +123,62 @@
i)
(define (process-piece i)
- (case (car i)
- ((defun)
- (add-code (worth->ia32 (cadr i) (cddr i))))
- ((cells)
- (add-code (cells->ia32 (cadr i) (cddr i))))
- ((native)
- (add-code (worth->ia32 (string->symbol "N_$(cadr i)")
- `(,',(nop)
- ,(list 'unquote (string->symbol "NN_$(cadr i)"))
- wisp-prologue ,@(cddr i) wisp-epilogue))))
- ((assemble)
- (add-code (cdr i)))
- ((macro)
- (my (name . body) (cdr i)
- (if (not (or (memq name builtin-words)
- (assq name macro-box[])))
- (cons! macro-box[] (cons name body))
- (raise 'duplicate-macro name))))
- ((string)
- (my (name value . rest) (cdr i)
- (if (not (null? rest))
- (raise 'null? rest))
- (add-string name value)))
- ((define)
- (my (sym . rest) (cdr i)
- (if (not (null? rest))
- (raise 'null? rest))
- (cons! def-box[] sym)))
- ((ifdef)
- (my (sym . body) (cdr i)
- (if (memq sym def-box[])
- (for-each process-piece body))))
- ((ifndef)
- (my (sym . body) (cdr i)
- (if (not (memq sym def-box[]))
- (for-each process-piece body))))
- ((include)
- (for-each (lambda (item)
- (cond
- ((string? item) (process-file item))
- ((symbol? item) (call-with-input-file
- "$[item].wrti" 'system-path
- process-file))
- (else (raise 'filename? item))))
- (cdr i)))
- ((extern)
- (for-each (lambda (word)
- (if (word-class word)
- (raise 'duplicate-word word))
- (cons! known-procedure-box[] word))
- (cdr i)))
- (else (raise 'worth-piece? i))))
+ (try
+ (case (car i)
+ ((defun)
+ (add-code (worth->ia32 (cadr i) (cddr i))))
+ ((cells)
+ (add-code (cells->ia32 (cadr i) (cddr i))))
+ ((native)
+ (add-code (worth->ia32 (string->symbol "N_$(cadr i)")
+ `(,',(nop)
+ ,(list 'unquote (string->symbol "NN_$(cadr i)"))
+ wisp-prologue ,@(cddr i) wisp-epilogue))))
+ ((assemble)
+ (add-code (cdr i)))
+ ((macro)
+ (my (name . body) (cdr i)
+ (if (not (or (memq name builtin-words)
+ (assq name macro-box[])))
+ (cons! macro-box[] (cons name body))
+ (raise 'duplicate-macro name))))
+ ((string)
+ (my (name value . rest) (cdr i)
+ (if (not (null? rest))
+ (raise 'null? rest))
+ (add-string name value)))
+ ((define)
+ (my (sym . rest) (cdr i)
+ (if (not (null? rest))
+ (raise 'null? rest))
+ (cons! def-box[] sym)))
+ ((ifdef)
+ (my (sym . body) (cdr i)
+ (if (memq sym def-box[])
+ (for-each process-piece body))))
+ ((ifndef)
+ (my (sym . body) (cdr i)
+ (if (not (memq sym def-box[]))
+ (for-each process-piece body))))
+ ((include)
+ (for-each (lambda (item)
+ (cond
+ ((string? item) (process-file item))
+ ((symbol? item) (call-with-input-file
+ "$[item].wrti" 'system-path
+ process-file))
+ (else (raise 'filename? item))))
+ (cdr i)))
+ ((extern)
+ (for-each (lambda (word)
+ (if (word-class word)
+ (raise 'duplicate-word word))
+ (cons! known-procedure-box[] word))
+ (cdr i)))
+ (else (raise 'worth-piece? i)))
+ (except ()
+ (print "(process-piece '$[i]) -/-> $[sig] $[dat]\n")
+ (raise sig dat))))
(define (process-file input)
(cond
@@ -199,8 +205,8 @@
(raise 'duplicate-word name))
(cons! known-procedure-box[] name)
(let ((gen-label (my c (make-counter)
- (lambda ()
- (string->symbol ".L$(c)"))))
+ (lambda (prefix)
+ (string->symbol "$,[prefix].L$(c)"))))
(rcode '())
(reminder '()))
(my emit (my skip? #f
@@ -213,9 +219,8 @@
(else (cons! rcode x)))))
(begin
(emit name)
- (let ((synstack '())
- ; FIXME: regstack should be a deque
- (regstack '())
+ (let ((regstack '()) ; FIXME: regstack should be a deque
+ (synstack '())
(regref# (map (cut cons <> 0)
'(%eax %ebx %ecx %edx %esi %edi))))
(letrec (((process-word-list word-list (suppress? #f))
@@ -487,67 +492,48 @@
(type integer depth)
(stack<=! depth)
(stack>=! depth)))
- ((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))))
- ((while)
- ; booleanize and negate the staktop
- (process-word 0 suppress?)
- (process-word '= suppress?)
- ; force stack depth
- (stack=! 1)
- ; jump
- (case (and (cons? synstack) (caar synstack))
- ((begin)
- (my exitlabel (gen-label)
- (conditional-jump exitlabel)
- (set! (car synstack)
- (list 'while (cdar synstack) exitlabel))))))
- ((repeat)
- (stack=! 0)
- ; jump
- (case (and (cons? synstack) (caar synstack))
- ((while)
- (emit `(jmp ,(cadar synstack)))
- (emit (caddar synstack))
- (cdr! synstack))
- (else (raise 'unexpected-repeat name))))
+ ((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))
@@ -727,20 +713,11 @@
'(%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
+ ((eq? (word-class word) 'broketed)
+ (cons! synstack word))
((assq word macro-box[])
=> (serial cdr (cut process-word-list <> #t)))
((memq word known-procedure-box[])
@@ -750,7 +727,10 @@
(raise 'worth-word? word)))))
(if (and (not suppress?)
skip-assembly?[] => (cut >= <> 3))
- (emit (list '() 'stack (reverse regstack))))))
+ (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
|
