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

mescc: Bugfix for break in switch not in compound.

Browse source 
* module/language/c99/compiler.mes (clause->jump-info): Rename from
  case->jump-info.
  (statements->clauses): New function.
  (ast->info): Use it.  Fixes switch statement with break in a case
  outside of a compound.
* scaffold/t.c (swits): Test it.
This commit is contained in:
Jan Nieuwenhuizen 2017-05-06 08:39:04 +02:00
parent f5372bdeff
commit 6dc19bd040
2 changed files with 56 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -858,7 +858,7 @@
(let ((s (string-drop o (string-length prefix)))) (let ((s (string-drop o (string-length prefix))))
(map byte->hex (string-split s #\space)))))) (map byte->hex (string-split s #\space))))))
(define (case->jump-info info) (define (clause->jump-info info)
(define (jump n) (define (jump n)
(wrap-as (i386:Xjump n))) (wrap-as (i386:Xjump n)))
(define (jump-nz n) (define (jump-nz n)
@ -1092,6 +1092,49 @@
(define (local? o) ;; formals < 0, locals > 0 (define (local? o) ;; formals < 0, locals > 0
(positive? (local:id o))) (positive? (local:id 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: unsupported:" s)))))))
(define (ast->info info) (define (ast->info info)
(lambda (o) (lambda (o)
(let ((globals (.globals info)) (let ((globals (.globals info))
@ -1217,16 +1260,17 @@
else-text) else-text)
#:globals (.globals else-info)))) #:globals (.globals else-info))))
((switch ,expr (compd-stmt (block-item-list . ,cases))) ((switch ,expr (compd-stmt (block-item-list . ,statements)))
(let* ((expr ((expr->accu info) expr)) (let* ((clauses (statements->clauses statements))
(expr ((expr->accu info) expr))
(empty (clone info #:text '())) (empty (clone info #:text '()))
(case-infos (map (case->jump-info empty) cases)) (clause-infos (map (clause->jump-info empty) clauses))
(case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos)) (clause-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) clause-infos))
(cases-info (let loop ((cases cases) (info expr) (lengths case-lengths)) (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
(if (null? cases) info (if (null? clauses) info
(let ((c-j ((case->jump-info info) (car cases)))) (let ((c-j ((clause->jump-info info) (car clauses))))
(loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths))))))) (loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
cases-info)) clauses-info))
((for ,init ,test ,step ,body) ((for ,init ,test ,step ,body)
(let* ((info (clone info #:text '())) ;; FIXME: goto in body... (let* ((info (clone info #:text '())) ;; FIXME: goto in body...

6
scaffold/t.c
View file

@ -128,10 +128,8 @@ swits (int c)
} }
case -1: case -1:
case 1: case 1:
{ x = 1;
x = 1; break;
break;
}
default: default:
{ {
x = 2; x = 2;