fix comments inside statements shifting their meaning

fmt-c-writer.scm

@@ -61,6 +61,28 @@ surrounding c-block supplies them)."
         `(%begin ,(line-directive src) ,(walk-expr s))
         (walk-expr s))))
 
+;;; A `;' comment reads as a form, so one written inside a construct
+;;; with positional slots lands in a slot and shifts everything after
+;;; it. So take the positional slots by skipping comments, and hand
+;;; the comments back to be emitted just before the statement
+(define (take-slots forms n)
+  "Three values: the comment forms skipped over, the next N non-comment
+forms, and what remains."
+  (let loop ((fs forms) (n n) (comments (list)) (slots (list)))
+    (cond ((or (= n 0) (null? fs))
+           (values (reverse comments) (reverse slots) fs))
+          ((comment-form? (car fs))
+           (loop (cdr fs) n (cons (car fs) comments) slots))
+          (else
+           (loop (cdr fs) (- n 1) comments (cons (car fs) slots))))))
+
+;;; `%begin' is a statement sequence that emits no braces of its own, so
+;;; the comments simply precede the statement.
+(define (with-comments comments form)
+  (if (null? comments)
+      form
+      `(%begin ,@(map walk-expr comments) ,form)))
+
 (define (walk-if-clauses clauses)
   "(test stmt test stmt ... [else-stmt]) -- tests stay expressions."
   (let loop ((cs clauses) (acc (list)))
@@ -128,9 +150,11 @@ surrounding c-block supplies them)."
     ;; is the fmt-c directive for the `.' operator (see sex-fmt-c).
     (('dot-access . rest) (cons '%. (map walk-expr rest)))
     (('var . _) (walk-var form))
-    (('cast expr type) (list '%cast
+    ;; An expression has no room for a statement, so a comment in a
-                             (walk-type type)
+    ;; cast is dropped rather than relocated.
-                             (walk-expr expr)))
+    (('cast . rest)
+     (let-values (((comments slots _) (take-slots rest 2)))
+       (list '%cast (walk-type (cadr slots)) (walk-expr (car slots)))))
     (('enum . _) (walk-enum form))
     ;; | is problematic... And c-or/bit-or/etc are actually
     ;; procedures, so we have to call the procedure itself
@@ -142,21 +166,38 @@ surrounding c-block supplies them)."
     ;; and each is spliced or wrapped according to what the
     ;; corresponding fmt-c procedure accepts.
     (('do . stmts) (cons '%block-begin (walk-body stmts)))
-    (('if . clauses) (cons 'if (walk-if-clauses clauses)))
+    (('if . clauses)
-    (('while test . body)
+     (with-comments (filter comment-form? clauses)
-     (cons* 'while (walk-expr test) (walk-body body)))
+       (cons 'if (walk-if-clauses (remove comment-form? clauses)))))
-    (('for init test step . body)
+    (('while . rest)
-     (cons* 'for (walk-expr init) (walk-expr test) (walk-expr step)
+     (let-values (((comments slots body) (take-slots rest 1)))
-            (walk-body body)))
+       (with-comments comments
+         (cons* 'while (walk-expr (car slots)) (walk-body body)))))
+    (('for . rest)
+     (let-values (((comments slots body) (take-slots rest 3)))
+       (with-comments comments
+         (cons* 'for (walk-expr (car slots)) (walk-expr (cadr slots))
+                (walk-expr (caddr slots))
+                (walk-body body)))))
     ;; No anchor *between* switch clauses: c-switch requires every clause
     ;; to be a case/default form and errors on anything else. The clause
     ;; bodies are anchored from inside, which is what a debugger steps
     ;; onto -- a `case' label is not a statement.
-    (('switch e . clauses)
+    ;; A comment between clauses has to go too: c-switch requires every
-     (cons* 'switch (walk-expr e) (map walk-expr clauses)))
+    ;; clause to be a case/default form and errors on anything else.
-    (('case v . body) (cons* 'case (walk-expr v) (walk-body body)))
+    (('switch . rest)
-    (('case/fallthrough v . body)
+     (let-values (((comments slots clauses) (take-slots rest 1)))
-     (cons* 'case/fallthrough (walk-expr v) (walk-body body)))
+       (with-comments (append comments (filter comment-form? clauses))
+         (cons* 'switch (walk-expr (car slots))
+                (map walk-expr (remove comment-form? clauses))))))
+    (('case . rest)
+     (let-values (((comments slots body) (take-slots rest 1)))
+       (with-comments comments
+         (cons* 'case (walk-expr (car slots)) (walk-body body)))))
+    (('case/fallthrough . rest)
+     (let-values (((comments slots body) (take-slots rest 1)))
+       (with-comments comments
+         (cons* 'case/fallthrough (walk-expr (car slots)) (walk-body body)))))
     (('default . body) (cons 'default (walk-body body)))
 
     (else (map walk-expr form))))
@@ -167,14 +208,16 @@ surrounding c-block supplies them)."
   ;; (var b [const char 512]) -> (%var (%array (const char) 512) b)
   ;; note: [...] is actually (¤ ...) after reading
   ;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c)
+  ;; Likewise a declaration: drop any comment rather than shift the
+  ;; name and type apart.
+  (let ((form (cons (car form) (remove comment-form? (cdr form)))))
     `(%var
       ,(walk-type (third form))
       ,(atom-to-fmt-c (second form))
       .
       ,(if (null? (drop form 3))
            (list)
-         (walk-expr (drop form 3)))      ; optional init expression
+           (walk-expr (drop form 3)))))) ; optional init expression
-    ))
 
 (define (walk-type form)
   ;; int -> int

tests/codegen.scm

@@ -72,4 +72,31 @@
               "(int *)&a"))
     (test-assert "sizeof is left bare"
       (emits? (in-fn "(var n int (cast (sizeof int) int))")
-              "(int)sizeof(int)"))))
+              "(int)sizeof(int)")))
+
+  ;; A `;' comment is a form, so one written inside a construct with
+  ;; positional slots used to land in a slot and shift everything after
+  ;; it -- silently. In an `if' the comment became the then-arm and the
+  ;; then-arm became an `else if' condition, and it still compiled.
+  ;; Comments are now taken out of the slots and emitted just before the
+  ;; statement; comments in a body stay where they were written.
+  (test-group "comments in positional slots"
+    (test-assert "an if arm is not shifted"
+      (not (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "else if")))
+    (test-assert "and both arms survive"
+      (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "g(1)"))
+    (test-assert "the comment survives too"
+      (emits? (in-fn "(if 1 ;; kept here\n (g 1) (g 2))") "kept here"))
+    (test-assert "a for header is not shifted"
+      (emits? (in-fn "(for ;; c\n (var i int 0) (< i 2) (++ i) (g i))")
+              "for (int i = 0; i < 2; ++i)"))
+    (test-assert "a while condition is not shifted"
+      (emits? (in-fn "(while ;; c\n (< a b) (g 1))") "while (a < b)"))
+    (test-assert "a var is not shifted"
+      (emits? (in-fn "(var ;; c\n x int 5)") "int x = 5"))
+    (test-assert "a cast is not shifted"
+      (emits? (in-fn "(var y int (cast ;; c\n a int))") "(int)a"))
+    ;; Bodies are a statement sequence, so comments there stay put.
+    (test-assert "a comment in a body stays in the body"
+      (emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
+              "while (a < b) {"))))