artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Refactor switch.

Browse source 
* module/language/c99/compiler.mes (case->jump-info): Refactor.
  Support multiple case statements.
* scaffold/t.c (swits): Test it.
* lib.c (display_helper)[__NYACC__]: Remove branch.
This commit is contained in:
Jan Nieuwenhuizen 2017-04-09 06:52:39 +02:00
parent da3ccf9703
commit 6009cf95fe
3 changed files with 64 additions and 104 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
lib.c
View file

@ -129,32 +129,7 @@ display_helper (SCM x, int cont, char* sep, int fd)
break;
}
case TSPECIAL:
#if __MESC__
// FIXME
//{}
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putc (VALUE (CAR (t)), fd);
t = CDR (t);
}
break;
}
#endif
case TSTRING:
#if __MESC__
// FIXME
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putc (VALUE (CAR (t)), fd);
t = CDR (t);
}
break;
}
#endif
case TSYMBOL:
{
SCM t = CAR (x);

101
module/language/c99/compiler.mes
View file

@ -738,75 +738,56 @@
(wrap-as (i386:Xjump n)))
(define (jump-nz n)
(wrap-as (i386:Xjump-nz n)))
(define (jump-z n)
(wrap-as (i386:Xjump-z n)))
(define (statement->info info body-length)
(lambda (o)
(pmatch o
((break) (append-text info (jump body-length)))
(_
((ast->info info) o)))))
(define (test->text test)
(let ((value (pmatch test
(0 0)
((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
((p-expr (fixed ,value)) (cstring->number value))
((neg (p-expr (fixed ,value))) (- (cstring->number value))))))
(lambda (n)
(append (wrap-as (i386:accu-cmp-value value))
(jump-z (+ (length (text->list (jump 0)))
(if (= n 0) 0
(* n (length (text->list ((test->text 0) 0)))))))))))
(define (cases+jump cases clause-length)
(append-text info
(append
(append-map (lambda (t i) (t i)) cases (reverse (iota (length cases))))
(if (null? cases) '()
(jump clause-length)))))
(lambda (o)
(lambda (body-length)
(let loop ((o o) (cases '()) (clause #f))
(pmatch o
((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(define (test->text value clause-length)
(append (wrap-as (i386:accu-cmp-value value))
(jump-nz clause-length)))
(let* ((value (assoc-ref (.constants info) constant))
(test-info (append-text info (test->text value 0)))
(text-length (length (.text test-info)))
(clause-info (let loop ((elements elements) (info test-info))
(if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements))))))
(clause-text (list-tail (.text clause-info) text-length))
(clause-length (length (text->list clause-text))))
(clone info #:text (append
(.text info)
(test->text value clause-length)
clause-text)
#:globals (.globals clause-info)))))
((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(define (test->text value clause-length)
(append (wrap-as (i386:accu-cmp-value value))
(jump-nz clause-length)))
(let* ((value (cstring->number value))
(test-info (append-text info (test->text value 0)))
(text-length (length (.text test-info)))
(clause-info (let loop ((elements elements) (info test-info))
(if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements))))))
(clause-text (list-tail (.text clause-info) text-length))
(clause-length (length (text->list clause-text))))
(clone info #:text (append
(.text info)
(test->text value clause-length)
clause-text)
#:globals (.globals clause-info)))))
((case (neg (p-expr (fixed ,value))) ,statement)
((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
((default (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(let ((text-length (length (.text info))))
(let loop ((elements elements) (info info))
(if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements))))))))
((case (p-expr (ident ,constant)) ,statement)
((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
((case (p-expr (fixed ,value)) ,statement)
((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
((case ,test ,statement)
(loop statement (append cases (list (test->text test))) clause))
((default ,statement)
((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
(_ (stderr "no case match: ~a\n" o) barf)
)))
(loop statement cases clause))
((compd-stmt (block-item-list))
(loop '() cases clause))
((compd-stmt (block-item-list . ,elements))
(let ((clause (or clause (cases+jump cases 0))))
(loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
((statement->info clause body-length) (car elements)))))
(()
(let* ((cases-length (length (.text (cases+jump cases 0))))
(clause-text (list-tail (.text clause) cases-length))
(clause-length (length (text->list clause-text))))
(clone clause #:text
(append (.text (cases+jump cases clause-length))
clause-text))))
(_
(let ((clause (or clause (cases+jump cases 0))))
(loop '() cases
((statement->info clause body-length) o)))))))))
(define (test->jump->info info)
(define (jump type . test)

6
scaffold/t.c
View file

@ -121,6 +121,7 @@ swits (int c)
c = 34;
break;
}
case -1:
case 1:
{
x = 1;
@ -672,7 +673,10 @@ test (char *p)
if (swits (1) != 1) return 1;
puts ("t: switch -1\n");
if (swits (-1) != 2) return 1;
if (swits (-1) != 1) return 1;
puts ("t: switch -1\n");
if (swits (-2) != 2) return 1;
puts ("t: if (1)\n");
if (1) goto ok0;