tests: add docstring cases

semen.scm

@@ -140,16 +140,78 @@
   (cons (copy-form-source! form `(typedef ,target ,new-type)) acc))
 
 ;;; Fn processing
+;;;
+;;; A string as the first body form is a docstring. In the generated
+;;; C code it will be placed as a C commentary just before the function
+;;; definition (actually that works for all blocky things: enum, struct, union as well).
 
 (define (comment-form? f)
   (and (pair? f) (eq? (car f) 'comment)))
 
+(define (fn-header-length fn-form)
+  (if (memq (first fn-form) '(pub extern)) 5 4))
+
+(define (fn-core form)
+  ;; The (fn name args rettype . body) list, without pub/extern
+  (if (memq (first form) '(pub extern))
+      (cdr form)
+      form))
+
+(define (take-leading-docstring forms)
+  ;; If FORMS starts with a string, possibly after comment forms, return
+  ;; that string and FORMS without it. Otherwise #f and FORMS unchanged
+  (let loop ((fs forms) (prefix (list)))
+    (match fs
+      (() (values #f forms))
+      (((and cmt ('comment . _)) . rest)
+       (loop rest (cons cmt prefix)))
+      (((? string? doc) . rest)
+       (values doc (append (reverse prefix) rest)))
+      (_ (values #f forms)))))
+
+(define (extract-fn-docstring fn-form)
+  (let ((lift
+         (lambda (proto body)
+           (let-values (((doc rest) (take-leading-docstring body)))
+             (if doc
+                 (values doc (copy-form-source! fn-form (append proto rest)))
+                 (values #f fn-form))))))
+    (match fn-form
+      (('pub 'fn name args ret . body)
+       (lift `(pub fn ,name ,args ,ret) body))
+      (('extern 'fn name args ret . body)
+       (lift `(extern fn ,name ,args ,ret) body))
+      (('fn name args ret . body)
+       (lift `(fn ,name ,args ,ret) body))
+      (_ (values #f fn-form)))))
+
+(define (extract-aggregate-docstring form)
+  ;; A string immediately after the name is the docstring; comments
+  ;; between name and fields are not skipped, they already confuse the
+  ;; writer
+  (match form
+    (('pub (and kind (or 'struct 'union 'enum))
+           (? symbol? name) (? string? doc) . rest)
+     (values doc (copy-form-source! form `(pub ,kind ,name ,@rest))))
+    (((and kind (or 'struct 'union 'enum))
+      (? symbol? name) (? string? doc) . rest)
+     (values doc (copy-form-source! form `(,kind ,name ,@rest))))
+    (_ (values #f form))))
+
+(define (with-docstring doc form acc)
+  ;; acc is newest-first; FORM is consed last so the final reverse
+  ;; emits the comment immediately before the declaration
+  (cons form
+        (if doc
+            (cons (list 'comment doc) acc)
+            acc)))
+
 (define (strip-fn-header-comments fn-form)
   ;; Remove comment forms from the function header
   ;; ([pub|extern] fn name arglist rettype) so the positional accessors
   ;; below are not shifted. Comments in the body are left in place as
   ;; ordinary statements and preserved into the generated C.
-  (let ((header-count (if (memq (car fn-form) '(pub extern)) 5 4)))
+  (let ((header-count (fn-header-length fn-form)))
     ;; This always rebuilds the list, so the location has to be carried
     ;; over explicitly -- otherwise every function loses it
     (copy-form-source!
@@ -162,21 +224,21 @@
         (else (loop (cdr form) (+ kept 1) (cons (car form) acc))))))))
 
 (define (process-fn sex-fn-raw acc)
-  (let* ((sex-fn (strip-fn-header-comments sex-fn-raw))
-         (expanded (macro-expand sex-fn))
-         (env (make-hash-table))
-         (processed
-          (walk-form
-           expanded
-           fn-walker
-           (begin
-             (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
-             (set! (hash-table-ref env :lambda-counter) 0)
-             (set! (hash-table-ref env :lambda-aux-code) (list))
-             env))))
-
-    (cons processed
-          (append (hash-table-ref env :lambda-aux-code) acc))))
+  (let-values (((doc sex-fn)
+                (extract-fn-docstring (strip-fn-header-comments sex-fn-raw))))
+    (let* ((expanded (macro-expand sex-fn))
+           (env (make-hash-table))
+           (processed
+            (walk-form
+             expanded
+             fn-walker
+             (begin
+               (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
+               (set! (hash-table-ref env :lambda-counter) 0)
+               (set! (hash-table-ref env :lambda-aux-code) (list))
+               env))))
+      (with-docstring doc processed
+                      (append (hash-table-ref env :lambda-aux-code) acc)))))
 
 (define (fn-walker form env)
   (if (eq? 'lambda (car form))
@@ -207,8 +269,9 @@
 
 ;;; Record the named structs, unions and enums in the type database
 (define (process-struct sex-struct acc)
-  (register-aggregate! sex-struct)
-  (cons sex-struct acc))
+  (let-values (((doc form) (extract-aggregate-docstring sex-struct)))
+    (register-aggregate! form)
+    (with-docstring doc form acc)))
 
 (define (register-aggregate! form)
   (let* ((f (if (eq? (car form) 'pub) (cdr form) form))
@@ -238,40 +301,30 @@ Returns #f if the form is not a function, returns the form otherwise"
     (else #f)))
 
 (define (sex-fn-public? fn-form)
-  (eq? (car fn-form) 'pub))
-
-(define (sex-fn-return-type fn-form)
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (third fn-form)
-      (second fn-form)))
+  (eq? (first fn-form) 'pub))
 
 (define (sex-fn-name fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (fourth fn-form)
-      (third fn-form)))
+  (second (fn-core fn-form)))
 
 (define (sex-fn-arglist fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (fifth fn-form)
-      (fourth fn-form)))
+  (third (fn-core fn-form)))
+
+(define (sex-fn-return-type fn-form)
+  (assert (sex-fn? fn-form)
+          (fmt #f "Form " fn-form " is not a function"))
+  (fourth (fn-core fn-form)))
 
 (define (sex-fn-prototype fn-form)
   "Returns all except body"
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (take fn-form 5)
-      (take fn-form 4)))
+  (take fn-form (fn-header-length fn-form)))
 
 (define (sex-fn-body fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (drop fn-form 5)
-      (drop fn-form 4)))
+  (drop fn-form (fn-header-length fn-form)))

sex-modules.scm

@@ -8,6 +8,7 @@
   (chicken process-context)
   (chicken string)
   fmt
+  matchable
   reader
   srfi-1
   utils)
@@ -71,22 +72,33 @@
      (list)
      raw-forms)))
 
+(define (public-fn-interface form)
+  ;; (pub fn name args ret . body) -> prototype, keeping a docstring so
+  ;; the importer can emit it above the declaration
+  (match form
+    (('pub 'fn name args ret)
+     form)
+    (('pub 'fn name args ret ('comment . _) . rest)
+     (public-fn-interface `(pub fn ,name ,args ,ret ,@rest)))
+    (('pub 'fn name args ret (? string? doc) . _)
+     `(pub fn ,name ,args ,ret ,doc))
+    (('pub 'fn name args ret . _)
+     `(pub fn ,name ,args ,ret))))
+
 ;;; TODO: use semen facilities to analyze modules
 (define (process-public-interface-form form acc)
-  (case (car form)
-    ((pub)
-     (case (cadr form)
-       ;; A function is reduced to a prototype and keeps its `pub', so
-       ;; the importing unit declares it with external linkage
-       ((fn)
-        (cons (copy-form-source! form (take form 5)) acc))
-       ;; A variable becomes an `extern' declaration
-       ((var)
-        (cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc))
-       ((define defmacro enum import include struct typedef union)
-        (cons (copy-form-source! form (cdr form)) acc))
-       (else (sex-error form "pub must be followed by a definition" form))))
-    (else acc)))
+  (match form
+    ;; Reduced to a prototype, still `pub', so the importer declares it
+    ;; with external linkage
+    (('pub 'fn . _)
+     (cons (copy-form-source! form (public-fn-interface form)) acc))
+    (('pub 'var name type . _)
+     (cons (copy-form-source! form `(extern var ,name ,type)) acc))
+    (('pub (or 'define 'defmacro 'enum 'import 'include 'struct 'typedef 'union) . _)
+     (cons (copy-form-source! form (cdr form)) acc))
+    (('pub . _)
+     (sex-error form "pub must be followed by a definition" form))
+    (_ acc)))
 
 (define (load-persistent-module-paths)
   (let ((sex-module-path-env-var

tests/codegen.scm

@@ -230,4 +230,33 @@ compiles."
     (test-assert "grouping sublist still accepted"
       (emits? (in-fn "(var s (* (const struct suc)) 0)") "const struct suc * s"))
     (test-assert "flat chain still accepted"
-      (emits? (in-fn "(var q (* * const char) 0)") "const char * * q"))))
+      (emits? (in-fn "(var q (* * const char) 0)") "const char * * q")))
+
+  ;; A string as the first body form (or after the name of a struct,
+  ;; union or enum) is a docstring: it becomes a comment immediately
+  ;; before the declaration, not a statement inside it.
+  (test-group "docstrings"
+    (test-assert "appears before the function"
+      (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
+              "/* Greet NAME. */"))
+    (test-assert "and not inside the body as a statement"
+      (not (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
+                   "\"Greet NAME.\"")))
+    (test-assert "multiline keeps its paragraphs"
+      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
+              "Entry point."))
+    (test-assert "and the second paragraph too"
+      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
+              "ARGC and ARGV."))
+    (test-assert "a prototype with only a docstring stays a prototype"
+      (emits? "(fn helper ((a int)) int \"Forward.\")"
+              "helper (int a);"))
+    (test-assert "a string after the first statement is left alone"
+      (emits? "(fn f () void (g) \"not a docstring\")"
+              "\"not a docstring\""))
+    (test-assert "a struct docstring sits above the struct"
+      (emits? "(struct point \"A 2D point.\" ((x int) (y int)))"
+              "/* A 2D point. */"))
+    (test-assert "and an enum docstring too"
+      (emits? "(enum color \"RGB.\" (red green blue))"
+              "/* RGB. */"))))

tests/modules/greet.sex

@@ -9,7 +9,9 @@
 
 (pub var greet-count int 0)
 
-(pub struct greeting ((text (* const char)) (times int)))
+(pub struct greeting
+  "A greeting to print."
+  ((text (* const char)) (times int)))
 
 (pub enum mood (cheerful grumpy))
 
@@ -24,6 +26,7 @@
              `(printf "%s " ,(symbol->string name))))))
 
 (pub fn greet ((name (* const char))) void
+  "Print a greeting for NAME."
   (++ greet-count)
   (printf "hello, %s\n" name))
 

tests/semen.scm

@@ -1,30 +1,35 @@
 (import srfi-69
-        semen)
+        semen
+        types)
 
 (define print-str-fn
-  '(fn void print-str ((string s))
+  '(fn print-str ((s string)) void
        (printf "%s" s)))
 
 (define sum-fn
-  '(pub fn float sum ((int a) (int b))
-        (return (cast float (+ a b)))))
+  '(pub fn sum ((a int) (b int)) float
+        (return (cast (+ a b) float))))
 
 (test-group "semen"
   (test-assert (sex-fn? print-str-fn))
   (test #f (sex-fn-public? print-str-fn))
   (test 'void (sex-fn-return-type print-str-fn))
   (test 'print-str (sex-fn-name print-str-fn))
-  (test '((string s)) (sex-fn-arglist print-str-fn))
-  (test '(fn void print-str ((string s))) (sex-fn-prototype print-str-fn))
+  (test '((s string)) (sex-fn-arglist print-str-fn))
+  (test '(fn print-str ((s string)) void) (sex-fn-prototype print-str-fn))
   (test '((printf "%s" s)) (sex-fn-body print-str-fn))
 
   (test-assert (sex-fn? sum-fn))
   (test #t (sex-fn-public? sum-fn))
   (test 'float (sex-fn-return-type sum-fn))
   (test 'sum (sex-fn-name sum-fn))
-  (test '((int a) (int b)) (sex-fn-arglist sum-fn))
-  (test '(pub fn float sum ((int a) (int b))) (sex-fn-prototype sum-fn))
-  (test '((return (cast float (+ a b)))) (sex-fn-body sum-fn))
+  (test '((a int) (b int)) (sex-fn-arglist sum-fn))
+  (test '(pub fn sum ((a int) (b int)) float) (sex-fn-prototype sum-fn))
+  (test '((return (cast (+ a b) float))) (sex-fn-body sum-fn))
+
+  (test-assert (sex-fn? '(extern fn foo () void)))
+  (test 'foo (sex-fn-name '(extern fn foo () void)))
+  (test #f (sex-fn? '(struct point ((x int)))))
 
   (let ((sex-code
          '((defmacro (sum-var name a b c)
@@ -49,9 +54,65 @@
          '((defmacro (x10 a)
              `(* 10 ,a))
 
-           (fn void foo ((int a) (int b))
+           (fn foo ((a int) (b int)) void
                (return (+ a (x10 b)))))))
 
-    (test '((fn void foo ((int a) (int b))
+    (test '((fn foo ((a int) (b int)) void
                 (return (+ a (* 10 b)))))
-          (semen-process sex-code-macro))))
+          (semen-process sex-code-macro)))
+
+;;; Docstrings are lifted out as comment forms sitting before the
+;;; declaration. A string later in a body is left alone.
+
+  (test '((comment "Greet NAME.")
+          (fn greet ((name (* char))) void
+              (printf "Hello %s!\n" name)))
+        (semen-process
+         '((fn greet ((name (* char))) void
+               "Greet NAME."
+               (printf "Hello %s!\n" name)))))
+
+  (test '((comment "Public entry.")
+          (pub fn main () int
+               (return 0)))
+        (semen-process
+         '((pub fn main () int
+                "Public entry."
+                (return 0)))))
+
+  ;; A prototype whose only "body" is a docstring stays a prototype
+  (test '((comment "Forward.")
+          (fn helper ((a int)) int))
+        (semen-process
+         '((fn helper ((a int)) int
+               "Forward."))))
+
+  (test '((fn f () void (g) "not a docstring"))
+        (semen-process
+         '((fn f () void (g) "not a docstring"))))
+
+  ;; `;' comments before the string are skipped when looking for it,
+  ;; and stay in the body
+  (test '((comment "Kept.")
+          (fn f () void (comment " note") (g)))
+        (semen-process
+         '((fn f () void (comment " note") "Kept." (g)))))
+
+  (test '((comment "A 2D point.")
+          (struct t-doc-pt ((x int) (y int))))
+        (semen-process
+         '((struct t-doc-pt "A 2D point." ((x int) (y int))))))
+
+  (test '((x int) (y int))
+        (get-fields 't-doc-pt))
+
+  (test '((comment "RGB.")
+          (enum t-doc-color (red green blue)))
+        (semen-process
+         '((enum t-doc-color "RGB." (red green blue)))))
+
+  (test '((comment "Either.")
+          (union t-doc-val ((i int) (f float))))
+        (semen-process
+         '((union t-doc-val "Either." ((i int) (f float))))))
+)