add source line number preservation

For source-level debug. Add --line-directives option, defaulted to
statement. Disabled when used with -C. Explicit non-none value
overrides disabling when -C is present

fmt-c-writer.module.scm

@@ -1,3 +1,3 @@
 (module fmt-c-writer (emit-c
-                      sex-fmt-current-file)
+                      sex-line-directives)
   "fmt-c-writer.scm")

fmt-c-writer.scm

@@ -15,15 +15,62 @@
   srfi-13                               ; strings
   utils)
 
-;;; Map a procedure over every leaf of a tree, preserving its shape.
+;;; egg `tree' not ported to CHICKEN 6 yet
-;;; Was the `tree' egg, which has not been ported to CHICKEN 6. (Its
-;;; `flatten', also used here, comes from brev-separate.)
 (define (tree-map f tree)
   (cond ((null? tree) (list))
         ((pair? tree) (cons (tree-map f (car tree))
                             (tree-map f (cdr tree))))
         (else (f tree))))
 
+;;; How much #line information to emit:
+;;;
+;;;   statement -- before every statement.
+;;;   toplevel  -- one directive per toplevel form.
+;;;   none      -- none at all, for reading -C output by eye.
+(define sex-line-directives (make-parameter 'statement))
+
+(define (anchor-statements?)
+  (eq? (sex-line-directives) 'statement))
+
+(define (line-directive src)
+  ;; `%line' is fmt-c's #line directive. cpp-line concatenates its
+  ;; second argument verbatim, so the file name arrives already quoted.
+  `(%line ,(cdr src) ,(fmt #f #\" (car src) #\")))
+
+(define (walk-body stmts)
+  "Walk a statement list, re-anchoring each statement that has a known
+source location. Only statement positions may be walked this way: a
+#line inside an expression is a C syntax error."
+  (if (anchor-statements?)
+      (append-map (lambda (s)
+                    (let ((src (form-source s)))
+                      (if src
+                          (list (line-directive src) (walk-expr s))
+                          (list (walk-expr s)))))
+                  stmts)
+      (map walk-expr stmts)))
+
+(define (walk-stmt s)
+  "A statement in a slot that holds exactly one form -- an `if' arm.
+Splicing is not possible there, since c-if reads anything past the arm
+as an `else if' chain, so the anchor and the statement are wrapped in
+`%begin': a statement sequence that emits no braces of its own (the
+surrounding c-block supplies them)."
+  (let ((src (and (pair? s) (anchor-statements?) (form-source s))))
+    (if src
+        `(%begin ,(line-directive src) ,(walk-expr s))
+        (walk-expr s))))
+
+(define (walk-if-clauses clauses)
+  "(test stmt test stmt ... [else-stmt]) -- tests stay expressions."
+  (let loop ((cs clauses) (acc (list)))
+    (cond ((null? cs) (reverse acc))
+          ((null? (cdr cs))                    ; trailing else statement
+           (reverse (cons (walk-stmt (car cs)) acc)))
+          (else (loop (cddr cs)
+                      (cons (walk-stmt (cadr cs))
+                            (cons (walk-expr (car cs)) acc)))))))
+
 (define (unkebabify sym)
   (case sym
     ((-) sym)
@@ -90,6 +137,28 @@
     (('c-or . rest) (apply c-or (map walk-expr rest)))
     (('c-bit-or . rest) (apply c-bit-or (map walk-expr rest)))
     (('c-bit-or= . rest) (apply c-bit-or= (map walk-expr rest)))
+
+    ;; Statement positions. These are the only places a #line may go,
+    ;; and each is spliced or wrapped according to what the
+    ;; corresponding fmt-c procedure accepts.
+    (('begin . stmts) (cons '%block-begin (walk-body stmts)))
+    (('if . clauses) (cons 'if (walk-if-clauses clauses)))
+    (('while test . body)
+     (cons* 'while (walk-expr test) (walk-body body)))
+    (('for init test step . body)
+     (cons* 'for (walk-expr init) (walk-expr test) (walk-expr step)
+            (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)
+     (cons* 'switch (walk-expr e) (map walk-expr clauses)))
+    (('case v . body) (cons* 'case (walk-expr v) (walk-body body)))
+    (('case/fallthrough v . body)
+     (cons* 'case/fallthrough (walk-expr v) (walk-body body)))
+    (('default . body) (cons 'default (walk-body body)))
+
     (else (map walk-expr form))))
 
 (define (walk-var form)
@@ -160,7 +229,7 @@
        ,(atom-to-fmt-c name)
        ,(walk-arglist args)
        .
-       ,(walk-expr maybe-body)))))
+       ,(walk-body maybe-body)))))
 
 ;;; TODO: isn't there a better way?
 (define (is-probably-type form)
@@ -264,22 +333,14 @@
     (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
     (else (walk-expr form))))
 
-(define (get-line-num form)
-  ;; Source line recorded by our reader (see utils' form-line), or #f
-  ;; for forms the reader did not produce (prelude, macro expansions).
-  (form-line form))
-
-(define sex-fmt-current-file (make-parameter "/dev/null"))
-(define sex-fmt-line-num (make-parameter 0))
-
-(define (line-directive-string)
-  (fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
-
 (define (emit-c sex-forms)
   (for-each (lambda (form)
-              (let ((start-line (get-line-num form)))
+              ;; Forms the reader did not produce -- the prelude, and
-                (when start-line
+              ;; anything a macro built that we could not attribute --
-                  (sex-fmt-line-num start-line)
+              ;; have no location and get no directive.
-                  (fmt #t (line-directive-string) nl)))
+              (let ((src (and (not (eq? (sex-line-directives) 'none))
+                              (form-source form))))
+                (when src
+                  (fmt #t (c-expr (line-directive src)))))
               (fmt #t (c-expr (process-toplevel-form form)) nl))
             sex-forms))

reader.scm

@@ -34,6 +34,13 @@
 (define (peek port)
   (peek-char port))
 
+;;; Record where a form started. Called with the line of the opening
+;;; delimiter, sampled before it is consumed
+(define (stamp form line)
+  (when (pair? form)
+    (set-form-source! form (current-source-file) line))
+  form)
+
 (define (delimiter? c)
   (or (eof-object? c)
       (char-whitespace? c)
@@ -69,11 +76,19 @@
   (let ((c (peek port)))
     (cond
      ((eof-object? c) c)
-     ((char=? c #\() (get-ch port) (read-list port close-paren))
+     ((char=? c #\()
-     ((char=? c #\[) (get-ch port) (cons '¤ (read-list port close-bracket)))
+      (let ((line (current-line)))
+        (get-ch port)
+        (stamp (read-list port close-paren) line)))
+     ((char=? c #\[)
+      (let ((line (current-line)))
+        (get-ch port)
+        (stamp (cons '¤ (read-list port close-bracket)) line)))
      ((char=? c #\)) (get-ch port) close-paren)
      ((char=? c #\]) (get-ch port) close-bracket)
-     ((char=? c #\;) (read-comment port))
+     ((char=? c #\;)
+      (let ((line (current-line)))
+        (stamp (read-comment port) line)))
      ((char=? c #\") (read-string-lit port))
      ((char=? c #\') (get-ch port) (list 'quote (read-datum port)))
      ((char=? c #\`) (get-ch port) (list 'quasiquote (read-datum port)))
@@ -239,8 +254,7 @@
   (parameterize ((current-line 1))
     (let loop ((acc (list)))
       (skip-whitespace port)
-      (let ((line (current-line))
+      (let ((tok (next-token port)))
-            (tok (next-token port)))
         (cond
          ((eof-object? tok) (reverse acc))
          ((or (eq? tok close-paren)
@@ -249,18 +263,22 @@
          ((eq? tok dot-token)
           (error "Unexpected . at top level"))
          (else
-          (when (pair? tok)
-            (set-form-line! tok line))
           (loop (cons tok acc))))))))
 
 ;;; Entry point: read all forms from a file, or from the current input
 ;;; port when the source is 'stdin
 (define (read-from-file file)
-  (with-directory file
+  ;; Resolve the name before with-directory moves us, so an imported
-    (with-input-from-file (pathname-strip-directory file)
+  ;; module's forms carry that module's path rather than the importer's
-      (lambda () (parse-all (current-input-port))))))
+  (let ((source-file (to-absolute-pathname file)))
+    (with-directory file
+      (with-input-from-file (pathname-strip-directory file)
+        (lambda ()
+          (parameterize ((current-source-file source-file))
+            (parse-all (current-input-port))))))))
 
 (define (read-raw-forms input-source)
   (if (eq? input-source 'stdin)
-      (parse-all (current-input-port))
+      (parameterize ((current-source-file "stdin"))
+        (parse-all (current-input-port)))
       (read-from-file input-source)))

semen.scm

@@ -47,10 +47,15 @@
   ;;
   ;; Single form we just cons to the top of rest-forms, but multiple
   ;; forms have to be appended to the rest-forms.
-  (let ((res (apply-macro macro-form)))
+  (let ((res (apply-macro macro-form))
+        (src (form-source macro-form)))
+    ;; An expansion is fresh structure with no location of its own. Give
+    ;; it the call site's, the way cpp attributes a macro body to where
+    ;; the macro was used
     (if (list? (car res))
-        (append res rest-forms)
+        (append (map (lambda (f) (stamp-form-source! f src)) res)
-        (cons res rest-forms))))
+                rest-forms)
+        (cons (stamp-form-source! res src) rest-forms))))
 
 (define (match-sex-form sex-form acc)
   (match sex-form
@@ -78,7 +83,7 @@
 
     ((or ('typedef new-type target)
          ('pub 'typedef new-type target))
-     (process-typedef new-type target acc))
+     (process-typedef sex-form new-type target acc))
 
     (else (assert #f (fmt #f "Unknown top level form " sex-form)))))
 
@@ -134,8 +139,8 @@
 
 ;;; Typdef
 
-(define (process-typedef new-type target acc)
+(define (process-typedef form new-type target acc)
-  (cons `(typedef ,target ,new-type) acc))
+  (cons (copy-form-source! form `(typedef ,target ,new-type)) acc))
 
 ;;; Fn processing
 
@@ -148,12 +153,16 @@
   ;; 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 loop ((form fn-form) (kept 0) (acc (list)))
+    ;; This always rebuilds the list, so the location has to be carried
-      (cond
+    ;; over explicitly -- otherwise every function loses it
-       ((null? form) (reverse acc))
+    (copy-form-source!
-       ((= kept header-count) (append (reverse acc) form))
+     fn-form
-       ((comment-form? (car form)) (loop (cdr form) kept acc))
+     (let loop ((form fn-form) (kept 0) (acc (list)))
-       (else (loop (cdr form) (+ kept 1) (cons (car form) acc)))))))
+       (cond
+        ((null? form) (reverse acc))
+        ((= kept header-count) (append (reverse acc) form))
+        ((comment-form? (car form)) (loop (cdr form) kept acc))
+        (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))
@@ -193,7 +202,8 @@
     (('lambda ret-type arglist captures . body)
      ;; Captures are ignored for now, but
      ;; we'll need them for TODO: closures support
-     (process-fn `(fn ,ret-type ,name ,arglist ,@body) (list)))
+     (process-fn (copy-form-source! form `(fn ,ret-type ,name ,arglist ,@body))
+                 (list)))
     (else (assert #f (fmt #f "Malformed lambda " form)))))
 
 ;;; Structs

sex-fmt-c.scm

@@ -845,8 +845,7 @@
 
   (define (c-label name)
     (lambda (st)
-      (let ((indent (make-space (max 0 (- (fmt-col st) 2)))))
+      ((cat name ":" fl) st)))
-        ((cat fl indent name ":" fl) st))))
 
   (define c-break
     (c-wrap-stmt (dsp "break")))

sex-modules.scm

@@ -71,9 +71,9 @@
        ((fn)                 ; replace with prototype
         ;; fn type name (arg-list) (body)
         ;; 1    2   3       4 - we need first 4
-        (cons (take (cdr form) 4) acc))
+        (cons (copy-form-source! form (take (cdr form) 4)) acc))
        ((define defmacro import include struct typedef union var)
-        (cons (cdr form) acc))
+        (cons (copy-form-source! form (cdr form)) acc))
        (else (error "Pub what? " (cadr form)))))
     (else acc)))
 

sexc.scm

@@ -50,7 +50,14 @@
                     (pad padding) "If -E or -m options are provided, defaults to stdout")
               (required #f)
               (value #t)
-              (single-char #\o)))))
+              (single-char #\o))
+      (line-directives
+       ,(fmt #f "How much #line information to emit: statement (default)," nl
+             (pad padding) "toplevel, or none. `statement' is what makes a debugger" nl
+             (pad padding) "land on the right source line; `none' is for reading -C" nl
+             (pad padding) "output by eye")
+       (required #f)
+       (value #t)))))
 
 (define (print-help)
   (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
@@ -72,6 +79,13 @@
 (define (get-c-compiler-args args)
   (filter (fn (string-prefix? "-" x)) (get-rest-args args)))
 
+(define (line-directives-arg args)
+  (let ((v (get-arg args 'line-directives "statement")))
+    (cond ((equal? v "statement") 'statement)
+          ((equal? v "toplevel") 'toplevel)
+          ((equal? v "none") 'none)
+          (else (error "--line-directives must be statement, toplevel or none, got" v)))))
+
 (define (get-input-file args)
   (let ((rest-args (get-rest-args args)))
     (if (null? rest-args)
@@ -156,9 +170,14 @@
          (return #f))
        (load-persistent-module-paths)
 
-       (if (eq? input 'stdin)
+       ;; The file name in a #line directive now comes from the form's
-           (sex-fmt-current-file "stdin")
+       ;; own recorded location, so imported modules report themselves
-           (sex-fmt-current-file (to-absolute-pathname input)))
+       ;; rather than the unit that imported them
+       (sex-line-directives (line-directives-arg args))
+       (when (and (get-arg args 'emit-c #f)
+                  (not (get-arg args 'line-directives #f)))
+         (sex-line-directives 'none))
+
        (let* ((raw-forms (append prelude (read-raw-forms input)))
               (sex-forms (semantic-process-forms raw-forms input)))
          (if (or (get-arg args 'macro-expand #f)

tests/Makefile

@@ -6,7 +6,7 @@ MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
 MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
 SEX_OBJ = $(MODULES:%=%.o)
 
-TESTS = basic semen reader fmt-c-writer utils
+TESTS = basic semen reader fmt-c-writer utils line-directives
 TEST_SRCS = $(TESTS:%=%.scm)
 
 sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)

tests/line-directives.scm

@@ -0,0 +1,242 @@
+;;; Source-line mapping.
+;;;
+;;; Every construct in the generated C must be attributed, through
+;;; #line directives, to the source line of the Sex form it came from.
+;;; That mapping is the whole basis of source-level debugging.
+;;;
+;;; It cannot be left to the C compiler's implicit line counting,
+;;; because a Sex form and its C rendering may or may not occupy the
+;;; same number of lines. A call written across four lines renders as
+;;; one C line; a one-line `for' renders as a braced block of
+;;; four. Either way every following line drifts, and the drift
+;;; accumulates over a function body.
+;;;
+;;; The tests below pin one construct per statement kind. Each carries
+;;; a unique numeric marker chosen so that it lands on the first C line
+;;; that construct emits; the marker is then located in the fixture (to
+;;; get the true source line) and in the C output (to get the line the
+;;; directives claim). The two must agree.
+
+(import (chicken port)
+        (chicken string)
+        srfi-1
+        srfi-13
+        fmt-c-writer
+        reader
+        semen
+        utils)
+
+;;; ------------------------------------------------------------------
+;;; Fixture. Line numbers are in the trailing comments; keep them
+;;; correct when editing. Markers are distinct 3-digit integers, and no
+;;; other literal in the fixture contains one as a substring.
+
+(define fixture-lines
+  '("(include stdio.h)"                   ;  1
+    ""                                    ;  2
+    "(struct pt"                          ;  3  multi-line toplevel
+    "  ((x int)"                          ;  4
+    "   (y int)))"                        ;  5
+    ""                                    ;  6
+    "(enum color (red green blue))"       ;  7
+    ""                                    ;  8
+    "(typedef byte u8)"                   ;  9
+    ""                                    ; 10
+    "(define MAXN 101)"                   ; 11
+    ""                                    ; 12
+    "(var gvar int 102)"                  ; 13
+    ""                                    ; 14
+    "(extern var evar int)"               ; 15
+    ""                                    ; 16
+    "(fn helper ((a int)) int)"           ; 17  prototype
+    ""                                    ; 18
+    "(pub fn main () int"                 ; 19
+    "  (var mvar int 103)"                ; 20
+    "  (var p (struct pt))"               ; 21
+    "  (var arr [int 4])"                 ; 22
+    "  (= (. p x) 104)"                   ; 23
+    "  (+= mvar 105)"                     ; 24
+    "  (++ mvar)"                         ; 25
+    "  (= [arr 0] 106)"                   ; 26
+    "  (putchar (+ 107"                   ; 27  form spanning 3 lines,
+    "             mvar"                   ; 28  emitted as one C line:
+    "             0))"                    ; 29  everything after drifts
+    "  (var aftercall int 108)"           ; 30
+    "  (if (< mvar 109)"                  ; 31
+    "      (putchar 110))"                ; 32
+    "  (if (< mvar 111)"                  ; 33
+    "      (putchar 112)"                 ; 34
+    "      (putchar 113))"                ; 35
+    "  (while (< mvar 114)"               ; 36
+    "    (++ mvar))"                      ; 37
+    "  (for (var i int 115)"              ; 38
+    "       (< i 116)"                    ; 39
+    "       (++ i)"                       ; 40
+    "    (continue))"                     ; 41
+    "  (switch 117"                       ; 42
+    "    (case 118"                       ; 43
+    "      (putchar 119)"                 ; 44
+    "      (break))"                      ; 45
+    "    (default"                        ; 46
+    "      (putchar 120)))"               ; 47
+    "  (begin"                            ; 48
+    "    (var bvar int 121)"              ; 49
+    "    (putchar bvar))"                 ; 50
+    "  (goto done)"                       ; 51
+    "  (: done)"                          ; 52
+    "  (var svar u64 (sizeof (struct pt)))" ; 53
+    "  (var cvar int (cast mvar int))"    ; 54
+    "  (return 122))"                     ; 55
+    ))
+
+(define fixture (string-intersperse fixture-lines "\n"))
+
+;;; ------------------------------------------------------------------
+;;; Pipeline and #line accounting
+
+(define (compile-to-c source)
+  "Run reader -> semen -> writer on SOURCE, returning the generated C.
+parse-all is called directly rather than through read-raw-forms so the
+fixture can be given a file name: a location is (file . line), and the
+file is what makes an imported module report itself rather than the unit
+that imported it."
+  (let ((forms (with-input-from-string source
+                 (lambda ()
+                   (parameterize ((current-source-file "fixture.sex"))
+                     (parse-all (current-input-port)))))))
+    (with-output-to-string
+      (lambda () (emit-c (semen-process forms))))))
+
+(define (split-lines s)
+  (let loop ((i 0) (start 0) (acc (list)))
+    (cond
+     ((= i (string-length s))
+      (reverse (if (> i start) (cons (substring s start i) acc) acc)))
+     ((char=? (string-ref s i) #\newline)
+      (loop (+ i 1) (+ i 1) (cons (substring s start i) acc)))
+     (else (loop (+ i 1) start acc)))))
+
+(define (directive-line text)
+  "The N of a `#line N \"file\"' directive, or #f if TEXT is not one."
+  (let ((t (string-trim text)))
+    (and (string-prefix? "#line " t)
+         (string->number (car (string-split (substring t 6) " "))))))
+
+(define (directive-file text)
+  "The file name of a `#line N \"file\"' directive, or #f."
+  (let ((t (string-trim text)))
+    (and (string-prefix? "#line " t)
+         (let ((parts (string-split (substring t 6) " ")))
+           (and (pair? (cdr parts)) (cadr parts))))))
+
+(define (attributed-lines c-source)
+  "Pair every non-directive C line with the source line it is
+attributed to. `#line N' says the *next* physical line is N; each line
+after that is one more. Lines before the first directive get #f."
+  (let loop ((lines (split-lines c-source)) (cur #f) (acc (list)))
+    (if (null? lines)
+        (reverse acc)
+        (cond
+         ((directive-line (car lines))
+          => (lambda (n) (loop (cdr lines) n acc)))
+         (else
+          (loop (cdr lines)
+                (and cur (+ cur 1))
+                (cons (cons (car lines) cur) acc)))))))
+
+(define (sex-line token)
+  "1-based fixture line containing TOKEN."
+  (let loop ((lines fixture-lines) (n 1))
+    (cond ((null? lines) #f)
+          ((string-contains (car lines) token) n)
+          (else (loop (cdr lines) (+ n 1))))))
+
+(define (claimed-line attributed token)
+  "The source line the generated C attributes TOKEN to."
+  (let ((hit (find (lambda (p) (string-contains (car p) token)) attributed)))
+    (and hit (cdr hit))))
+
+;;; ------------------------------------------------------------------
+
+(define c-out (compile-to-c fixture))
+(define attributed (attributed-lines c-out))
+
+;;; MAPS checks a construct found under the same token on both sides.
+;;; MAPS/TOKENS is for constructs that are spelled differently in Sex
+;;; and in C (`(break)' -> `break;', `(: done)' -> `done:').
+(define-syntax maps
+  (syntax-rules ()
+    ((maps name token)
+     (test name (sex-line token) (claimed-line attributed token)))))
+
+(define-syntax maps/tokens
+  (syntax-rules ()
+    ((maps/tokens name sex-token c-token)
+     (test name (sex-line sex-token) (claimed-line attributed c-token)))))
+
+(test-group "line-directives"
+
+  ;; Toplevel forms
+  (test-group "toplevel"
+    (maps/tokens "include"        "(include stdio.h)" "#include")
+    (maps/tokens "struct"         "(struct pt"        "struct pt {")
+    (maps/tokens "enum"           "(enum color"       "enum color {")
+    (maps/tokens "typedef"        "(typedef byte u8)" "typedef u8 byte;")
+    (maps         "define"        "101")
+    (maps         "global var"    "102")
+    (maps/tokens "extern var"     "(extern var evar" "extern int evar")
+    (maps/tokens "prototype"      "(fn helper"       "int helper (int a)")
+    (maps/tokens "function"       "(pub fn main"     "int main (void)"))
+
+  ;; Declarations and expression statements
+  (test-group "statements"
+    (maps "var decl"              "103")
+    (maps "member assignment"     "104")
+    (maps "compound assignment"   "105")
+    (maps/tokens "increment"      "(++ mvar)" "++mvar;")
+    (maps "array assignment"      "106")
+
+    ;; The point of the whole exercise: a call spread over three source
+    ;; lines collapses to one C line, so the statement after it must be
+    ;; re-anchored or it is reported two lines too early. The call
+    ;; itself anchors to the line it *starts* on, which is where a
+    ;; debugger should report it.
+    (maps "multi-line call"       "107")
+    (maps "statement after it"    "108"))
+
+  ;; Control flow
+  (test-group "control flow"
+    (maps "if"                    "109")
+    (maps "if body"               "110")
+    (maps "if/else"               "111")
+    (maps "then branch"           "112")
+    (maps "else branch"           "113")
+    (maps "while"                 "114")
+    (maps "for"                   "115")
+    (maps/tokens "continue"       "(continue)" "continue;")
+    (maps "switch"                "117")
+    ;; The `case 118:' label line itself is deliberately not pinned.
+    ;; c-switch requires every clause to be a case/default form and
+    ;; rejects anything else, so no anchor can be placed between
+    ;; clauses. The clause *bodies* are anchored from inside, which is
+    ;; what matters -- a label is not a statement a debugger stops on.
+    (maps "case body"             "119")
+    (maps/tokens "break"          "(break)" "break;")
+    (maps "default body"          "120")
+    (maps "block"                 "121")
+    (maps/tokens "goto"           "(goto done)" "goto done;")
+    (maps/tokens "label"          "(: done)"    "done:")
+    (maps "return"                "122"))
+
+  ;; Expressions that are their own statement
+  (test-group "expressions"
+    (maps/tokens "sizeof" "(var svar" "sizeof")
+    (maps/tokens "cast"   "(var cvar" "(int)mvar"))
+
+  ;; A location is (file . line); every directive must name the file the
+  ;; form was read from.
+  (test-group "file name"
+    (test "every directive names the fixture"
+          (list "\"fixture.sex\"")
+          (delete-duplicates
+           (filter values (map directive-file (split-lines c-out)))))))

tests/run.scm

@@ -6,6 +6,7 @@
 (include "reader.scm")
 (include "fmt-c-writer.scm")
 (include "utils.scm")
+(include "line-directives.scm")
 
 ;;; Should be the last in the test suite
 (test-exit)

tools/sextest/utils.module.scm

@@ -5,8 +5,13 @@
      list-split
      list-join
      recons
-     set-form-line!
+     current-source-file
+     set-form-source!
+     form-source
+     form-file
      form-line
+     copy-form-source!
+     stamp-form-source!
      with-directory
      )
   "../../utils.scm")

utils.module.scm

@@ -5,8 +5,13 @@
      list-split
      list-join
      recons
-     set-form-line!
+     current-source-file
+     set-form-source!
+     form-source
+     form-file
      form-line
+     copy-form-source!
+     stamp-form-source!
      with-directory
      )
   "utils.scm")

utils.scm

@@ -1,5 +1,6 @@
 (import
   scheme
+  (scheme base)                         ; make-parameter
   (chicken base)
   (chicken pathname)
   (chicken process-context)
@@ -64,19 +65,53 @@
   (if (and (eq? new-car (car old-cons))
            (eq? new-cdr (cdr old-cons)))
       old-cons
-      (cons new-car new-cdr)))
+      ;; A rebuilt cell is still the same source form, so it keeps the
+      ;; same location
+      (copy-form-source! old-cons (cons new-car new-cdr))))
 
 ;;; Source-location map.
-;;; Our hand-written reader records the source line of each form here,
+;;; Our hand-written reader records the source location of each form
-;;; keyed by the form's cons cell (eq?). This replaces CHICKEN's
+;;; here, keyed by the form's cons cell (eq?). This replaces CHICKEN's
-;;; read-with-source-info / get-line-number, which only works when
+;;; read-with-source-info / get-line-number, which only works when forms
-;;; forms are produced by the built-in `read'. The key survives
+;;; are produced by the built-in `read'.
-;;; semantic processing because `recons' preserves the original cons
+;;;
-;;; cell for forms it does not structurally change.
+;;; A location is (file . line). The file matters because imported
-(define +form-lines+ (make-hash-table eq?))
+;;; modules paste their public forms into the current unit: those forms
+;;; originate in another file and must be reported as such
+(define +form-sources+ (make-hash-table eq?))
 
-(define (set-form-line! form line)
+;;; The file `parse-all' is currently reading. Bound by the reader
-  (hash-table-set! +form-lines+ form line))
+(define current-source-file (make-parameter "<unknown>"))
+
+(define (set-form-source! form file line)
+  (hash-table-set! +form-sources+ form (cons file line)))
+
+(define (form-source form)
+  (hash-table-ref/default +form-sources+ form #f))
+
+(define (form-file form)
+  (let ((src (form-source form)))
+    (and src (car src))))
 
 (define (form-line form)
-  (hash-table-ref/default +form-lines+ form #f))
+  (let ((src (form-source form)))
+    (and src (cdr src))))
+
+(define (copy-form-source! from to)
+  "Give TO the location of FROM, if FROM has one. Returns TO, so it can
+wrap a form-building expression."
+  (let ((src (form-source from)))
+    (when (and src (pair? to))
+      (hash-table-set! +form-sources+ to src)))
+  to)
+
+(define (stamp-form-source! form src)
+  "Give FORM and every subform that has none the location SRC. Used for
+macro expansions, which inherit the location of the call site the way a
+cpp macro does. Forms that already have a location keep it."
+  (when (and src (pair? form))
+    (unless (form-source form)
+      (hash-table-set! +form-sources+ form src))
+    (stamp-form-source! (car form) src)
+    (stamp-form-source! (cdr form) src))
+  form)