_run-pp.scm (3397B)
1 ;; tests/cc-pp/_run-pp.scm — driver for cc-pp .c fixtures. 2 ;; 3 ;; argv[0] = scheme1 binary path 4 ;; argv[1] = combined source (assembled by the test runner via catm) 5 ;; argv[2] = .c fixture path 6 ;; 7 ;; Slurps the fixture, runs lex-tokenize then pp-expand, prints one 8 ;; tok per line on stdout in the cc-lex / cc-pp golden format. 9 ;; Mirrors tests/cc-lex/_run-lex.scm with one extra phase (pp). 10 11 (define (%hex-nibble n) 12 (if (< n 10) (+ n 48) (+ n 87))) 13 14 (define (%bv-escape bv) 15 (let* ((n (bytevector-length bv)) 16 (buf (make-buf))) 17 (buf-push! buf "\"") 18 (let loop ((i 0)) 19 (cond 20 ((= i n) 21 (buf-push! buf "\"") 22 (buf-flush buf)) 23 (else 24 (let ((b (bytevector-u8-ref bv i))) 25 (cond 26 ((= b 10) (buf-push! buf "\\n")) 27 ((= b 9) (buf-push! buf "\\t")) 28 ((= b 13) (buf-push! buf "\\r")) 29 ((= b 92) (buf-push! buf "\\\\")) 30 ((= b 34) (buf-push! buf "\\\"")) 31 ((and (>= b 32) (<= b 126)) 32 (buf-push! buf (bv-of-byte b))) 33 (else 34 (let* ((hi (%hex-nibble (bit-and (arithmetic-shift b -4) 15))) 35 (lo (%hex-nibble (bit-and b 15)))) 36 (buf-push! buf "\\x") 37 (buf-push! buf (bv-of-byte hi)) 38 (buf-push! buf (bv-of-byte lo))))) 39 (loop (+ i 1)))))))) 40 41 (define (%fmt-value kind val) 42 (cond 43 ((eq? kind 'IDENT) (%bv-escape val)) 44 ((eq? kind 'STR) (%bv-escape val)) 45 ((eq? kind 'INT) (format "~d" val)) 46 ((eq? kind 'CHAR) (format "~d" val)) 47 ((eq? kind 'KW) (format "~a" val)) 48 ((eq? kind 'PUNCT) (format "~a" val)) 49 ((eq? kind 'HASH) "#f") 50 ((eq? kind 'NL) "#f") 51 ((eq? kind 'EOF) "#f") 52 (else (format "~a" val)))) 53 54 (define (%fmt-tok t) 55 (let* ((kind (tok-kind t)) 56 (val (tok-value t)) 57 (loc (tok-loc t)) 58 (file (loc-file loc)) 59 (line (loc-line loc)) 60 (col (loc-col loc))) 61 (bv-cat (list "(" (format "~a" kind) " " 62 (%fmt-value kind val) " " 63 (%bv-escape file) " " 64 (format "~d" line) " " 65 (format "~d" col) ")" 66 NL-BV)))) 67 68 (define (%emit-toks toks) 69 (cond 70 ((null? toks) #t) 71 (else 72 (write-bv-fd 1 (%fmt-tok (car toks))) 73 (%emit-toks (cdr toks))))) 74 75 (define (%basename path) 76 (let* ((n (bytevector-length path))) 77 (let loop ((i (- n 1))) 78 (cond 79 ((< i 0) path) 80 ((= (bytevector-u8-ref path i) 47) 81 (bv-slice path (+ i 1) n)) 82 (else (loop (- i 1))))))) 83 84 (define (%run-pp path) 85 (let ((op (open-input path))) 86 (if (not (car op)) 87 (begin 88 (write-bv-fd 2 "run-pp: cannot open ") 89 (write-bv-fd 2 path) 90 (write-bv-fd 2 NL-BV) 91 (sys-exit 2)) 92 (let* ((src (slurp-fd (port-fd (cdr op)))) 93 (file (%basename path)) 94 (toks (lex-tokenize src file)) 95 (expanded (pp-expand toks '()))) 96 (sys-close (port-fd (cdr op))) 97 (%emit-toks expanded) 98 (sys-exit 0))))) 99 100 (let ((args (argv))) 101 (cond 102 ((null? args) (sys-exit 2)) 103 ((null? (cdr args)) (sys-exit 2)) 104 ((null? (cdr (cdr args))) 105 (write-bv-fd 2 "run-pp: missing fixture path\n") 106 (sys-exit 2)) 107 (else (%run-pp (car (cdr (cdr args)))))))