semen: process fn docstrings

semen.scm

@@ -140,6 +140,10 @@
   (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)))
@@ -153,6 +157,55 @@
       (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
@@ -171,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))
+  (let-values (((doc sex-fn)
-         (expanded (macro-expand sex-fn))
+                (extract-fn-docstring (strip-fn-header-comments sex-fn-raw))))
-         (env (make-hash-table))
+    (let* ((expanded (macro-expand sex-fn))
-         (processed
+           (env (make-hash-table))
-          (walk-form
+           (processed
-           expanded
+            (walk-form
-           fn-walker
+             expanded
-           (begin
+             fn-walker
-             (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
+             (begin
-             (set! (hash-table-ref env :lambda-counter) 0)
+               (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
-             (set! (hash-table-ref env :lambda-aux-code) (list))
+               (set! (hash-table-ref env :lambda-counter) 0)
-             env))))
+               (set! (hash-table-ref env :lambda-aux-code) (list))
-
+               env))))
-    (cons processed
+      (with-docstring doc processed
-          (append (hash-table-ref env :lambda-aux-code) acc))))
+                      (append (hash-table-ref env :lambda-aux-code) acc)))))
 
 (define (fn-walker form env)
   (if (eq? 'lambda (car form))
@@ -216,8 +269,9 @@
 
 ;;; Record the named structs, unions and enums in the type database
 (define (process-struct sex-struct acc)
-  (register-aggregate! sex-struct)
+  (let-values (((doc form) (extract-aggregate-docstring sex-struct)))
-  (cons sex-struct acc))
+    (register-aggregate! form)
+    (with-docstring doc form acc)))
 
 (define (register-aggregate! form)
   (let* ((f (if (eq? (car form) 'pub) (cdr form) form))