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

* 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.

module/language/c99/compiler.mes

@@ -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))
+              (count (length (filter clause? statements)))
-                      (if (null? clauses) info
+              (default? (find (cut eq? <> 'default) (map clause? statements)))
-                          (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
+              (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
@@ -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))))

scaffold/tests/44-switch.c

@@ -30,10 +30,10 @@ swits (int c)
 
   switch (c)
     {
-    case TCHAR: {goto next;}
+    case TCHAR: {puts ("TCHAR\n"); goto next;}
-    case 1: {goto next;}
+    case 1: {puts ("1\n"); goto next;}
-    case 2: {goto next;}
+    case 2: {puts ("2\n"); goto next;}
-    default: {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;
 }