commit fe7fb1b71c7c54fbd652b376ae7bb77437a268ee
parent 41b5fb541064317f3fe63dfbc1d8aafd4e477275
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Mon, 27 Apr 2026 11:41:37 -0700
cc/parse: use pmatch record patterns for token dispatch
Migrates 19 token/ctype-dispatch sites from cond+(eq? (tok-kind t) ...)
chains to pmatch with ($ tok? (kind ...) (value ...)) patterns:
the helpers (at-kw?, at-punct?, expect-kw, expect-punct), parse-stmt
and stmt-starts-decl?, parse-primary, parse-unary, parse-cast-or-unary,
parse-postfix-rest, parse-decl-cont, parse-decl-suf-cont, parse-const-int,
paren-is-group?, token-is-decl?, parse-init-global,
parse-init-local-aggregate, and the IDENT pickup in parse-aggregate-spec
and parse-enum-spec.
Pure refactor; no behavior change. Sites where the dispatch is over
many keywords (parse-decl-spec) were left as-is — the pmatch form is
longer there without a clear readability win.
Diffstat:
| M | cc/parse.scm | | | 545 | ++++++++++++++++++++++++++++++++++++++----------------------------------------- |
1 file changed, 260 insertions(+), 285 deletions(-)
diff --git a/cc/parse.scm b/cc/parse.scm
@@ -10,19 +10,23 @@
(define (advance ps)
(let ((t (peek ps))) (ps-toks-set! ps (cdr (ps-toks ps))) t))
(define (at-kw? ps s)
- (let ((t (peek ps)))
- (and (eq? (tok-kind t) 'KW) (eq? (tok-value t) s))))
+ (pmatch (peek ps)
+ (($ tok? (kind KW) (value ,v)) (eq? v s))
+ (else #f)))
(define (at-punct? ps s)
- (let ((t (peek ps)))
- (and (eq? (tok-kind t) 'PUNCT) (eq? (tok-value t) s))))
+ (pmatch (peek ps)
+ (($ tok? (kind PUNCT) (value ,v)) (eq? v s))
+ (else #f)))
(define (expect-kw ps s)
(let ((t (peek ps)))
- (if (and (eq? (tok-kind t) 'KW) (eq? (tok-value t) s))
- (advance ps) (die (tok-loc t) "expected kw" s))))
+ (pmatch t
+ (($ tok? (kind KW) (value ,v)) (guard (eq? v s)) (advance ps))
+ (else (die (tok-loc t) "expected kw" s)))))
(define (expect-punct ps s)
(let ((t (peek ps)))
- (if (and (eq? (tok-kind t) 'PUNCT) (eq? (tok-value t) s))
- (advance ps) (die (tok-loc t) "expected punct" s))))
+ (pmatch t
+ (($ tok? (kind PUNCT) (value ,v)) (guard (eq? v s)) (advance ps))
+ (else (die (tok-loc t) "expected punct" s)))))
(define (scope-enter! ps)
(ps-scope-set! ps (cons '() (ps-scope ps)))
@@ -130,8 +134,9 @@
(define (parse-aggregate-spec ps kind)
(advance ps)
- (let ((tag (cond ((eq? (tok-kind (peek ps)) 'IDENT)
- (tok-value (advance ps))) (else #f))))
+ (let ((tag (pmatch (peek ps)
+ (($ tok? (kind IDENT)) (tok-value (advance ps)))
+ (else #f))))
(cond
((at-punct? ps 'lbrace)
(advance ps)
@@ -194,8 +199,9 @@
(define (parse-enum-spec ps)
(advance ps)
- (let ((tag (cond ((eq? (tok-kind (peek ps)) 'IDENT)
- (tok-value (advance ps))) (else #f))))
+ (let ((tag (pmatch (peek ps)
+ (($ tok? (kind IDENT)) (tok-value (advance ps)))
+ (else #f))))
(cond
((at-punct? ps 'lbrace)
(advance ps)
@@ -225,17 +231,15 @@
(define (parse-const-int ps)
(let ((t (peek ps)))
- (cond
- ((eq? (tok-kind t) 'INT) (tok-value (advance ps)))
- ((and (eq? (tok-kind t) 'PUNCT) (eq? (tok-value t) 'minus))
- (advance ps) (- 0 (parse-const-int ps)))
- ((and (eq? (tok-kind t) 'PUNCT) (eq? (tok-value t) 'plus))
- (advance ps) (parse-const-int ps))
- ((eq? (tok-kind t) 'IDENT)
- (let ((sm (scope-lookup ps (tok-value t))))
+ (pmatch t
+ (($ tok? (kind INT)) (tok-value (advance ps)))
+ (($ tok? (kind PUNCT) (value minus)) (advance ps) (- 0 (parse-const-int ps)))
+ (($ tok? (kind PUNCT) (value plus)) (advance ps) (parse-const-int ps))
+ (($ tok? (kind IDENT) (value ,n))
+ (let ((sm (scope-lookup ps n)))
(cond ((and sm (eq? (sym-kind sm) 'enum-const))
(advance ps) (sym-slot sm))
- (else (die (tok-loc t) "const?" (tok-value t))))))
+ (else (die (tok-loc t) "const?" n)))))
(else (die (tok-loc t) "const?" (tok-value t))))))
(define (parse-declarator ps base)
@@ -243,20 +247,21 @@
(lambda (n t) (cons n t))))
(define (parse-decl-cont ps)
- (cond
- ((at-punct? ps 'star)
+ (pmatch (peek ps)
+ (($ tok? (kind PUNCT) (value star))
(advance ps) (eat-cv-quals! ps)
(let* ((r (parse-decl-cont ps)) (rf (cdr r)))
(cons (car r) (lambda (b k) (rf (%mk-ptr b) k)))))
- ((and (at-punct? ps 'lparen) (paren-is-group? ps))
+ (($ tok? (kind PUNCT) (value lparen))
+ (guard (paren-is-group? ps))
(advance ps)
(let* ((i (parse-decl-cont ps)) (if- (cdr i)))
(expect-punct ps 'rparen)
(let ((s (parse-decl-suf-cont ps)))
(cons (car i) (lambda (b k) (if- (s b) k))))))
- ((eq? (tok-kind (peek ps)) 'IDENT)
- (let* ((tk (advance ps)) (n (tok-value tk))
- (s (parse-decl-suf-cont ps)))
+ (($ tok? (kind IDENT) (value ,n))
+ (advance ps)
+ (let ((s (parse-decl-suf-cont ps)))
(cons n (lambda (b k) (k n (s b))))))
(else
(let ((s (parse-decl-suf-cont ps)))
@@ -268,15 +273,15 @@
;; not arr (arr int 2) 3 (which would treat the leftmost suffix as
;; outermost). The recursive structure builds the inner suffix's
;; result first, then this level wraps.
- (cond
- ((at-punct? ps 'lbrack)
+ (pmatch (peek ps)
+ (($ tok? (kind PUNCT) (value lbrack))
(advance ps)
(let* ((ln (cond ((at-punct? ps 'rbrack) -1)
(else (parse-const-int ps))))
(_ (expect-punct ps 'rbrack))
(r (parse-decl-suf-cont ps)))
(lambda (b) (%mk-arr (r b) ln))))
- ((at-punct? ps 'lparen)
+ (($ tok? (kind PUNCT) (value lparen))
(advance ps)
(let* ((res (parse-fn-params ps))
(p (car res)) (v (cdr res)))
@@ -286,26 +291,23 @@
(else (lambda (b) b))))
(define (paren-is-group? ps)
- (let ((t (peek2 ps)))
- (cond
- ((eq? (tok-kind t) 'KW)
- (let ((v (tok-value t)))
- (cond ((or (eq? v 'void) (eq? v 'char) (eq? v 'short)
- (eq? v 'int) (eq? v 'long) (eq? v 'signed)
- (eq? v 'unsigned) (eq? v '_Bool)
- (eq? v 'struct) (eq? v 'union) (eq? v 'enum)
- (eq? v 'const) (eq? v 'volatile)
- (eq? v 'restrict) (eq? v 'static)
- (eq? v 'extern) (eq? v 'register)) #f)
- (else #t))))
- ((eq? (tok-kind t) 'IDENT)
- (cond ((typedef? ps (tok-value t)) #f) (else #t)))
- ((eq? (tok-kind t) 'PUNCT)
- (let ((v (tok-value t)))
- (cond ((eq? v 'rparen) #f)
- ((or (eq? v 'star) (eq? v 'lparen) (eq? v 'lbrack)) #t)
- (else #f))))
- (else #f))))
+ (pmatch (peek2 ps)
+ (($ tok? (kind KW) (value ,v))
+ (cond ((or (eq? v 'void) (eq? v 'char) (eq? v 'short)
+ (eq? v 'int) (eq? v 'long) (eq? v 'signed)
+ (eq? v 'unsigned) (eq? v '_Bool)
+ (eq? v 'struct) (eq? v 'union) (eq? v 'enum)
+ (eq? v 'const) (eq? v 'volatile)
+ (eq? v 'restrict) (eq? v 'static)
+ (eq? v 'extern) (eq? v 'register)) #f)
+ (else #t)))
+ (($ tok? (kind IDENT) (value ,n))
+ (cond ((typedef? ps n) #f) (else #t)))
+ (($ tok? (kind PUNCT) (value rparen)) #f)
+ (($ tok? (kind PUNCT) (value star)) #t)
+ (($ tok? (kind PUNCT) (value lparen)) #t)
+ (($ tok? (kind PUNCT) (value lbrack)) #t)
+ (else #f)))
(define (parse-fn-params ps)
(cond
@@ -532,15 +534,14 @@
;; ----- Global initializers ---------------------------------------------
(define (parse-init-global ps ty)
- (cond
+ (pmatch (peek ps)
;; String literal initializer for char[]
- ((and (eq? (ctype-kind ty) 'arr)
- (eq? (tok-kind (peek ps)) 'STR)
- (let ((et (car (ctype-ext ty))))
- (or (eq? et %t-i8) (eq? et %t-u8))))
- (let* ((t (advance ps))
- (s (tok-value t))
- (slen (bytevector-length s))
+ (($ tok? (kind STR) (value ,s))
+ (guard (and (eq? (ctype-kind ty) 'arr)
+ (let ((et (car (ctype-ext ty))))
+ (or (eq? et %t-i8) (eq? et %t-u8)))))
+ (advance ps)
+ (let* ((slen (bytevector-length s))
(decl (cdr (ctype-ext ty)))
(final (cond ((< decl 0) (+ slen 1)) (else decl))))
(cond ((< decl 0) (%init-fix-array-size! ty final)))
@@ -552,7 +553,7 @@
(bytevector-u8-set! bv i (bytevector-u8-ref s i))
(loop (+ i 1))))))))
;; Brace-form
- ((at-punct? ps 'lbrace)
+ (($ tok? (kind PUNCT) (value lbrace))
(advance ps)
(cond
((eq? (ctype-kind ty) 'arr)
@@ -735,15 +736,14 @@
;; (a 'var sym whose slot is the frame offset). Assumes the assignment
;; `=` has already been consumed.
(define (parse-init-local-aggregate ps sm ty)
- (cond
+ (pmatch (peek ps)
;; Local char[] = "string" — fill from string bytes.
- ((and (eq? (ctype-kind ty) 'arr)
- (eq? (tok-kind (peek ps)) 'STR)
- (let ((et (car (ctype-ext ty))))
- (or (eq? et %t-i8) (eq? et %t-u8))))
- (let* ((t (advance ps))
- (s (tok-value t))
- (slen (bytevector-length s))
+ (($ tok? (kind STR) (value ,s))
+ (guard (and (eq? (ctype-kind ty) 'arr)
+ (let ((et (car (ctype-ext ty))))
+ (or (eq? et %t-i8) (eq? et %t-u8)))))
+ (advance ps)
+ (let* ((slen (bytevector-length s))
(decl (cdr (ctype-ext ty)))
(final (cond ((< decl 0) (+ slen 1)) (else decl))))
(cond ((< decl 0) (%init-fix-array-size! ty final)))
@@ -761,7 +761,7 @@
(cg-assign (ps-cg ps))
(cg-pop (ps-cg ps))
(loop (+ i 1))))))))
- ((at-punct? ps 'lbrace)
+ (($ tok? (kind PUNCT) (value lbrace))
(advance ps)
(cond
((eq? (ctype-kind ty) 'arr)
@@ -1005,42 +1005,41 @@
(cg-fn-end (ps-cg ps)))))
(define (parse-stmt ps)
- (cond
- ((at-punct? ps 'lbrace) (parse-cstmt ps))
- ((at-kw? ps 'if) (parse-if-stmt ps))
- ((at-kw? ps 'while) (parse-while-stmt ps))
- ((at-kw? ps 'do) (parse-do-stmt ps))
- ((at-kw? ps 'for) (parse-for-stmt ps))
- ((at-kw? ps 'switch) (parse-switch-stmt ps))
- ((at-kw? ps 'return) (parse-return-stmt ps))
- ((at-kw? ps 'goto) (parse-goto-stmt ps))
- ((at-kw? ps 'break)
+ (pmatch (peek ps)
+ (($ tok? (kind PUNCT) (value lbrace)) (parse-cstmt ps))
+ (($ tok? (kind KW) (value if)) (parse-if-stmt ps))
+ (($ tok? (kind KW) (value while)) (parse-while-stmt ps))
+ (($ tok? (kind KW) (value do)) (parse-do-stmt ps))
+ (($ tok? (kind KW) (value for)) (parse-for-stmt ps))
+ (($ tok? (kind KW) (value switch)) (parse-switch-stmt ps))
+ (($ tok? (kind KW) (value return)) (parse-return-stmt ps))
+ (($ tok? (kind KW) (value goto)) (parse-goto-stmt ps))
+ (($ tok? (kind KW) (value break))
(advance ps) (expect-punct ps 'semi) (do-break ps))
- ((at-kw? ps 'continue)
+ (($ tok? (kind KW) (value continue))
(advance ps) (expect-punct ps 'semi) (do-continue ps))
- ((at-kw? ps 'case) (parse-case-stmt ps))
- ((at-kw? ps 'default) (parse-default-stmt ps))
- ((and (eq? (tok-kind (peek ps)) 'IDENT)
- (eq? (tok-kind (peek2 ps)) 'PUNCT)
- (eq? (tok-value (peek2 ps)) 'colon))
+ (($ tok? (kind KW) (value case)) (parse-case-stmt ps))
+ (($ tok? (kind KW) (value default)) (parse-default-stmt ps))
+ (($ tok? (kind IDENT))
+ (guard (and (eq? (tok-kind (peek2 ps)) 'PUNCT)
+ (eq? (tok-value (peek2 ps)) 'colon)))
(parse-labelled-stmt ps))
- ((stmt-starts-decl? ps) (parse-local-decl ps))
- (else (parse-expr-stmt ps))))
+ (else
+ (cond ((stmt-starts-decl? ps) (parse-local-decl ps))
+ (else (parse-expr-stmt ps))))))
(define (stmt-starts-decl? ps)
- (let ((t (peek ps)))
- (cond
- ((eq? (tok-kind t) 'KW)
- (let ((v (tok-value t)))
- (or (eq? v 'auto) (eq? v 'register) (eq? v 'static)
- (eq? v 'extern) (eq? v 'typedef) (eq? v 'const)
- (eq? v 'volatile) (eq? v 'restrict) (eq? v 'inline)
- (eq? v 'void) (eq? v 'char) (eq? v 'short) (eq? v 'int)
- (eq? v 'long) (eq? v 'signed) (eq? v 'unsigned)
- (eq? v '_Bool) (eq? v 'struct) (eq? v 'union)
- (eq? v 'enum))))
- ((eq? (tok-kind t) 'IDENT) (typedef? ps (tok-value t)))
- (else #f))))
+ (pmatch (peek ps)
+ (($ tok? (kind KW) (value ,v))
+ (or (eq? v 'auto) (eq? v 'register) (eq? v 'static)
+ (eq? v 'extern) (eq? v 'typedef) (eq? v 'const)
+ (eq? v 'volatile) (eq? v 'restrict) (eq? v 'inline)
+ (eq? v 'void) (eq? v 'char) (eq? v 'short) (eq? v 'int)
+ (eq? v 'long) (eq? v 'signed) (eq? v 'unsigned)
+ (eq? v '_Bool) (eq? v 'struct) (eq? v 'union)
+ (eq? v 'enum)))
+ (($ tok? (kind IDENT) (value ,n)) (typedef? ps n))
+ (else #f)))
(define (parse-local-decl ps)
(let* ((sp (parse-decl-spec ps))
@@ -1367,185 +1366,167 @@
(parse-binary-rhs ps mn)))))))))
(define (parse-unary ps)
- (let ((t (peek ps)))
- (cond
- ((eq? (tok-kind t) 'PUNCT)
- (let ((v (tok-value t)))
- (cond
- ((eq? v 'amp)
- (advance ps) (parse-unary ps)
- (cg-take-addr (ps-cg ps)))
- ((eq? v 'star)
- (advance ps) (parse-unary ps) (rval! ps)
- (cg-push-deref (ps-cg ps)))
- ((eq? v 'plus)
- (advance ps) (parse-unary ps)
- (rval! ps) (cg-promote (ps-cg ps)))
- ((eq? v 'minus)
- (advance ps) (parse-unary ps)
- (rval! ps) (cg-promote (ps-cg ps))
- (cg-unop (ps-cg ps) 'neg))
- ((eq? v 'tilde)
- (advance ps) (parse-unary ps)
- (rval! ps) (cg-promote (ps-cg ps))
- (cg-unop (ps-cg ps) 'bnot))
- ((eq? v 'bang)
- (advance ps) (parse-unary ps) (rval! ps)
- (cg-unop (ps-cg ps) 'lnot))
- ((eq? v 'inc) (advance ps) (parse-unary ps)
- (cg-dup (ps-cg ps))
- (cg-load (ps-cg ps))
- (cg-push-imm (ps-cg ps) %t-i32 1)
- (cg-binop (ps-cg ps) 'add) (cg-assign (ps-cg ps)))
- ((eq? v 'dec) (advance ps) (parse-unary ps)
- (cg-dup (ps-cg ps))
- (cg-load (ps-cg ps))
- (cg-push-imm (ps-cg ps) %t-i32 1)
- (cg-binop (ps-cg ps) 'sub) (cg-assign (ps-cg ps)))
- ((eq? v 'lparen) (parse-cast-or-unary ps))
- (else (parse-postfix ps)))))
- ((and (eq? (tok-kind t) 'KW) (eq? (tok-value t) 'sizeof))
- (advance ps)
- (cond
- ((at-punct? ps 'lparen)
- (advance ps)
- (cond
- ((token-is-decl? ps)
- (let* ((sp (parse-decl-spec ps))
- (p (parse-declarator ps (cdr sp)))
- (ty (cdr p)))
- (expect-punct ps 'rparen)
- (cg-push-imm (ps-cg ps) %t-u64
- (max (ctype-size ty) 0))))
- (else
- (parse-expr ps) (expect-punct ps 'rparen)
+ (pmatch (peek ps)
+ (($ tok? (kind PUNCT) (value amp))
+ (advance ps) (parse-unary ps)
+ (cg-take-addr (ps-cg ps)))
+ (($ tok? (kind PUNCT) (value star))
+ (advance ps) (parse-unary ps) (rval! ps)
+ (cg-push-deref (ps-cg ps)))
+ (($ tok? (kind PUNCT) (value plus))
+ (advance ps) (parse-unary ps)
+ (rval! ps) (cg-promote (ps-cg ps)))
+ (($ tok? (kind PUNCT) (value minus))
+ (advance ps) (parse-unary ps)
+ (rval! ps) (cg-promote (ps-cg ps))
+ (cg-unop (ps-cg ps) 'neg))
+ (($ tok? (kind PUNCT) (value tilde))
+ (advance ps) (parse-unary ps)
+ (rval! ps) (cg-promote (ps-cg ps))
+ (cg-unop (ps-cg ps) 'bnot))
+ (($ tok? (kind PUNCT) (value bang))
+ (advance ps) (parse-unary ps) (rval! ps)
+ (cg-unop (ps-cg ps) 'lnot))
+ (($ tok? (kind PUNCT) (value inc))
+ (advance ps) (parse-unary ps)
+ (cg-dup (ps-cg ps))
+ (cg-load (ps-cg ps))
+ (cg-push-imm (ps-cg ps) %t-i32 1)
+ (cg-binop (ps-cg ps) 'add) (cg-assign (ps-cg ps)))
+ (($ tok? (kind PUNCT) (value dec))
+ (advance ps) (parse-unary ps)
+ (cg-dup (ps-cg ps))
+ (cg-load (ps-cg ps))
+ (cg-push-imm (ps-cg ps) %t-i32 1)
+ (cg-binop (ps-cg ps) 'sub) (cg-assign (ps-cg ps)))
+ (($ tok? (kind PUNCT) (value lparen)) (parse-cast-or-unary ps))
+ (($ tok? (kind KW) (value sizeof))
+ (advance ps)
+ (cond
+ ((at-punct? ps 'lparen)
+ (advance ps)
+ (cond
+ ((token-is-decl? ps)
+ (let* ((sp (parse-decl-spec ps))
+ (p (parse-declarator ps (cdr sp)))
+ (ty (cdr p)))
+ (expect-punct ps 'rparen)
+ (cg-push-imm (ps-cg ps) %t-u64
+ (max (ctype-size ty) 0))))
+ (else
+ (parse-expr ps) (expect-punct ps 'rparen)
+ (let* ((tp (cg-top (ps-cg ps)))
+ (sz (max (ctype-size (opnd-type tp)) 0)))
+ (cg-pop (ps-cg ps))
+ (cg-push-imm (ps-cg ps) %t-u64 sz)))))
+ (else (parse-unary ps)
(let* ((tp (cg-top (ps-cg ps)))
(sz (max (ctype-size (opnd-type tp)) 0)))
(cg-pop (ps-cg ps))
(cg-push-imm (ps-cg ps) %t-u64 sz)))))
- (else (parse-unary ps)
- (let* ((tp (cg-top (ps-cg ps)))
- (sz (max (ctype-size (opnd-type tp)) 0)))
- (cg-pop (ps-cg ps))
- (cg-push-imm (ps-cg ps) %t-u64 sz)))))
- (else (parse-postfix ps)))))
+ (else (parse-postfix ps))))
(define (token-is-decl? ps)
- (let ((t (peek ps)))
- (cond
- ((eq? (tok-kind t) 'KW)
- (let ((v (tok-value t)))
- (or (eq? v 'void) (eq? v 'char) (eq? v 'short) (eq? v 'int)
- (eq? v 'long) (eq? v 'signed) (eq? v 'unsigned)
- (eq? v '_Bool) (eq? v 'struct) (eq? v 'union)
- (eq? v 'enum) (eq? v 'const) (eq? v 'volatile)
- (eq? v 'restrict) (eq? v 'inline))))
- ((eq? (tok-kind t) 'IDENT) (typedef? ps (tok-value t)))
- (else #f))))
+ (pmatch (peek ps)
+ (($ tok? (kind KW) (value ,v))
+ (or (eq? v 'void) (eq? v 'char) (eq? v 'short) (eq? v 'int)
+ (eq? v 'long) (eq? v 'signed) (eq? v 'unsigned)
+ (eq? v '_Bool) (eq? v 'struct) (eq? v 'union)
+ (eq? v 'enum) (eq? v 'const) (eq? v 'volatile)
+ (eq? v 'restrict) (eq? v 'inline)))
+ (($ tok? (kind IDENT) (value ,n)) (typedef? ps n))
+ (else #f)))
(define (parse-cast-or-unary ps)
- (let ((t (peek2 ps)))
- (cond
- ((and (eq? (tok-kind t) 'KW)
- (let ((v (tok-value t)))
- (or (eq? v 'void) (eq? v 'char) (eq? v 'short)
- (eq? v 'int) (eq? v 'long) (eq? v 'signed)
- (eq? v 'unsigned) (eq? v '_Bool)
- (eq? v 'struct) (eq? v 'union) (eq? v 'enum)
- (eq? v 'const) (eq? v 'volatile)
- (eq? v 'restrict))))
- (advance ps)
- (let* ((sp (parse-decl-spec ps))
- (p (parse-declarator ps (cdr sp)))
- (ty (cdr p)))
- (expect-punct ps 'rparen)
- (parse-unary ps)
- ;; Cast operand undergoes lvalue conversion first (C semantics):
- ;; arrays decay to pointers, lvals become rvals. cg-cast then
- ;; bit-casts the resulting rval to the target type.
- (rval! ps)
- (cg-cast (ps-cg ps) ty)))
- ((and (eq? (tok-kind t) 'IDENT) (typedef? ps (tok-value t)))
- (advance ps)
- (let* ((sp (parse-decl-spec ps))
- (p (parse-declarator ps (cdr sp)))
- (ty (cdr p)))
- (expect-punct ps 'rparen)
- (parse-unary ps)
- ;; Cast operand undergoes lvalue conversion first (C semantics):
- ;; arrays decay to pointers, lvals become rvals. cg-cast then
- ;; bit-casts the resulting rval to the target type.
- (rval! ps)
- (cg-cast (ps-cg ps) ty)))
- (else (advance ps) (parse-expr ps)
- (expect-punct ps 'rparen)
- (parse-postfix-rest ps)))))
+ (pmatch (peek2 ps)
+ (($ tok? (kind KW) (value ,v))
+ (guard (or (eq? v 'void) (eq? v 'char) (eq? v 'short)
+ (eq? v 'int) (eq? v 'long) (eq? v 'signed)
+ (eq? v 'unsigned) (eq? v '_Bool)
+ (eq? v 'struct) (eq? v 'union) (eq? v 'enum)
+ (eq? v 'const) (eq? v 'volatile)
+ (eq? v 'restrict)))
+ (advance ps)
+ (let* ((sp (parse-decl-spec ps))
+ (p (parse-declarator ps (cdr sp)))
+ (ty (cdr p)))
+ (expect-punct ps 'rparen)
+ (parse-unary ps)
+ ;; Cast operand undergoes lvalue conversion first (C semantics):
+ ;; arrays decay to pointers, lvals become rvals. cg-cast then
+ ;; bit-casts the resulting rval to the target type.
+ (rval! ps)
+ (cg-cast (ps-cg ps) ty)))
+ (($ tok? (kind IDENT) (value ,n))
+ (guard (typedef? ps n))
+ (advance ps)
+ (let* ((sp (parse-decl-spec ps))
+ (p (parse-declarator ps (cdr sp)))
+ (ty (cdr p)))
+ (expect-punct ps 'rparen)
+ (parse-unary ps)
+ (rval! ps)
+ (cg-cast (ps-cg ps) ty)))
+ (else (advance ps) (parse-expr ps)
+ (expect-punct ps 'rparen)
+ (parse-postfix-rest ps))))
(define (parse-postfix ps)
(parse-primary ps) (parse-postfix-rest ps))
(define (parse-postfix-rest ps)
(let lp ()
- (let ((t (peek ps)))
- (cond
- ((not (eq? (tok-kind t) 'PUNCT)) #t)
- (else
- (let ((v (tok-value t)))
- (cond
- ((eq? v 'lbrack)
- (advance ps) (rval! ps)
- (parse-expr ps) (rval! ps)
- (expect-punct ps 'rbrack)
- (cg-binop (ps-cg ps) 'add)
- (cg-push-deref (ps-cg ps)) (lp))
- ((eq? v 'lparen)
- (advance ps) (rval-not-fn! ps)
- (let* ((fn-ty (call-fn-type (ps-cg ps)))
- (n (parse-call-args ps fn-ty))
- ;; has-result? = #f for known void returns. Skips
- ;; the wasted ST a0 → frame-slot spill that
- ;; cg-call would otherwise emit for void calls.
- (has-result?
- (cond
- ((not fn-ty) #t)
- ((eq? (ctype-kind (car (ctype-ext fn-ty))) 'void) #f)
- (else #t))))
- (expect-punct ps 'rparen)
- (cg-call (ps-cg ps) n has-result?)
- ;; Maintain parse's "one rval per expression" invariant
- ;; so comma / parse-expr-stmt / for-init/step pop sites
- ;; stay simple. The placeholder is vstack-only and
- ;; never materialized (cg-pop is a vstack op, no emit).
- (cond ((not has-result?)
- (cg-push-imm (ps-cg ps) %t-i32 0)))
- (lp)))
- ((eq? v 'dot)
- (advance ps)
- (let ((nt (advance ps)))
- (cond
- ((not (eq? (tok-kind nt) 'IDENT))
- (die (tok-loc nt) "expected field name"))
- (else
- (cg-push-field (ps-cg ps) (tok-value nt)) (lp)))))
- ((eq? v 'arrow)
- (advance ps)
- (let ((nt (advance ps)))
- (cond
- ((not (eq? (tok-kind nt) 'IDENT))
- (die (tok-loc nt) "expected field name"))
- (else
- ;; ptr -> field: load the pointer to rval, deref to
- ;; reach the struct lval, then push the field.
- (rval! ps)
- (cg-push-deref (ps-cg ps))
- (cg-push-field (ps-cg ps) (tok-value nt)) (lp)))))
- ((eq? v 'inc)
- (advance ps)
- (cg-postinc (ps-cg ps)) (lp))
- ((eq? v 'dec)
- (advance ps)
- (cg-postdec (ps-cg ps)) (lp))
- (else #t))))))))
+ (pmatch (peek ps)
+ (($ tok? (kind PUNCT) (value lbrack))
+ (advance ps) (rval! ps)
+ (parse-expr ps) (rval! ps)
+ (expect-punct ps 'rbrack)
+ (cg-binop (ps-cg ps) 'add)
+ (cg-push-deref (ps-cg ps)) (lp))
+ (($ tok? (kind PUNCT) (value lparen))
+ (advance ps) (rval-not-fn! ps)
+ (let* ((fn-ty (call-fn-type (ps-cg ps)))
+ (n (parse-call-args ps fn-ty))
+ ;; has-result? = #f for known void returns. Skips the
+ ;; wasted ST a0 → frame-slot spill that cg-call would
+ ;; otherwise emit for void calls.
+ (has-result?
+ (cond
+ ((not fn-ty) #t)
+ ((eq? (ctype-kind (car (ctype-ext fn-ty))) 'void) #f)
+ (else #t))))
+ (expect-punct ps 'rparen)
+ (cg-call (ps-cg ps) n has-result?)
+ ;; Maintain parse's "one rval per expression" invariant so
+ ;; comma / parse-expr-stmt / for-init/step pop sites stay
+ ;; simple. The placeholder is vstack-only and never
+ ;; materialized (cg-pop is a vstack op, no emit).
+ (cond ((not has-result?)
+ (cg-push-imm (ps-cg ps) %t-i32 0)))
+ (lp)))
+ (($ tok? (kind PUNCT) (value dot))
+ (advance ps)
+ (pmatch (advance ps)
+ (($ tok? (kind IDENT) (value ,n))
+ (cg-push-field (ps-cg ps) n) (lp))
+ (($ tok? (loc ,l)) (die l "expected field name"))))
+ (($ tok? (kind PUNCT) (value arrow))
+ (advance ps)
+ (pmatch (advance ps)
+ (($ tok? (kind IDENT) (value ,n))
+ ;; ptr -> field: load the pointer to rval, deref to reach
+ ;; the struct lval, then push the field.
+ (rval! ps)
+ (cg-push-deref (ps-cg ps))
+ (cg-push-field (ps-cg ps) n) (lp))
+ (($ tok? (loc ,l)) (die l "expected field name"))))
+ (($ tok? (kind PUNCT) (value inc))
+ (advance ps)
+ (cg-postinc (ps-cg ps)) (lp))
+ (($ tok? (kind PUNCT) (value dec))
+ (advance ps)
+ (cg-postdec (ps-cg ps)) (lp))
+ (else #t))))
;; call-fn-type cg -> ctype-or-#f
;; The function operand sits at the top of the vstack when
@@ -1651,37 +1632,31 @@
(define (parse-primary ps)
(let ((t (peek ps)))
- (cond
- ((eq? (tok-kind t) 'INT)
+ (pmatch t
+ (($ tok? (kind INT) (value ,n))
(advance ps)
- (cg-push-imm (ps-cg ps) %t-i32 (tok-value t)))
- ((eq? (tok-kind t) 'CHAR)
+ (cg-push-imm (ps-cg ps) %t-i32 n))
+ (($ tok? (kind CHAR) (value ,c))
(advance ps)
- (cg-push-imm (ps-cg ps) %t-i8 (tok-value t)))
- ((eq? (tok-kind t) 'STR)
+ (cg-push-imm (ps-cg ps) %t-i8 c))
+ (($ tok? (kind STR) (value ,s))
(advance ps)
- (cg-push-string (ps-cg ps) (tok-value t)))
- ((eq? (tok-kind t) 'IDENT)
+ (cg-push-string (ps-cg ps) s))
+ (($ tok? (kind IDENT) (value ,n))
(cond
- ((bv= (tok-value t) "__builtin_va_start")
- (parse-builtin-va-start ps))
- ((bv= (tok-value t) "__builtin_va_arg")
- (parse-builtin-va-arg ps))
- ((bv= (tok-value t) "__builtin_va_end")
- (parse-builtin-va-end ps))
+ ((bv= n "__builtin_va_start") (parse-builtin-va-start ps))
+ ((bv= n "__builtin_va_arg") (parse-builtin-va-arg ps))
+ ((bv= n "__builtin_va_end") (parse-builtin-va-end ps))
(else
- (let ((sm (scope-lookup ps (tok-value t))))
+ (let ((sm (scope-lookup ps n)))
(advance ps)
(cond
- ((not sm) (die (tok-loc t) "undecl" (tok-value t)))
+ ((not sm) (die (tok-loc t) "undecl" n))
((eq? (sym-kind sm) 'enum-const)
(cg-push-imm (ps-cg ps) %t-i32 (sym-slot sm)))
(else (cg-push-sym (ps-cg ps) sm)))))))
- ((eq? (tok-kind t) 'PUNCT)
- (cond
- ((eq? (tok-value t) 'lparen)
- (advance ps) (parse-expr ps) (expect-punct ps 'rparen))
- (else (die (tok-loc t) "unexp" (tok-value t)))))
+ (($ tok? (kind PUNCT) (value lparen))
+ (advance ps) (parse-expr ps) (expect-punct ps 'rparen))
(else (die (tok-loc t) "unexp" (tok-value t))))))
(define (rval! ps)
