mescc: Refactor switch.

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

diff --git a/lib.c b/lib.c
index 67747db327cbe9d9f3bd1f426a9d910c40b6d93d..e7ac71c85714aa70a5a53cae1ea642f26908336d 100644 (file)
--- a/lib.c
+++ b/lib.c
@@ -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);

diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes
index baa9698604bae2c8975cc0f754aa41ba6955340c..47d10276aace1227a978b354e7f6cf47573b3d68 100644 (file)
--- a/module/language/c99/compiler.mes
+++ b/module/language/c99/compiler.mes
@@ -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)
-    (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)))))
-
-      ((default ,statement)
-       ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
-
-      (_ (stderr "no case match: ~a\n" o) barf)
-      )))
+    (lambda (body-length)
+      (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))
+          ((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)

diff --git a/scaffold/t.c b/scaffold/t.c
index 872fd7608e3753483aeeb8ea5d5870aafd02bb08..ced944be72eb5989f68280b147d629a9f288dac4 100644 (file)
--- a/scaffold/t.c
+++ b/scaffold/t.c
@@ -115,22 +115,23 @@ swits (int c)
  next:
   switch (c)
     {
-      case 0:
-        {
-          x = 0;
-          c = 34;
-          break;
-        }
-      case 1:
-        {
-          x = 1;
-          break;
-        }
-      default:
-        {
-          x = 2;
-          break;
-        }
+    case 0:
+      {
+        x = 0;
+        c = 34;
+        break;
+      }
+    case -1:
+    case 1:
+      {
+        x = 1;
+        break;
+      }
+    default:
+      {
+        x = 2;
+        break;
+      }
     }
   return x;
 }
@@ -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;