pkulev/sex
1
0
Fork 0
forked from alex-eg/sex
Code Pull Requests Activity

add source line number preservation

Browse Source 
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
This commit is contained in:
alex-eg
2026-09-09 14:00:53 +03:00
parent 528f26b7ef
commit d83ee32f12
13 changed files with 461 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
fmt-c-writer.module.scm
View File

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

99
fmt-c-writer.scm
View File

@@ -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))

40
reader.scm
View File

@@ -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)))

36
semen.scm
View File

@@ -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

3
sex-fmt-c.scm
View File

@@ -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")))

4
sex-modules.scm
View File

@@ -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)))

27
sexc.scm
View File

@@ -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)

2
tests/Makefile
View File

@@ -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)

242
tests/line-directives.scm Normal file
View File

@@ -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)))))))

1
tests/run.scm
View File

@@ -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)

7
tools/sextest/utils.module.scm
View File

@@ -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")

7
utils.module.scm
View File

@@ -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")

57
utils.scm
View File

@@ -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 "<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)