_run-lex.scm (3962B)
1 ;; tests/cc-lex/run-lex.scm — driver for cc-lex fixtures. 2 ;; 3 ;; Reads a fixture path from (argv) — argv[0] is scheme1's program 4 ;; name; argv[1] is the combined source file (the test runner catm's 5 ;; prelude+lex+driver into one); argv[2] is the .c fixture path. 6 ;; 7 ;; Calls lex-tokenize and prints one line per tok in the cc-lex 8 ;; golden serialization. Run: 9 ;; scheme1 /tmp/c.scm <FIXTURE.c> 10 11 (define (%hex-nibble n) 12 ;; n in 0..15 -> ASCII byte for the lowercase hex digit. 13 (if (< n 10) (+ n 48) (+ n 87))) 14 15 (define (%bv-escape bv) 16 ;; Escape a bv per §2.1: surround with "...", and inside replace 17 ;; \n \t \r \\ \" plus non-ASCII bytes with \xNN. Returns a fresh bv. 18 (let* ((n (bytevector-length bv)) 19 (buf (make-buf))) 20 (buf-push! buf "\"") 21 (let loop ((i 0)) 22 (cond 23 ((= i n) 24 (buf-push! buf "\"") 25 (buf-flush buf)) 26 (else 27 (let ((b (bytevector-u8-ref bv i))) 28 (cond 29 ((= b 10) (buf-push! buf "\\n")) 30 ((= b 9) (buf-push! buf "\\t")) 31 ((= b 13) (buf-push! buf "\\r")) 32 ((= b 92) (buf-push! buf "\\\\")) 33 ((= b 34) (buf-push! buf "\\\"")) 34 ;; Printable ASCII: 32..126 inclusive (except 34/92 above) 35 ((and (>= b 32) (<= b 126)) 36 (buf-push! buf (bv-of-byte b))) 37 (else 38 (let* ((hi (%hex-nibble (bit-and (arithmetic-shift b -4) 15))) 39 (lo (%hex-nibble (bit-and b 15)))) 40 (buf-push! buf "\\x") 41 (buf-push! buf (bv-of-byte hi)) 42 (buf-push! buf (bv-of-byte lo))))) 43 (loop (+ i 1)))))))) 44 45 (define (%fmt-value kind val) 46 ;; Stringify the tok value per §2.1. Returns a bv. 47 (cond 48 ((eq? kind 'IDENT) (%bv-escape val)) 49 ((eq? kind 'STR) (%bv-escape val)) 50 ((eq? kind 'INT) (format "~d" val)) 51 ((eq? kind 'CHAR) (format "~d" val)) 52 ((eq? kind 'KW) (format "~a" val)) 53 ((eq? kind 'PUNCT) (format "~a" val)) 54 ((eq? kind 'HASH) "#f") 55 ((eq? kind 'NL) "#f") 56 ((eq? kind 'EOF) "#f") 57 (else (format "~a" val)))) 58 59 (define (%fmt-tok t) 60 ;; Returns a bv ending in '\n'. 61 (let* ((kind (tok-kind t)) 62 (val (tok-value t)) 63 (loc (tok-loc t)) 64 (file (loc-file loc)) 65 (line (loc-line loc)) 66 (col (loc-col loc))) 67 (bv-cat (list "(" (format "~a" kind) " " 68 (%fmt-value kind val) " " 69 (%bv-escape file) " " 70 (format "~d" line) " " 71 (format "~d" col) ")" 72 NL-BV)))) 73 74 (define (%emit-toks toks) 75 (cond 76 ((null? toks) #t) 77 (else 78 (write-bv-fd 1 (%fmt-tok (car toks))) 79 (%emit-toks (cdr toks))))) 80 81 (define (%basename path) 82 ;; Strip directory components from a bv path. Returns a fresh bv 83 ;; containing the trailing path component (after the last '/'). 84 (let* ((n (bytevector-length path))) 85 (let loop ((i (- n 1))) 86 (cond 87 ((< i 0) path) 88 ((= (bytevector-u8-ref path i) 47) 89 (bv-slice path (+ i 1) n)) 90 (else (loop (- i 1))))))) 91 92 (define (%run-lex path) 93 (let ((op (open-input path))) 94 (if (not (car op)) 95 (begin 96 (write-bv-fd 2 "run-lex: cannot open ") 97 (write-bv-fd 2 path) 98 (write-bv-fd 2 NL-BV) 99 (sys-exit 2)) 100 (let* ((src (slurp-fd (port-fd (cdr op)))) 101 (file (%basename path)) 102 (toks (lex-tokenize src file))) 103 (sys-close (port-fd (cdr op))) 104 (%emit-toks toks) 105 (sys-exit 0))))) 106 107 (let ((args (argv))) 108 ;; argv[0] = scheme1 program path 109 ;; argv[1] = combined source (the harness arranges this) 110 ;; argv[2] = .c fixture path 111 (cond 112 ((null? args) (sys-exit 2)) 113 ((null? (cdr args)) (sys-exit 2)) 114 ((null? (cdr (cdr args))) 115 (write-bv-fd 2 "run-lex: missing fixture path\n") 116 (sys-exit 2)) 117 (else (%run-lex (car (cdr (cdr args)))))))