forked from alex-eg/sex
243 lines
10 KiB
Scheme
243 lines
10 KiB
Scheme
;;; 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
|
|
" (do" ; 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)))))))
|