From d83ee32f12bd8e450f5c95af1423188805aa6431 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 9 Sep 2026 14:00:53 +0300 Subject: [PATCH] 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 | 2 +- fmt-c-writer.scm | 99 +++++++++++--- reader.scm | 40 ++++-- semen.scm | 36 +++-- sex-fmt-c.scm | 3 +- sex-modules.scm | 4 +- sexc.scm | 27 +++- tests/Makefile | 2 +- tests/line-directives.scm | 242 +++++++++++++++++++++++++++++++++ tests/run.scm | 1 + tools/sextest/utils.module.scm | 7 +- utils.module.scm | 7 +- utils.scm | 57 ++++++-- 13 files changed, 461 insertions(+), 66 deletions(-) create mode 100644 tests/line-directives.scm diff --git a/fmt-c-writer.module.scm b/fmt-c-writer.module.scm index e7e57fe..5500894 100644 --- a/fmt-c-writer.module.scm +++ b/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") diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index bfd9c93..b80fcbb 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -15,15 +15,62 @@ srfi-13 ; strings utils) -;;; Map a procedure over every leaf of a tree, preserving its shape. -;;; Was the `tree' egg, which has not been ported to CHICKEN 6. (Its -;;; `flatten', also used here, comes from brev-separate.) +;;; egg `tree' not ported to CHICKEN 6 yet (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))) - (when start-line - (sex-fmt-line-num start-line) - (fmt #t (line-directive-string) nl))) + ;; Forms the reader did not produce -- the prelude, and + ;; anything a macro built that we could not attribute -- + ;; have no location and get no directive. + (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)) diff --git a/reader.scm b/reader.scm index 95d14be..e902114 100644 --- a/reader.scm +++ b/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 #\[) (get-ch port) (cons '¤ (read-list port close-bracket))) + ((char=? c #\() + (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)) - (tok (next-token port))) + (let ((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 - (with-input-from-file (pathname-strip-directory file) - (lambda () (parse-all (current-input-port)))))) + ;; Resolve the name before with-directory moves us, so an imported + ;; module's forms carry that module's path rather than the importer's + (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))) diff --git a/semen.scm b/semen.scm index 67c6e1c..6bdfcc4 100644 --- a/semen.scm +++ b/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) - (cons res rest-forms)))) + (append (map (lambda (f) (stamp-form-source! f src)) res) + 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) - (cons `(typedef ,target ,new-type) acc)) +(define (process-typedef form new-type target 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))) - (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))))))) + ;; This always rebuilds the list, so the location has to be carried + ;; over explicitly -- otherwise every function loses it + (copy-form-source! + fn-form + (let loop ((form fn-form) (kept 0) (acc (list))) + (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 diff --git a/sex-fmt-c.scm b/sex-fmt-c.scm index f55553e..d6a5aa1 100644 --- a/sex-fmt-c.scm +++ b/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 fl indent name ":" fl) st)))) + ((cat name ":" fl) st))) (define c-break (c-wrap-stmt (dsp "break"))) diff --git a/sex-modules.scm b/sex-modules.scm index 4720e62..5025629 100644 --- a/sex-modules.scm +++ b/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))) diff --git a/sexc.scm b/sexc.scm index 4493f58..34f0cc2 100644 --- a/sexc.scm +++ b/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) - (sex-fmt-current-file "stdin") - (sex-fmt-current-file (to-absolute-pathname input))) + ;; The file name in a #line directive now comes from the form's + ;; own recorded location, so imported modules report themselves + ;; 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) diff --git a/tests/Makefile b/tests/Makefile index c11d025..6950dd6 100644 --- a/tests/Makefile +++ b/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) diff --git a/tests/line-directives.scm b/tests/line-directives.scm new file mode 100644 index 0000000..d1d3576 --- /dev/null +++ b/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))))))) diff --git a/tests/run.scm b/tests/run.scm index 2ea0e53..4f61af1 100644 --- a/tests/run.scm +++ b/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) diff --git a/tools/sextest/utils.module.scm b/tools/sextest/utils.module.scm index 703406a..0eeeae1 100644 --- a/tools/sextest/utils.module.scm +++ b/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") diff --git a/utils.module.scm b/utils.module.scm index 8113c67..f577477 100644 --- a/utils.module.scm +++ b/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") diff --git a/utils.scm b/utils.scm index 7e51b09..430bdb3 100644 --- a/utils.scm +++ b/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, -;;; keyed by the form's cons cell (eq?). This replaces CHICKEN's -;;; read-with-source-info / get-line-number, which only works when -;;; forms are produced by the built-in `read'. The key survives -;;; semantic processing because `recons' preserves the original cons -;;; cell for forms it does not structurally change. -(define +form-lines+ (make-hash-table eq?)) +;;; Our hand-written reader records the source location of each form +;;; here, keyed by the form's cons cell (eq?). This replaces CHICKEN's +;;; read-with-source-info / get-line-number, which only works when forms +;;; are produced by the built-in `read'. +;;; +;;; A location is (file . line). The file matters because imported +;;; 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) - (hash-table-set! +form-lines+ form line)) +;;; The file `parse-all' is currently reading. Bound by the reader +(define current-source-file (make-parameter "")) + +(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)