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

mescc: Tinycc support: Switch with heterogeneous body, non-last default.

Browse source 
* module/language/c99/compiler.mes (switch->info): New function.
  (ast->info): Use it for switch.
  (clause->info, statements->clauses): Remove.
* scaffold/tests/44-switch.c (default_first): Test it.
This commit is contained in:
Jan Nieuwenhuizen 2018-05-17 07:40:01 +02:00
parent 8f8a4be83d
commit 7dfc88e22c
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
2 changed files with 193 additions and 114 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1375,63 +1375,6 @@
(define (comment? o)
(and (pair? o) (pair? (car o)) (eq? (caar o) #:comment)))
(define (clause->info info i label last?)
(define clause-label
(string-append label "clause" (number->string i)))
(define body-label
(string-append label "body" (number->string i)))
(define (jump label)
(wrap-as (i386:jump label)))
(define (jump-nz label)
(wrap-as (i386:jump-nz label)))
(define (jump-z label)
(wrap-as (i386:jump-z label)))
(define (test->text test)
(let ((value (pmatch test
(0 0)
((p-expr (char ,value)) (char->integer (car (string->list value))))
((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
((p-expr (fixed ,value)) (cstring->number value))
((neg (p-expr (fixed ,value))) (- (cstring->number value)))
(_ (error "case test: not supported: " test)))))
(append (wrap-as (i386:accu-cmp-value value))
(jump-z body-label))))
(define (cases+jump info cases)
(let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
(next-clause-label (if last? (string-append label "break")
(string-append label "clause" (number->string (1+ i)))))
(info (append-text info (apply append cases)))
(info (if (null? cases) info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,body-label))))))
info))
(lambda (o)
(let loop ((o o) (cases '()) (clause #f))
(pmatch o
((case ,test ,statement)
(loop statement (append cases (list (test->text test))) clause))
((default ,statement)
(loop statement cases clause))
((default . ,statements)
(loop `(compd-stmt (block-item-list ,@statements)) cases clause))
((compd-stmt (block-item-list))
(loop '() cases clause))
((compd-stmt (block-item-list . ,elements))
(let ((clause (or clause (cases+jump info cases))))
(loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
(ast->info (car elements) clause))))
(()
(let ((clause (or clause (cases+jump info cases))))
(if last? clause
(let ((next-body-label (string-append label "body"
(number->string (1+ i)))))
(append-text clause (wrap-as (i386:jump next-body-label)))))))
(_
(let ((clause (or clause (cases+jump info cases))))
(loop '() cases
(ast->info o clause))))))))
(define (test-jump-label->info info label)
(define (jump type . test)
(lambda (o)
@ -1622,49 +1565,6 @@
((pointer (pointer (pointer))) 3)
(_ (error "ptr-declr->rank not supported: " o))))
(define (statements->clauses statements)
(let loop ((statements statements) (clauses '()))
(if (null? statements) clauses
(let ((s (car statements)))
(pmatch s
((case ,test (compd-stmt (block-item-list . _)))
(loop (cdr statements) (append clauses (list s))))
((case ,test (break))
(loop (cdr statements) (append clauses (list s))))
((case ,test) (loop (cdr statements) (append clauses (list s))))
((case ,test ,statement)
(let loop2 ((statement statement) (heads `((case ,test))))
(define (heads->case heads statement)
(if (null? heads) statement
(append (car heads) (list (heads->case (cdr heads) statement)))))
(pmatch statement
((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
((default ,s2) (loop2 s2 (append heads `((default)))))
((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
(_ (let loop3 ((statements (cdr statements)) (c (list statement)))
(if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
(let ((s (car statements)))
(pmatch s
((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
(_ (loop3 (cdr statements) (append c (list s))))))))))))
((default (compd-stmt (block-item-list _)))
(loop (cdr statements) (append clauses (list s))))
((default . ,statement)
(let loop2 ((statements (cdr statements)) (c statement))
(if (null? statements) (loop statements (append clauses (list `(default ,@c))))
(let ((s (car statements)))
(pmatch s
((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
(_ (loop2 (cdr statements) (append c (list s)))))))))
(_ (error "statements->clauses: not supported:" s)))))))
(define (ast->info o info)
(let ((functions (.functions info))
(globals (.globals info))
@ -1751,16 +1651,36 @@
info))
((switch ,expr (compd-stmt (block-item-list . ,statements)))
(define (clause? o)
(pmatch o
((case . _) 'case)
((default . _) 'default)
((labeled-stmt _ ,statement) (clause? statement))
(_ #f)))
(define clause-number
(let ((i 0))
(lambda (o)
(let ((n i))
(when (clause? (car o))
(set! i (1+ i)))
n))))
(let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break"))
(clauses (statements->clauses statements))
(info (expr->accu expr info))
(info (clone info #:break (cons break-label (.break info))))
(info (let loop ((clauses clauses) (i 0) (info info))
(if (null? clauses) info
(loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
(count (length (filter clause? statements)))
(default? (find (cut eq? <> 'default) (map clause? statements)))
(info (fold (cut switch->info #t label (1- count) <> <> <>) info statements
(unfold null? clause-number cdr statements)))
(last-clause-label (string-append label "clause" (number->string count)))
(default-label (string-append label "default"))
(info (if (not default?) info
(append-text info (wrap-as (i386:jump break-label)))))
(info (append-text info (wrap-as `((#:label ,last-clause-label)))))
(info (if (not default?) info
(append-text info (wrap-as (i386:jump default-label)))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
@ -1846,7 +1766,7 @@
((decl . ,decl)
;;FIXME: ridiculous performance hit with mes
;; Nyacc 0.80.42: missing (enum-ref (ident "fred"))
(let (;;(info (append-text info (ast->comment o)))
(let ( ;;(info (append-text info (ast->comment o)))
)
(decl->info info decl)))
;; ...
@ -1872,6 +1792,91 @@
(define (ast-list->info o info)
(fold ast->info info o))
(define (switch->info clause? label count o i info)
(let* ((i-string (number->string i))
(i+1-string (number->string (1+ i)))
(body-label (string-append label "body" i-string))
(clause-label (string-append label "clause" i-string))
(last? (= i count))
(break-label (string-append label "break"))
(next-clause-label (string-append label "clause" i+1-string))
(default-label (string-append label "default")))
(define (jump label)
(wrap-as (i386:jump label)))
(pmatch o
((case ,test)
(define (jump-nz label)
(wrap-as (i386:jump-nz label)))
(define (jump-z label)
(wrap-as (i386:jump-z label)))
(define (test->text test)
(let ((value (pmatch test
(0 0)
((p-expr (char ,value)) (char->integer (car (string->list value))))
((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
((p-expr (fixed ,value)) (cstring->number value))
((neg (p-expr (fixed ,value))) (- (cstring->number value)))
(_ (error "case test: not supported: " test)))))
(append (wrap-as (i386:accu-cmp-value value))
(jump-z body-label))))
(let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info)))
(append-text info (test->text test))))
((case ,test (case . ,case1))
(let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info)))
(fold (cut switch->info #f label count <> i <>) info (cons `(case ,test) `((case ,@case1))))))
((case ,test (default . ,rest))
(let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info)))
(fold (cut switch->info #f label count <> i <>) info (cons `(case ,test) `(default ,@rest)))))
((case ,test ,statement)
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (switch->info #f label count `(case ,test) i info))
(info (append-text info (jump next-clause-label)))
(info (append-text info (wrap-as `((#:label ,body-label))))))
(ast->info statement info)))
((case ,test (case . ,case1) . ,rest)
(let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info)))
(fold (cut switch->info #f label count <> i <>) info (cons `(case ,test) `((case ,@case1) ,@rest)))))
((default (case . ,case1) . ,rest)
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (if last? info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,default-label)))))
(info (append-text info (jump body-label))))
(fold (cut switch->info #f label count <> i <>) info `((case ,@case1) ,@rest))))
(default
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (if last? info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,default-label))))))
(append-text info (jump body-label))))
((default ,statement)
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (if last? info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,body-label)))))
(info (append-text info (wrap-as `((#:label ,default-label))))))
(ast->info statement info)))
((default ,statement ,rest)
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (if last? info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,body-label)))))
(info (append-text info (wrap-as `((#:label ,default-label))))))
(fold ast->info (ast->info statement info) rest)))
((labeled-stmt (ident ,goto-label) ,statement)
(let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" goto-label)))))))
(switch->info clause? label count statement i info)))
(_ (ast->info o info)))))
(define (global->static function)
(lambda (o)
(cons (car o) (set-field (cdr o) (global:function) function))))

92
scaffold/tests/44-switch.c
View file

@ -30,10 +30,10 @@ swits (int c)
switch (c)
{
case TCHAR: {goto next;}
case 1: {goto next;}
case 2: {goto next;}
default: {goto next;}
case TCHAR: {puts ("TCHAR\n"); goto next;}
case 1: {puts ("1\n"); goto next;}
case 2: {puts ("2\n"); goto next;}
default: {puts ("default\n"); goto next;}
}
return 1;
@ -42,6 +42,7 @@ swits (int c)
{
case 0:
{
puts ("0\n");
x = 0;
c = 34;
break;
@ -52,9 +53,11 @@ swits (int c)
case 2:
case -1:
case 1:
puts ("5..1, -1\n");
x = 1;
break;
default:
puts ("default\n");
x = 2;
x = 2;
break;
@ -62,21 +65,92 @@ swits (int c)
return x;
}
int
default_first (int c)
{
int a;
switch (c)
{
here:
default:
a = 1;
{
}
a = 2;
return a;
there:
case 0:
;
{}
return 0;
}
return -1;
}
int
test ()
{
puts ("\n");
puts ("t: switch 0\n");
if (swits (0) != 0) return swits (0);
int i = swits (0);
if (i != 0)
return i;
puts ("t: switch 1\n");
if (swits (1) != 1) return 1;
if (swits (1) != 1)
return 10;
puts ("t: switch -1\n");
if (swits (-1) != 1) return 1;
if (swits (-1) != 1)
return 11;
puts ("t: switch -1\n");
if (swits (-2) != 2) return 1;
if (swits (-2) != 2)
return 12;
return 0;
if (default_first (1) != 2)
return 13;
if (default_first (0) != 0)
return 14;
i = 15;
switch (i)
{
case 0:
case 1:
case 2:
case 3:
case 4:
i = 15;
break;
}
if (i != 15)
return 15;
i = 16;
switch (i)
{
case 1:
default:
case 0:
i = 0;
break;
}
if (i!= 0)
return 16;
i = 2;
switch (i)
{
default:
case 0:
i = 17;
break;
case 2:
i = 0;
}
return i;
}