fmt-c-writer.scm

@@ -47,8 +47,8 @@ source location. Only statement positions may be walked this way: a
                       (if src
                           (list (line-directive src) (walk-expr s))
                           (list (walk-expr s)))))
-                  stmts)
+                  (pack-comments stmts))
-      (map walk-expr stmts)))
+      (map walk-expr (pack-comments stmts))))
 
 (define (walk-stmt s)
   "A statement in a slot that holds exactly one form -- an `if' arm.
@@ -132,6 +132,40 @@ forms, and what remains."
 (define (comment-form? f)
   (and (pair? f) (eq? (car f) 'comment)))
 
+;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
+(define (strip-comment-marker text)
+  (string-trim-both (string-trim text #\;)))
+
+(define (walk-comment texts)
+  (list '%comment
+        (string-append " "
+                       (string-intersperse (map strip-comment-marker texts)
+                                           "\n ")
+                       " ")))
+
+;;; Merge multiple lines of /* */ into single block
+(define (pack-comments forms)
+  (let loop ((fs forms) (acc (list)))
+    (cond
+     ((null? fs) (reverse acc))
+     ((comment-form? (car fs))
+      (let ((first (car fs)))
+        (let gather ((rest (cdr fs)) (texts (cdr first)) (line (form-line first)))
+          (if (and (pair? rest)
+                   (comment-form? (car rest))
+                   line
+                   (equal? (form-file first) (form-file (car rest)))
+                   (eqv? (form-line (car rest)) (+ line 1)))
+              (gather (cdr rest)
+                      (append texts (cdr (car rest)))
+                      (form-line (car rest)))
+              (loop rest
+                    (cons (if (eq? texts (cdr first))
+                              first          ; a run of one, left alone
+                              (copy-form-source! first (cons 'comment texts)))
+                          acc))))))
+     (else (loop (cdr fs) (cons (car fs) acc))))))
+
 (define (walk-generic-toplevel form)
   (cond ((atom? form) (atom-to-fmt-c form))
         ((list? form) (map walk-generic-toplevel form))
@@ -145,7 +179,7 @@ forms, and what remains."
     ((? atom?)
      (atom-to-fmt-c form))
     ;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
-    (('comment . text) (cons '%comment text))
+    (('comment . text) (walk-comment text))
     ;; (dot-access obj field ...) -> obj.field... member access. `%.'
     ;; is the fmt-c directive for the `.' operator (see sex-fmt-c).
     (('dot-access . rest) (cons '%. (map walk-expr rest)))
@@ -200,7 +234,8 @@ forms, and what remains."
          (cons* 'case/fallthrough (walk-expr (car slots)) (walk-body body)))))
     (('default . body) (cons 'default (walk-body body)))
 
-    (else (map walk-expr form))))
+    ;; Drop comments so they will not generate additional comma
+    (else (map walk-expr (remove comment-form? form)))))
 
 (define (walk-var form)
   ;; (var a int) -> (%var int a)
@@ -365,7 +400,7 @@ forms, and what remains."
 
 (define (process-toplevel-form form)
   (match form
-    (('comment . text) (cons '%comment text))
+    (('comment . text) (walk-comment text))
     (('fn . _) (list 'static (walk-function form)))
     (('var . _) (list 'static (walk-var form)))
     (('extern . rest) (walk-extern rest))
@@ -386,4 +421,4 @@ forms, and what remains."
                 (when src
                   (fmt #t (c-expr (line-directive src)))))
               (fmt #t (c-expr (process-toplevel-form form)) nl))
-            sex-forms))
+            (pack-comments sex-forms)))

tests/basic.scm

@@ -42,5 +42,10 @@
   (test '(%. a_b c) (walk-expr '(dot-access a-b c)))
 
   ;; comment -> %comment directive (rendered as /* ... */)
-  (test '(%comment " hi") (walk-expr '(comment " hi")))
+  ;; The reader eats only the `;' that introduced the line, so ";;; Foo"
-  (test '(%comment " hi") (process-toplevel-form '(comment " hi"))))
+  ;; arrives as ";; Foo"; and c-comment puts nothing between /* */ and
+  ;; the text. Both are handled on the way out.
+  (test '(%comment " hi ") (walk-expr '(comment " hi")))
+  (test '(%comment " hi ") (process-toplevel-form '(comment " hi")))
+  (test '(%comment " Foo ") (walk-expr '(comment ";; Foo")))
+  (test '(%comment " Foo ") (walk-expr '(comment ";;;   Foo   "))))

tests/codegen.scm

@@ -74,6 +74,30 @@
       (emits? (in-fn "(var n int (cast (sizeof int) int))")
               "(int)sizeof(int)")))
 
+  ;; A comment among a call's arguments used to become an argument,
+  ;; and c-apply put a comma on each side of it -- which does not
+  ;; compile. It is dropped, as in any other expression context.
+  (test-group "comments among arguments"
+    (test-assert "no stray comma"
+      (not (emits? (in-fn "(g 1 ;; c\n 2)") "*/,")))
+    (test-assert "the arguments survive"
+      (emits? (in-fn "(g 1 ;; c\n 2)") "g(1, 2)")))
+
+  ;; The reader leaves the `;'s that introduced each line, and a run of
+  ;; comment lines arrives as one form per line.
+  (test-group "comment rendering"
+    (test-assert "the markers are stripped"
+      (emits? "(fn f () void ;;; Foo\n (g))" "/* Foo */"))
+    (test-assert "so none survive into the C"
+      (not (emits? "(fn f () void ;;; Foo\n (g))" ";;")))
+    (test-assert "consecutive lines are packed into one comment"
+      (emits? "(fn f () void\n ;; first\n ;; second\n (g))"
+              "/* first\n second */"))
+    ;; Packing compares locations rather than just looking for adjacent
+    ;; comment forms, so a blank line still separates them.
+    (test-assert "a blank line keeps them apart"
+      (emits? "(fn f () void\n ;; first\n\n ;; second\n (g))" "/* first */")))
+
   ;; 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