[PATCH] mescc: Fix switch statements' fallthrough

[Ekaitz Zarraga]

>From f75cf7bfb911868023732bf4274978069b98849a Mon Sep 17 00:00:00 2001
From: Ekaitz Zarraga <ekaitz@elenq.tech>
Date: Tue, 12 Sep 2023 14:07:04 +0200
Subject: [PATCH] mescc: Fix switch statements' fallthrough

Flattens case structures as nyacc is giving consecutive cases as a
nested block like:

    (case testA
      (case testB
        (case testC BODY)))

We convert to:

    ((case testA (expr-stmt))
     (case testB (expr-stmt))
     (case testC BODY))

And then treat them as independent cases. For the fallthrough we just
add a jump to each case's body right before its clause (each of the case
blocks is responsible of adding its own jump to its body):

        // This doesn't have it because it's the first
    CASE1:
        testA
    CASE1_BODY:

        goto CASE2_BODY
    CASE2:
        testB
    CASE2_BODY:

        goto CASE3_BODY
    CASE3:
        testB
    CASE3_BODY:

This enables complex fallthrough schemes comparing to what was done
before.

* module/mescc/compile.scm
  (ast->info)[switch]{flatten-cases}: New variable.
  (ast->info)[switch]{statements}: Use flatten-cases on it.
  (switch->expr): Remove unneeded matchers and add jumps to body.
* build-aux/check-mescc.sh(xfail-tests): Remove
  lib/tests/scaffold/66-local-char-array.c
---
 build-aux/check-mescc.sh |  1 -
 module/mescc/compile.scm | 45 ++++++++++++++++++++++++++--------------
 2 files changed, 30 insertions(+), 16 deletions(-)

diff --git a/build-aux/check-mescc.sh b/build-aux/check-mescc.sh
index 4b4be83a..b10b1589 100755
--- a/build-aux/check-mescc.sh
+++ b/build-aux/check-mescc.sh
@@ -253,7 +253,6 @@ if test $compiler = mescc; then
     xfail_tests="$xfail_tests
 lib/tests/scaffold/17-compare-unsigned-char-le.c
 lib/tests/scaffold/17-compare-unsigned-short-le.c
-lib/tests/scaffold/66-local-char-array.c
 lib/tests/scaffold/70-ternary-arithmetic-argument.c
 lib/tests/mes/90-abtod.c
 lib/tests/mes/90-dtoab.c
diff --git a/module/mescc/compile.scm b/module/mescc/compile.scm
index 50df1e6b..071dfb67 100644
--- a/module/mescc/compile.scm
+++ b/module/mescc/compile.scm
@@ -1790,7 +1790,33 @@
                (when (clause? (car o))
                  (set! i (1+ i)))
                n))))
+
+        (define (flatten-cases c)
+          (define (flatten-case case)
+            (pmatch case
+              ((case ,test (case . ,body))
+               (append `((case ,test (expr-stmt))) (flatten-case `(case 
,@body))))
+              ((case ,test ,casebody (case . ,body))
+               (append `((case ,test ,casebody)) (flatten-case `(case 
,@body))))
+              ((default (case . ,body))
+               (append `((default (expr-stmt))) (flatten-case `(case ,@body))))
+              ((default ,defbody (case . ,body))
+               (append `((default ,defbody)) (flatten-case `(case ,@body))))
+              ((case ,test (default . ,body))
+               (append `((case ,test (expr-stmt))) (flatten-case `(default 
,@body))))
+              ((default ,rest)
+               (list case))
+              ((case ,test)
+               (list case))
+              ((case ,test ,expr)
+               (list case))
+              (,s (list s))))
+          (fold (lambda (x acc) (append acc (flatten-case x))) '() c))
+
+
+
        (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt 
(block-item-list (ellipsis)))))))
+              (statements (flatten-cases statements))
               (here (number->string (length text)))
               (label (string-append "_" (.function info) "_" here "_"))
               (break-label (string-append label "break"))
@@ -1926,8 +1952,8 @@
   (let* ((i-string (number->string i))
          (i+1-string (number->string (1+ i)))
          (body-label (string-append label "body" i-string))
-         (next-body-label (string-append label "body" i+1-string))
          (clause-label (string-append label "clause" i-string))
+         (first? (= i 0))
          (last? (= i count))
          (break-label (string-append label "break"))
          (next-clause-label (string-append label "clause" i+1-string))
@@ -1953,30 +1979,19 @@
        (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))))
+       (let* ((info (if first? info (append-text info (jump body-label)))) ; 
Enables fallthrough
+              (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)))))
-              (info (ast->info statement info))
-              ;; 66-local-char-array -- fallthrough FIXME
-              ;; (info (if last? info
-              ;;           (append-text info (jump next-body-label))))
-              )
+              (info (ast->info statement info)))
          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))
-- 
2.41.0