pp.scm (32810B)
1 ;; cc/pp.scm — token list -> expanded token list. 2 ;; Realizes docs/CC-INTERNALS.md §pp.scm. Hide-set per C11 6.10.3.4. 3 ;; #include rejected (CC.md §Toolchain envelope). 4 5 ;; --- helpers (TODO: promote to util.scm if shared more broadly) --- 6 (define (%pp-bv-mem? x xs) 7 (cond ((null? xs) #f) 8 ((bv= x (car xs)) #t) 9 (else (%pp-bv-mem? x (cdr xs))))) 10 11 (define (%pp-bv-union a b) 12 (cond ((null? a) b) 13 ((%pp-bv-mem? (car a) b) (%pp-bv-union (cdr a) b)) 14 (else (cons (car a) (%pp-bv-union (cdr a) b))))) 15 16 (define (%pp-with-hide t hide) 17 (%tok (tok-kind t) (tok-value t) (tok-loc t) hide)) 18 (define (%pp-with-loc t loc) 19 (%tok (tok-kind t) (tok-value t) loc (tok-hide t))) 20 21 ;; --- pp-state (private record) --- 22 ;; cond-stack: list of (active? . has-taken?). Outer-active gating is 23 ;; computed by walking the stack rather than encoding it in frames. 24 (define-record-type pp-state 25 (%pp-state macros cond-stack cur-file line-delta) 26 pp-state? 27 (macros pps-macros pps-macros-set!) 28 (cond-stack pps-cond-stack pps-cond-stack-set!) 29 (cur-file pps-cur-file pps-cur-file-set!) 30 (line-delta pps-line-delta pps-line-delta-set!)) 31 32 (define (%pp-make-state defs) (%pp-state defs '() #f 0)) 33 34 (define (%pp-active? state) 35 (let loop ((xs (pps-cond-stack state))) 36 (cond ((null? xs) #t) 37 ((not (car (car xs))) #f) 38 (else (loop (cdr xs)))))) 39 40 ;; Active for the *parent* of the top frame (used by elif/else). 41 (define (%pp-parent-active? state) 42 (let ((cs (pps-cond-stack state))) 43 (cond ((null? cs) #t) 44 (else 45 (let loop ((xs (cdr cs))) 46 (cond ((null? xs) #t) 47 ((not (car (car xs))) #f) 48 (else (loop (cdr xs))))))))) 49 50 ;; --- token classification --- 51 (define (%pp-eof? t) (eq? (tok-kind t) 'EOF)) 52 (define (%pp-nl? t) (eq? (tok-kind t) 'NL)) 53 (define (%pp-hash? t) (eq? (tok-kind t) 'HASH)) 54 (define (%pp-ident? t) (eq? (tok-kind t) 'IDENT)) 55 (define (%pp-int? t) (eq? (tok-kind t) 'INT)) 56 (define (%pp-punct? t pname) 57 (and (eq? (tok-kind t) 'PUNCT) (eq? (tok-value t) pname))) 58 (define (%pp-ident-name? t name-bv) 59 (and (%pp-ident? t) (bv= (tok-value t) name-bv))) 60 (define (%pp-skip-ws toks) toks) 61 62 ;; --- built-in macro names --- 63 (define %pp-bv-FILE "__FILE__") 64 (define %pp-bv-LINE "__LINE__") 65 (define %pp-bv-STDC "__STDC__") 66 (define %pp-bv-LISPCC "__LISPCC__") 67 (define %pp-bv-DATE "__DATE__") 68 (define %pp-bv-TIME "__TIME__") 69 (define %pp-bv-STDC-VERSION "__STDC_VERSION__") 70 (define %pp-bv-STDC-HOSTED "__STDC_HOSTED__") 71 (define %pp-bv-VA-ARGS "__VA_ARGS__") 72 (define %pp-bv-defined "defined") 73 74 ;; Fixed values for reproducibility — we don't read the wall clock. 75 (define %pp-bv-DATE-VALUE "Jan 1 1970") 76 (define %pp-bv-TIME-VALUE "00:00:00") 77 78 (define (%pp-builtin? name) 79 (or (bv= name %pp-bv-FILE) (bv= name %pp-bv-LINE) 80 (bv= name %pp-bv-STDC) (bv= name %pp-bv-LISPCC) 81 (bv= name %pp-bv-DATE) (bv= name %pp-bv-TIME) 82 (bv= name %pp-bv-STDC-VERSION) (bv= name %pp-bv-STDC-HOSTED))) 83 84 (define (%pp-expand-builtin name loc state) 85 (let* ((file (or (pps-cur-file state) (loc-file loc))) 86 (line (+ (loc-line loc) (pps-line-delta state))) 87 (col (loc-col loc)) 88 (here (%loc file line col))) 89 (cond 90 ((bv= name %pp-bv-FILE) (list (%tok 'STR file here '()))) 91 ((bv= name %pp-bv-LINE) (list (%tok 'INT line here '()))) 92 ((bv= name %pp-bv-STDC) (list (%tok 'INT 1 here '()))) 93 ((bv= name %pp-bv-LISPCC) (list (%tok 'INT 1 here '()))) 94 ((bv= name %pp-bv-DATE) (list (%tok 'STR %pp-bv-DATE-VALUE here '()))) 95 ((bv= name %pp-bv-TIME) (list (%tok 'STR %pp-bv-TIME-VALUE here '()))) 96 ((bv= name %pp-bv-STDC-VERSION) (list (%tok 'INT 199901 here '()))) 97 ((bv= name %pp-bv-STDC-HOSTED) (list (%tok 'INT 1 here '()))) 98 (else (die loc "internal: not a builtin" name))))) 99 100 ;; --- buf-list: simple reversed-list buffer of toks --- 101 (define-record-type buf-list 102 (%buf-list xs) 103 buf-list? 104 (xs buf-list-xs buf-list-xs-set!)) 105 (define (make-buf-list) (%buf-list '())) 106 (define (buf-list-push! b t) (buf-list-xs-set! b (cons t (buf-list-xs b)))) 107 (define (buf-list-push-many! b ts) 108 (let loop ((ts ts)) 109 (cond ((null? ts) #t) 110 (else (buf-list-push! b (car ts)) (loop (cdr ts)))))) 111 (define (buf-list-flush b) (reverse (buf-list-xs b))) 112 113 ;; Translation phase 6: concatenate adjacent string literals. The merged 114 ;; token keeps the loc and hide-set of the first; values are byte-appended. 115 (define (%pp-merge-adjacent-strs toks) 116 (let loop ((toks toks) (acc '())) 117 (cond 118 ((null? toks) (reverse acc)) 119 ((and (not (null? acc)) 120 (eq? (tok-kind (car toks)) 'STR) 121 (eq? (tok-kind (car acc)) 'STR)) 122 (let* ((prev (car acc)) 123 (cur (car toks)) 124 (merged (%tok 'STR 125 (bytevector-append (tok-value prev) (tok-value cur)) 126 (tok-loc prev) 127 (tok-hide prev)))) 128 (loop (cdr toks) (cons merged (cdr acc))))) 129 (else (loop (cdr toks) (cons (car toks) acc)))))) 130 131 ;; --- pp-expand: top-level driver --- 132 (define (pp-expand toks initial-defines) 133 (let ((state (%pp-make-state initial-defines)) 134 (out (make-buf-list))) 135 (let loop ((toks toks)) 136 (cond 137 ((null? toks) (die #f "pp-expand: missing EOF token")) 138 ((%pp-eof? (car toks)) 139 (cond ((not (null? (pps-cond-stack state))) 140 (die (tok-loc (car toks)) "unterminated #if/#ifdef/#ifndef")) 141 (else 142 (buf-list-push! out (car toks)) 143 (%pp-merge-adjacent-strs (buf-list-flush out))))) 144 ((%pp-nl? (car toks)) (loop (cdr toks))) 145 ((%pp-hash? (car toks)) 146 (let* ((lr (%pp-take-line (cdr toks))) 147 (line (car lr)) (rest (cdr lr))) 148 (%pp-dispatch-directive (car toks) line state out) 149 (loop rest))) 150 (else 151 (let* ((lr (%pp-take-line toks)) 152 (line (car lr)) (rest (cdr lr))) 153 (cond ((%pp-active? state) 154 (%pp-emit-expanded line state out)) 155 (else #t)) 156 (loop rest))))))) 157 158 ;; Take tokens up to (not including) the next NL or EOF. NL is consumed; 159 ;; EOF is left in the stream so the driver sees it next. 160 (define (%pp-take-line toks) 161 (let loop ((toks toks) (acc '())) 162 (cond 163 ((null? toks) (cons (reverse acc) toks)) 164 ((%pp-eof? (car toks)) (cons (reverse acc) toks)) 165 ((%pp-nl? (car toks)) (cons (reverse acc) (cdr toks))) 166 (else (loop (cdr toks) (cons (car toks) acc)))))) 167 168 ;; --- directive dispatch --- 169 ;; pmatch-based on the directive name bv. bv literals match by equal?. 170 ;; Directive name can arrive as IDENT (most cases) or KW (`if` and `else` 171 ;; are C keywords promoted by lex; their KW symbol values map back to bv 172 ;; via symbol->string). 173 (define (%pp-directive-name t) 174 (cond ((eq? (tok-kind t) 'IDENT) (tok-value t)) 175 ((eq? (tok-kind t) 'KW) (symbol->string (tok-value t))) 176 (else #f))) 177 178 (define (%pp-dispatch-directive hash-tok line state out) 179 (let ((line (%pp-skip-ws line))) 180 (cond 181 ((null? line) #t) ; bare `#` line — null directive 182 ((%pp-directive-name (car line)) 183 (let ((name (%pp-directive-name (car line))) 184 (rest (cdr line)) 185 (loc (tok-loc (car line)))) 186 (pmatch name 187 ("define" (cond ((%pp-active? state) (%pp-do-define rest state)) (else #t))) 188 ("undef" (cond ((%pp-active? state) (%pp-do-undef rest state)) (else #t))) 189 ("if" (%pp-do-if rest state)) 190 ("ifdef" (%pp-do-ifdef rest state)) 191 ("ifndef" (%pp-do-ifndef rest state)) 192 ("elif" (%pp-do-elif rest state)) 193 ("else" (%pp-do-else rest state)) 194 ("endif" (%pp-do-endif rest state)) 195 ("error" (cond ((%pp-active? state) 196 (%pp-do-error (cons (car line) rest) state)) 197 (else #t))) 198 ("line" (cond ((%pp-active? state) (%pp-do-line rest state)) (else #t))) 199 ("pragma" (cond ((%pp-active? state) (%pp-do-pragma rest state)) (else #t))) 200 ("include" (cond ((%pp-active? state) (%pp-do-include rest state)) (else #t))) 201 (else (die loc "unknown preprocessor directive" name))))) 202 (else 203 (die (tok-loc (car line)) "expected directive name after '#'" 204 (tok-kind (car line))))))) 205 206 ;; --- #define --- 207 ;; function-like vs object-like is decided by an immediately-adjacent `(`. 208 ;; "Adjacent" = column of `(` equals column of name + length of name. 209 (define (%pp-do-define line state) 210 (cond 211 ((null? line) (die #f "#define requires a macro name")) 212 ((not (%pp-ident? (car line))) 213 (die (tok-loc (car line)) "#define: expected identifier")) 214 (else 215 (let* ((nt (car line)) (name (tok-value nt)) (rest (cdr line))) 216 (cond 217 ((and (not (null? rest)) 218 (%pp-punct? (car rest) 'lparen) 219 (= (loc-col (tok-loc (car rest))) 220 (+ (loc-col (tok-loc nt)) 221 (bytevector-length name)))) 222 (%pp-define-fn name (cdr rest) (tok-loc nt) state)) 223 (else 224 (let ((m (%macro 'obj '() rest))) 225 (pps-macros-set! state (alist-set name m (pps-macros state)))))))))) 226 227 (define (%pp-define-fn name post-lparen nloc state) 228 (let loop ((toks post-lparen) (params '()) (variadic? #f)) 229 (cond 230 ((null? toks) (die nloc "#define: unterminated parameter list")) 231 ((%pp-punct? (car toks) 'rparen) 232 (let* ((body (cdr toks)) 233 (kind (if variadic? 'fn-vararg 'fn)) 234 (m (%macro kind (reverse params) body))) 235 (pps-macros-set! state (alist-set name m (pps-macros state))))) 236 ((%pp-punct? (car toks) 'ellipsis) 237 (let ((rest (cdr toks))) 238 (cond 239 ((null? rest) (die (tok-loc (car toks)) "#define: '...' must precede ')'")) 240 ((%pp-punct? (car rest) 'rparen) (loop rest params #t)) 241 (else (die (tok-loc (car rest)) "#define: garbage after '...'"))))) 242 ((null? params) 243 (cond 244 ((%pp-ident? (car toks)) 245 (loop (cdr toks) (cons (tok-value (car toks)) params) #f)) 246 (else (die (tok-loc (car toks)) "#define: expected parameter name")))) 247 (else 248 (cond 249 ((%pp-punct? (car toks) 'comma) 250 (let ((after (cdr toks))) 251 (cond 252 ((null? after) (die (tok-loc (car toks)) "#define: trailing ','")) 253 ((%pp-punct? (car after) 'ellipsis) 254 (let ((aa (cdr after))) 255 (cond 256 ((and (not (null? aa)) (%pp-punct? (car aa) 'rparen)) 257 (loop aa params #t)) 258 (else (die (tok-loc (car after)) 259 "#define: '...' must precede ')'"))))) 260 ((%pp-ident? (car after)) 261 (loop (cdr after) (cons (tok-value (car after)) params) #f)) 262 (else 263 (die (tok-loc (car after)) 264 "#define: expected parameter name after ','"))))) 265 (else (die (tok-loc (car toks)) 266 "#define: expected ',' or ')' in parameter list"))))))) 267 268 ;; --- #undef --- 269 (define (%pp-do-undef line state) 270 (cond 271 ((null? line) (die #f "#undef requires a macro name")) 272 ((not (%pp-ident? (car line))) 273 (die (tok-loc (car line)) "#undef: expected identifier")) 274 (else 275 (pps-macros-set! state 276 (%pp-alist-drop (tok-value (car line)) (pps-macros state)))))) 277 278 (define (%pp-alist-drop key al) 279 (cond ((null? al) '()) 280 ((bv= (car (car al)) key) (cdr al)) 281 (else (cons (car al) (%pp-alist-drop key (cdr al)))))) 282 283 ;; --- #if / #ifdef / #ifndef / #elif / #else / #endif --- 284 (define (%pp-do-if line state) 285 (cond 286 ((not (%pp-active? state)) 287 (pps-cond-stack-set! state (cons (cons #f #f) (pps-cond-stack state)))) 288 (else 289 (let* ((v (pp-eval-cexpr line (pps-macros state))) 290 (a? (not (= v 0)))) 291 (pps-cond-stack-set! state (cons (cons a? a?) (pps-cond-stack state))))))) 292 293 (define (%pp-do-ifdef line state) 294 (cond 295 ((not (%pp-active? state)) 296 (pps-cond-stack-set! state (cons (cons #f #f) (pps-cond-stack state)))) 297 (else 298 (let ((d? (%pp-defined? (%pp-name-of-single line) state))) 299 (pps-cond-stack-set! state 300 (cons (cons d? d?) (pps-cond-stack state))))))) 301 302 (define (%pp-do-ifndef line state) 303 (cond 304 ((not (%pp-active? state)) 305 (pps-cond-stack-set! state (cons (cons #f #f) (pps-cond-stack state)))) 306 (else 307 (let ((a? (not (%pp-defined? (%pp-name-of-single line) state)))) 308 (pps-cond-stack-set! state 309 (cons (cons a? a?) (pps-cond-stack state))))))) 310 311 (define (%pp-name-of-single line) 312 (cond 313 ((null? line) (die #f "#ifdef/#ifndef: missing identifier")) 314 ((not (%pp-ident? (car line))) 315 (die (tok-loc (car line)) "#ifdef/#ifndef: expected identifier")) 316 (else (tok-value (car line))))) 317 318 (define (%pp-defined? name state) 319 (or (alist-ref name (pps-macros state)) 320 (%pp-builtin? name) 321 #f)) 322 323 (define (%pp-do-elif line state) 324 (let ((cs (pps-cond-stack state))) 325 (cond 326 ((null? cs) (die #f "#elif outside #if")) 327 (else 328 (let* ((top (car cs)) (rest (cdr cs)) 329 (taken? (cdr top)) 330 (par? (%pp-parent-active? state))) 331 (cond 332 ((or (not par?) taken?) 333 (pps-cond-stack-set! state (cons (cons #f taken?) rest))) 334 (else 335 (let* ((v (pp-eval-cexpr line (pps-macros state))) 336 (a? (not (= v 0)))) 337 (pps-cond-stack-set! state 338 (cons (cons a? (or a? taken?)) rest)))))))))) 339 340 (define (%pp-do-else line state) 341 (let ((cs (pps-cond-stack state))) 342 (cond 343 ((null? cs) (die #f "#else outside #if")) 344 (else 345 (let* ((top (car cs)) (rest (cdr cs)) 346 (taken? (cdr top)) 347 (par? (%pp-parent-active? state))) 348 (cond 349 ((not par?) 350 (pps-cond-stack-set! state (cons (cons #f taken?) rest))) 351 (taken? 352 (pps-cond-stack-set! state (cons (cons #f #t) rest))) 353 (else 354 (pps-cond-stack-set! state (cons (cons #t #t) rest))))))))) 355 356 (define (%pp-do-endif line state) 357 (let ((cs (pps-cond-stack state))) 358 (cond ((null? cs) (die #f "#endif outside #if")) 359 (else (pps-cond-stack-set! state (cdr cs)))))) 360 361 ;; --- #error --- 362 ;; line[0] is the directive name "error"; the rest is the user message. 363 (define (%pp-do-error line state) 364 (let* ((msg-toks (if (null? line) '() (cdr line))) 365 (loc (if (null? line) #f (tok-loc (car line)))) 366 (msg (%pp-toks->display msg-toks))) 367 (die loc "#error" msg))) 368 369 (define (%pp-toks->display toks) 370 (let loop ((toks toks) (acc '()) (first? #t)) 371 (cond 372 ((null? toks) (bv-cat (reverse acc))) 373 (else 374 (let ((p (%pp-tok->bv (car toks)))) 375 (loop (cdr toks) 376 (if first? (cons p acc) (cons p (cons " " acc))) 377 #f)))))) 378 379 (define (%pp-tok->bv t) 380 (let ((k (tok-kind t)) (v (tok-value t))) 381 (cond 382 ((eq? k 'IDENT) v) 383 ((eq? k 'INT) (fixnum->bv v 10)) 384 ((eq? k 'STR) (%pp-quote-bytes v 34)) 385 ((eq? k 'CHAR) (%pp-quote-bytes (bv-of-byte v) 39)) 386 ((eq? k 'KW) (symbol->string v)) 387 ((eq? k 'PUNCT) (symbol->string v)) 388 (else "?")))) 389 390 ;; Reconstruct a string/char literal source spelling from cooked content. 391 ;; Per C11 6.10.3.2: insert `\` before each `"` and `\` (or `'` for char). 392 ;; `delim` is 34 for STR, 39 for CHAR. 393 (define (%pp-quote-bytes bv delim) 394 (let* ((n (bytevector-length bv)) 395 (delim-bv (bv-of-byte delim))) 396 (let loop ((i 0) (acc (list delim-bv))) 397 (cond 398 ((= i n) (bv-cat (reverse (cons delim-bv acc)))) 399 (else 400 (let ((b (bytevector-u8-ref bv i))) 401 (cond 402 ((or (= b delim) (= b 92)) 403 (loop (+ i 1) (cons (bv-of-byte b) (cons "\\" acc)))) 404 (else 405 (loop (+ i 1) (cons (bv-of-byte b) acc)))))))))) 406 407 ;; --- #line / #pragma / #include --- 408 ;; Approximate #line: subsequent toks have line = (orig-line + delta), 409 ;; where delta = (N - here-line - 1). Good enough for most cases. 410 (define (%pp-do-line line state) 411 (cond 412 ((null? line) (die #f "#line requires a line number")) 413 ((not (%pp-int? (car line))) 414 (die (tok-loc (car line)) "#line: expected integer")) 415 (else 416 (let* ((nt (car line)) (n (tok-value nt)) 417 (rest (cdr line)) 418 (here (loc-line (tok-loc nt)))) 419 (pps-line-delta-set! state (- n here 1)) 420 (cond 421 ((null? rest) #t) 422 ((eq? (tok-kind (car rest)) 'STR) 423 (pps-cur-file-set! state (tok-value (car rest)))) 424 (else (die (tok-loc (car rest)) 425 "#line: expected string after number"))))))) 426 427 (define (%pp-do-pragma line state) #t) 428 429 (define (%pp-do-include line state) 430 (die (if (null? line) #f (tok-loc (car line))) 431 "#include: file inclusion is handled upstream by pre-flatten")) 432 433 ;; --- macro expansion engine --- 434 ;; Walk toks; for each IDENT, look up in macros / builtins. Hide-set: 435 ;; if the name is in t.hide, don't expand. Otherwise expand and rescan 436 ;; the produced body, with hide += {name}. 437 (define (%pp-emit-expanded toks state out) 438 (let loop ((toks toks)) 439 (cond 440 ((null? toks) #t) 441 (else 442 (let* ((t (car toks)) (rest (cdr toks))) 443 (cond 444 ((not (%pp-ident? t)) 445 (buf-list-push! out (%pp-relocate t state)) 446 (loop rest)) 447 (else 448 (let ((name (tok-value t))) 449 (cond 450 ((%pp-bv-mem? name (tok-hide t)) 451 (buf-list-push! out (%pp-relocate t state)) 452 (loop rest)) 453 ((%pp-builtin? name) 454 (buf-list-push-many! out 455 (%pp-expand-builtin name (tok-loc t) state)) 456 (loop rest)) 457 (else 458 (let ((m (alist-ref name (pps-macros state)))) 459 (cond 460 ((not m) 461 (buf-list-push! out (%pp-relocate t state)) 462 (loop rest)) 463 (else 464 (%pp-apply-macro t m rest state out loop)))))))))))))) 465 466 (define (%pp-apply-macro t m rest state out cont) 467 (let ((kind (macro-kind m)) (name (tok-value t))) 468 (cond 469 ((eq? kind 'obj) 470 (let ((bodies (%pp-prepare-body (macro-body m) 471 (cons name (tok-hide t))))) 472 (%pp-emit-expanded bodies state out) 473 (cont rest))) 474 (else 475 (let ((after (%pp-skip-ws rest))) 476 (cond 477 ((or (null? after) (not (%pp-punct? (car after) 'lparen))) 478 (buf-list-push! out (%pp-relocate t state)) 479 (cont rest)) 480 (else 481 (let* ((ar (%pp-collect-args (cdr after) (tok-loc t))) 482 (args (car ar)) (rest2 (cdr ar)) 483 (params (macro-params m)) 484 (variadic? (eq? kind 'fn-vararg)) 485 (env (%pp-bind-args params args variadic? (tok-loc t))) 486 (sub (%pp-substitute (macro-body m) env (tok-loc t))) 487 (bodies (%pp-prepare-body sub 488 (cons name (tok-hide t))))) 489 (%pp-emit-expanded bodies state out) 490 (cont rest2))))))))) 491 492 (define (%pp-prepare-body body extra-hide) 493 (map (lambda (t) 494 (%pp-with-hide t (%pp-bv-union extra-hide (tok-hide t)))) 495 body)) 496 497 ;; Collect comma-separated args. `toks` starts AFTER `(`. Returns 498 ;; (args . rest), where args is a list of token-lists. 499 (define (%pp-collect-args toks call-loc) 500 (let loop ((toks toks) (depth 0) (cur '()) (args '())) 501 (cond 502 ((null? toks) (die call-loc "macro call: unterminated argument list")) 503 ((%pp-eof? (car toks)) 504 (die call-loc "macro call: unterminated argument list")) 505 ((and (= depth 0) (%pp-punct? (car toks) 'rparen)) 506 (let ((args* 507 (cond 508 ;; Empty parens count as one empty argument; bind-args 509 ;; degenerates this back to "no args" for 0-param macros. 510 ((and (null? args) (null? cur)) (list '())) 511 (else (reverse (cons (reverse cur) args)))))) 512 (cons args* (cdr toks)))) 513 ((and (= depth 0) (%pp-punct? (car toks) 'comma)) 514 (loop (cdr toks) 0 '() (cons (reverse cur) args))) 515 ((%pp-punct? (car toks) 'lparen) 516 (loop (cdr toks) (+ depth 1) (cons (car toks) cur) args)) 517 ((%pp-punct? (car toks) 'rparen) 518 (loop (cdr toks) (- depth 1) (cons (car toks) cur) args)) 519 (else 520 (loop (cdr toks) depth (cons (car toks) cur) args))))) 521 522 ;; Bind formals → token-lists (alist by bv key). Variadic gathers 523 ;; trailing actuals into __VA_ARGS__, joined with synthetic commas. 524 (define (%pp-bind-args params args variadic? call-loc) 525 (let* ((np (length params)) (na (length args))) 526 (cond 527 (variadic? 528 (cond 529 ((< na np) (die call-loc "macro call: too few arguments")) 530 (else 531 (let loop ((ps params) (as args) (acc '())) 532 (cond 533 ((null? ps) 534 (alist-set %pp-bv-VA-ARGS (%pp-join-comma as) acc)) 535 (else 536 (loop (cdr ps) (cdr as) 537 (alist-set (car ps) (car as) acc)))))))) 538 (else 539 (cond 540 ((and (= np 0) (= na 1) (null? (car args))) '()) 541 ((not (= np na)) (die call-loc "macro call: argument count mismatch")) 542 (else 543 (let loop ((ps params) (as args) (acc '())) 544 (cond 545 ((null? ps) acc) 546 (else (loop (cdr ps) (cdr as) 547 (alist-set (car ps) (car as) acc))))))))))) 548 549 (define (%pp-join-comma argss) 550 (cond 551 ((null? argss) '()) 552 ((null? (cdr argss)) (car argss)) 553 (else 554 (append (car argss) 555 (cons (%pp-synth-comma) (%pp-join-comma (cdr argss))))))) 556 557 (define (%pp-synth-comma) 558 (%tok 'PUNCT 'comma (%loc "<expand>" 0 0) '())) 559 560 ;; Body substitution: walk body; replace param IDENTs with arg toks, 561 ;; handle `#param` (stringize) and `a##b` (paste). For v1 we do not 562 ;; pre-expand args before substitution; the rescan after substitution 563 ;; catches the same expansions in practice. 564 (define (%pp-substitute body env call-loc) 565 (let loop ((body body) (out '())) 566 (cond 567 ((null? body) (reverse out)) 568 (else 569 (let ((t (car body)) (rest (cdr body))) 570 (cond 571 ((%pp-punct? t 'hash) 572 (cond 573 ((or (null? rest) (not (%pp-ident? (car rest)))) 574 (die (tok-loc t) "stringize: '#' must precede a parameter name")) 575 (else 576 (let* ((id (car rest)) (pn (tok-value id)) 577 (pt (alist-ref pn env))) 578 (cond 579 ((not pt) 580 (die (tok-loc id) "stringize: '#' operand must be a parameter" pn)) 581 (else 582 (let ((s (%tok 'STR (%pp-toks->display pt) (tok-loc t) '()))) 583 (loop (cdr rest) (cons s out))))))))) 584 ((%pp-punct? t 'paste) 585 (cond 586 ((null? out) (die (tok-loc t) "paste: '##' cannot start a body")) 587 ((null? rest) (die (tok-loc t) "paste: '##' cannot end a body")) 588 (else 589 (let* ((lhs (car out)) 590 (rt (car rest)) 591 (rhs-list 592 (cond 593 ((and (%pp-ident? rt) (alist-ref (tok-value rt) env)) 594 (alist-ref (tok-value rt) env)) 595 (else (list rt))))) 596 (cond 597 ((null? rhs-list) (loop (cdr rest) out)) 598 (else 599 (let* ((p (%pp-paste-tokens lhs (car rhs-list))) 600 (after (append (cdr rhs-list) (cdr rest)))) 601 (loop after (cons p (cdr out)))))))))) 602 ((%pp-ident? t) 603 (let* ((pn (tok-value t)) (pt (alist-ref pn env))) 604 (cond 605 ((not pt) (loop rest (cons t out))) 606 ((and (not (null? rest)) (%pp-punct? (car rest) 'paste)) 607 (cond 608 ((null? pt) (loop (cdr rest) out)) 609 (else (loop rest (append (reverse pt) out))))) 610 (else (loop rest (append (reverse pt) out)))))) 611 (else (loop rest (cons t out))))))))) 612 613 ;; Paste two tokens textually; reparse the result. 614 (define (%pp-paste-tokens lhs rhs) 615 (let ((lk (tok-kind lhs)) (rk (tok-kind rhs))) 616 (cond 617 ((and (eq? lk 'IDENT) (eq? rk 'IDENT)) 618 (%tok 'IDENT (bytevector-append (tok-value lhs) (tok-value rhs)) 619 (tok-loc lhs) (%pp-bv-union (tok-hide lhs) (tok-hide rhs)))) 620 ((and (eq? lk 'IDENT) (eq? rk 'INT)) 621 (%tok 'IDENT (bytevector-append (tok-value lhs) (fixnum->bv (tok-value rhs) 10)) 622 (tok-loc lhs) (%pp-bv-union (tok-hide lhs) (tok-hide rhs)))) 623 ((and (eq? lk 'INT) (eq? rk 'INT)) 624 (let* ((s (bytevector-append (fixnum->bv (tok-value lhs) 10) 625 (fixnum->bv (tok-value rhs) 10))) 626 (pr (bv->fixnum s 10))) 627 (cond 628 ((not (car pr)) (die (tok-loc lhs) "paste: cannot reparse as integer" s)) 629 (else (%tok 'INT (cdr pr) (tok-loc lhs) 630 (%pp-bv-union (tok-hide lhs) (tok-hide rhs))))))) 631 (else (die (tok-loc lhs) "paste: unsupported token kinds" lk rk))))) 632 633 (define (%pp-relocate t state) 634 (cond 635 ((and (= (pps-line-delta state) 0) (not (pps-cur-file state))) t) 636 (else 637 (let* ((l (tok-loc t)) 638 (f (or (pps-cur-file state) (loc-file l))) 639 (ln (+ (loc-line l) (pps-line-delta state))) 640 (c (loc-col l))) 641 (%pp-with-loc t (%loc f ln c)))))) 642 643 ;; --- pp-eval-cexpr: #if expression evaluator --- 644 ;; Steps: resolve `defined NAME`, macro-expand the rest, treat any 645 ;; remaining IDENT as 0, parse with recursive descent. 646 ;; 647 ;; Arena boundary (test_93 A→B→C pattern). Everything between the mark 648 ;; and the rewind is scratch: `s1`/`s2`/`s3` (each a fresh token list, 649 ;; where `s2` runs the full macro-expansion engine), plus the recursive 650 ;; parser's (val . rest) cons cell at every level. The result is a 651 ;; fixnum, so no pre-allocated out cell is needed — `val` survives the 652 ;; rewind by virtue of being an immediate. The error path goes through 653 ;; `die` (which sys-exits), so no rewind there. 654 (define (pp-eval-cexpr toks macros) 655 (let ((mark (heap-mark))) 656 (let* ((state (%pp-state macros '() #f 0)) 657 (s1 (%pp-resolve-defined toks state)) 658 (s2 (%pp-expand-line s1 state)) 659 (s3 (%pp-idents-as-zero s2))) 660 (let* ((p (%pp-cx-expr s3)) 661 (val (car p)) (rest (cdr p))) 662 (cond 663 ((null? rest) (heap-rewind! mark) val) 664 (else (die (tok-loc (car rest)) "#if: garbage at end of expression" 665 (tok-kind (car rest))))))))) 666 667 (define (%pp-expand-line toks state) 668 (let ((out (make-buf-list))) 669 (%pp-emit-expanded toks state out) 670 (buf-list-flush out))) 671 672 (define (%pp-resolve-defined toks state) 673 (let loop ((toks toks) (acc '())) 674 (cond 675 ((null? toks) (reverse acc)) 676 ((%pp-ident-name? (car toks) %pp-bv-defined) 677 (let ((rest (cdr toks))) 678 (cond 679 ((null? rest) (die (tok-loc (car toks)) "defined: missing operand")) 680 ((%pp-ident? (car rest)) 681 (let ((v (if (%pp-defined? (tok-value (car rest)) state) 1 0))) 682 (loop (cdr rest) 683 (cons (%tok 'INT v (tok-loc (car toks)) '()) acc)))) 684 ((%pp-punct? (car rest) 'lparen) 685 (let ((after (cdr rest))) 686 (cond 687 ((or (null? after) (not (%pp-ident? (car after)))) 688 (die (tok-loc (car toks)) "defined: expected identifier")) 689 (else 690 (let ((aa (cdr after))) 691 (cond 692 ((or (null? aa) (not (%pp-punct? (car aa) 'rparen))) 693 (die (tok-loc (car toks)) "defined: expected ')'")) 694 (else 695 (let ((v (if (%pp-defined? (tok-value (car after)) state) 1 0))) 696 (loop (cdr aa) 697 (cons (%tok 'INT v (tok-loc (car toks)) '()) acc)))))))) )) 698 (else (die (tok-loc (car rest)) "defined: expected identifier or '('"))))) 699 (else (loop (cdr toks) (cons (car toks) acc)))))) 700 701 (define (%pp-idents-as-zero toks) 702 (map (lambda (t) 703 (cond ((%pp-ident? t) (%tok 'INT 0 (tok-loc t) '())) 704 (else t))) 705 toks)) 706 707 ;; --- recursive-descent #if expression parser --- 708 ;; Returns (value . rest). 709 (define (%pp-cx-expr toks) (%pp-cx-cond toks)) 710 711 (define (%pp-cx-cond toks) 712 (let* ((p (%pp-cx-lor toks)) 713 (v (car p)) (rest (cdr p))) 714 (cond 715 ((and (not (null? rest)) (%pp-punct? (car rest) 'qmark)) 716 (let* ((p2 (%pp-cx-expr (cdr rest))) 717 (vt (car p2)) (after (cdr p2))) 718 (cond 719 ((or (null? after) (not (%pp-punct? (car after) 'colon))) 720 (die (if (null? after) #f (tok-loc (car after))) "?: missing ':'")) 721 (else 722 (let* ((p3 (%pp-cx-cond (cdr after))) 723 (vf (car p3)) (rest3 (cdr p3))) 724 (cons (if (not (= v 0)) vt vf) rest3)))))) 725 (else (cons v rest))))) 726 727 (define (%pp-cx-binl next ops toks) 728 (let loop ((p (next toks))) 729 (let ((v (car p)) (rest (cdr p))) 730 (cond 731 ((null? rest) p) 732 (else 733 (let* ((tt (car rest)) 734 (hit (and (eq? (tok-kind tt) 'PUNCT) 735 (alist-ref/eq (tok-value tt) ops)))) 736 (cond 737 ((not hit) p) 738 (else 739 (let* ((p2 (next (cdr rest))) 740 (v2 (car p2)) (rest2 (cdr p2))) 741 (loop (cons (hit v v2) rest2))))))))))) 742 743 (define (%pp-cx-lor toks) 744 (%pp-cx-binl %pp-cx-land 745 (list (cons 'lor (lambda (a b) (if (or (not (= a 0)) (not (= b 0))) 1 0)))) 746 toks)) 747 (define (%pp-cx-land toks) 748 (%pp-cx-binl %pp-cx-bor 749 (list (cons 'land (lambda (a b) (if (and (not (= a 0)) (not (= b 0))) 1 0)))) 750 toks)) 751 (define (%pp-cx-bor toks) (%pp-cx-binl %pp-cx-bxor (list (cons 'bar bit-or)) toks)) 752 (define (%pp-cx-bxor toks) (%pp-cx-binl %pp-cx-band (list (cons 'caret bit-xor)) toks)) 753 (define (%pp-cx-band toks) (%pp-cx-binl %pp-cx-eq (list (cons 'amp bit-and)) toks)) 754 (define (%pp-cx-eq toks) 755 (%pp-cx-binl %pp-cx-rel 756 (list (cons 'eq2 (lambda (a b) (if (= a b) 1 0))) 757 (cons 'ne (lambda (a b) (if (= a b) 0 1)))) 758 toks)) 759 (define (%pp-cx-rel toks) 760 (%pp-cx-binl %pp-cx-shift 761 (list (cons 'lt (lambda (a b) (if (< a b) 1 0))) 762 (cons 'le (lambda (a b) (if (<= a b) 1 0))) 763 (cons 'gt (lambda (a b) (if (> a b) 1 0))) 764 (cons 'ge (lambda (a b) (if (>= a b) 1 0)))) 765 toks)) 766 (define (%pp-cx-shift toks) 767 (%pp-cx-binl %pp-cx-add 768 (list (cons 'shl (lambda (a b) (arithmetic-shift a b))) 769 (cons 'shr (lambda (a b) (arithmetic-shift a (- 0 b))))) 770 toks)) 771 (define (%pp-cx-add toks) 772 (%pp-cx-binl %pp-cx-mul (list (cons 'plus +) (cons 'minus -)) toks)) 773 (define (%pp-cx-mul toks) 774 (%pp-cx-binl %pp-cx-unary 775 (list (cons 'star *) (cons 'slash quotient) (cons 'pct remainder)) 776 toks)) 777 778 (define (%pp-cx-unary toks) 779 (cond 780 ((null? toks) (die #f "#if: unexpected end of expression")) 781 ((%pp-punct? (car toks) 'plus) (%pp-cx-unary (cdr toks))) 782 ((%pp-punct? (car toks) 'minus) 783 (let* ((p (%pp-cx-unary (cdr toks))) (v (car p)) (r (cdr p))) 784 (cons (- 0 v) r))) 785 ((%pp-punct? (car toks) 'bang) 786 (let* ((p (%pp-cx-unary (cdr toks))) (v (car p)) (r (cdr p))) 787 (cons (if (= v 0) 1 0) r))) 788 ((%pp-punct? (car toks) 'tilde) 789 (let* ((p (%pp-cx-unary (cdr toks))) (v (car p)) (r (cdr p))) 790 (cons (bit-not v) r))) 791 (else (%pp-cx-primary toks)))) 792 793 (define (%pp-cx-primary toks) 794 (cond 795 ((null? toks) (die #f "#if: expected expression")) 796 ((%pp-int? (car toks)) (cons (tok-value (car toks)) (cdr toks))) 797 ((eq? (tok-kind (car toks)) 'CHAR) 798 (cons (tok-value (car toks)) (cdr toks))) 799 ((%pp-punct? (car toks) 'lparen) 800 (let* ((p (%pp-cx-expr (cdr toks))) (v (car p)) (r (cdr p))) 801 (cond 802 ((or (null? r) (not (%pp-punct? (car r) 'rparen))) 803 (die (if (null? r) #f (tok-loc (car r))) "#if: missing ')'")) 804 (else (cons v (cdr r)))))) 805 (else (die (tok-loc (car toks)) "#if: unexpected token" (tok-kind (car toks))))))