TMP

semen.scm

@@ -140,16 +140,82 @@
   (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 (car fn-form) '(pub extern)) 5 4))
+
+(define (fn-core form)
+  ;; The (fn name args rettype . body) list, without pub/extern
+  (if (memq (car 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)))
+    (cond
+     ((null? fs)
+      (values #f forms))
+     ((comment-form? (car fs))
+      (loop (cdr fs) (cons (car fs) prefix)))
+     ((string? (car fs))
+      (values (car fs) (append (reverse prefix) (cdr fs))))
+     (else
+      (values #f forms)))))
+
+(define (extract-fn-docstring fn-form)
+  (let ((n (fn-header-length fn-form)))
+    (if (< (length fn-form) n)
+        (values #f fn-form)
+        (let-values (((doc body) (take-leading-docstring (drop fn-form n))))
+          (if doc
+              (values doc
+                      (copy-form-source! fn-form
+                                         (append (take fn-form n) body)))
+              (values #f fn-form))))))
+
+(define (extract-aggregate-docstring form)
+  ;; ([pub] struct|union|enum name "doc" (fields ...) . attrs)
+  ;; A string immediately after the name is the docstring; comments
+  ;; between name and fields are not skipped, they already confuse the
+  ;; writer
+  (let* ((pub? (eq? (car form) 'pub))
+         (core (if pub? (cdr form) form)))
+    (if (and (pair? (cdr core))
+             (symbol? (cadr core))
+             (pair? (cddr core))
+             (string? (caddr core)))
+        (let ((new-core (cons (car core)
+                              (cons (cadr core) (cdddr core)))))
+          (values (caddr core)
+                  (copy-form-source! form
+                                     (if pub?
+                                         (cons 'pub new-core)
+                                         new-core))))
+        (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 +228,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 +273,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))
@@ -232,46 +299,35 @@
 (define (sex-fn? form)
   "The `form` must be toplevel.
 Returns #f if the form is not a function, returns the form otherwise"
-  (match form
-    ((fn . _) form)
-    ((pub fn . _) form)
-    (else #f)))
+  (and (non-empty-list? form)
+       (let ((core (fn-core form)))
+         (and (pair? core) (eq? (car core) 'fn) form))))
 
 (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)))
-
 (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)))
+  (cadr (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)))
+  (caddr (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"))
+  (cadddr (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)))