commit 311fbbd7bf644c421acabce8905880cd1b367362
parent 3ad49004bf38631d89ed95d4db57c03c360d40c4
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Fri, 1 May 2026 14:55:48 -0700
cc: deduplicate and unify constant-expression evaluator
- Delete %find-field (5347); its two callers now use %cg-find-field
- Move %ctype-ptr?, %ctype-pointee, %ctype-unsigned?, %ctype-fp? from
cg section to data section where they belong alongside ctype accessors
- Inline %ctype-size (trivial alias for ctype-size) at all callsites
- Unify the two constant-expression grammar implementations: delete the
15-function %pp-cx-* block; add %pp-make-const-ps IO adapter that
wraps a preprocessor token list as a minimal pstate (empty scope,
ps-cg=#f) so pp-eval-cexpr can delegate directly to parse-const-int;
guard %const-sizeof-expr against the ps-cg=#f case
- Refactor parse-const-* binary levels: add %const-binl (generic
left-associative level loop), %const-arith-op, %const-div-op,
%const-cmp-op; collapse 8 hand-rolled binary level functions into
single-line %const-binl calls
Net: -163 lines, one shared grammar instead of two
Diffstat:
| M | cc/cc.scm | | | 303 | ++++++++++++++++++++++--------------------------------------------------------- |
1 file changed, 82 insertions(+), 221 deletions(-)
diff --git a/cc/cc.scm b/cc/cc.scm
@@ -2431,27 +2431,35 @@
;; --- pp-eval-cexpr: #if expression evaluator ---
;; Steps: resolve `defined NAME`, macro-expand the rest, treat any
-;; remaining IDENT as 0, parse with recursive descent.
+;; remaining IDENT as 0, then delegate to parse-const-int via a minimal
+;; pstate (empty scope, no cg). sizeof(type) works as an extension;
+;; sizeof(expr) dies with a clear message.
;;
;; Arena boundary (test 093 A→B→C pattern). Everything inside the
-;; call-with-heap-rewind thunk is scratch: `s1`/`s2`/`s3` (each a fresh
-;; token list, where `s2` runs the full macro-expansion engine), plus
-;; the recursive parser's (val . rest) cons cell at every level. The
-;; result is a fixnum, so no pre-allocated out cell is needed — `val`
-;; survives the rewind by virtue of being an immediate. The error path
-;; goes through `die` (which sys-exits), so no rewind there.
+;; call-with-heap-rewind thunk is scratch: `s1`/`s2`/`s3` plus the
+;; parse-const-* (value . ctype) cells at every level. parse-const-int
+;; returns the integer via `car`, which is a fixnum immediate and
+;; survives the rewind. The error path goes through `die` (sys-exits),
+;; so no rewind there.
+(define (%pp-make-const-ps toks)
+ (%pstate (make-list-iter toks)
+ (%world (list '()) (list '()) '() '())
+ '() #f #f))
+
(define (pp-eval-cexpr toks macros)
(call-with-heap-rewind
(lambda ()
(let* ((state (%pp-state macros '() #f 0 #f '() '()))
(s1 (%pp-resolve-defined toks state))
(s2 (%pp-expand-line s1 state))
- (s3 (%pp-idents-as-zero s2)))
- (let-values (((val rest) (%pp-cx-expr s3)))
- (cond
- ((null? rest) val)
- (else (die (tok-loc (car rest)) "#if: garbage at end of expression"
- (tok-kind (car rest))))))))))
+ (s3 (%pp-idents-as-zero s2))
+ (ps (%pp-make-const-ps s3))
+ (val (parse-const-int ps))
+ (t (peek ps)))
+ (cond
+ ((eq? (tok-kind t) 'EOF) val)
+ (else (die (tok-loc t) "#if: garbage at end of expression"
+ (tok-kind t))))))))
(define (%pp-expand-line toks state)
(let ((out (make-buf-list)))
@@ -2493,101 +2501,6 @@
(else t)))
toks))
-;; --- recursive-descent #if expression parser ---
-;; Each %pp-cx-* returns (values value rest).
-(define (%pp-cx-expr toks) (%pp-cx-cond toks))
-
-(define (%pp-cx-cond toks)
- (let-values (((v rest) (%pp-cx-lor toks)))
- (cond
- ((and (not (null? rest)) (%pp-punct? (car rest) 'qmark))
- (let-values (((vt after) (%pp-cx-expr (cdr rest))))
- (cond
- ((or (null? after) (not (%pp-punct? (car after) 'colon)))
- (die (if (null? after) #f (tok-loc (car after))) "?: missing ':'"))
- (else
- (let-values (((vf rest3) (%pp-cx-cond (cdr after))))
- (values (if (not (= v 0)) vt vf) rest3))))))
- (else (values v rest)))))
-
-(define (%pp-cx-binl next ops toks)
- (let-values (((v rest) (next toks)))
- (let loop ((v v) (rest rest))
- (cond
- ((null? rest) (values v rest))
- (else
- (let* ((tt (car rest))
- (hit (and (eq? (tok-kind tt) 'PUNCT)
- (alist-ref/eq (tok-value tt) ops))))
- (cond
- ((not hit) (values v rest))
- (else
- (let-values (((v2 rest2) (next (cdr rest))))
- (loop (hit v v2) rest2))))))))))
-
-(define (%pp-cx-lor toks)
- (%pp-cx-binl %pp-cx-land
- (list (cons 'lor (lambda (a b) (if (or (not (= a 0)) (not (= b 0))) 1 0))))
- toks))
-(define (%pp-cx-land toks)
- (%pp-cx-binl %pp-cx-bor
- (list (cons 'land (lambda (a b) (if (and (not (= a 0)) (not (= b 0))) 1 0))))
- toks))
-(define (%pp-cx-bor toks) (%pp-cx-binl %pp-cx-bxor (list (cons 'bar bit-or)) toks))
-(define (%pp-cx-bxor toks) (%pp-cx-binl %pp-cx-band (list (cons 'caret bit-xor)) toks))
-(define (%pp-cx-band toks) (%pp-cx-binl %pp-cx-eq (list (cons 'amp bit-and)) toks))
-(define (%pp-cx-eq toks)
- (%pp-cx-binl %pp-cx-rel
- (list (cons 'eq2 (lambda (a b) (if (= a b) 1 0)))
- (cons 'ne (lambda (a b) (if (= a b) 0 1))))
- toks))
-(define (%pp-cx-rel toks)
- (%pp-cx-binl %pp-cx-shift
- (list (cons 'lt (lambda (a b) (if (< a b) 1 0)))
- (cons 'le (lambda (a b) (if (<= a b) 1 0)))
- (cons 'gt (lambda (a b) (if (> a b) 1 0)))
- (cons 'ge (lambda (a b) (if (>= a b) 1 0))))
- toks))
-(define (%pp-cx-shift toks)
- (%pp-cx-binl %pp-cx-add
- (list (cons 'shl (lambda (a b) (arithmetic-shift a b)))
- (cons 'shr (lambda (a b) (arithmetic-shift a (- 0 b)))))
- toks))
-(define (%pp-cx-add toks)
- (%pp-cx-binl %pp-cx-mul (list (cons 'plus +) (cons 'minus -)) toks))
-(define (%pp-cx-mul toks)
- (%pp-cx-binl %pp-cx-unary
- (list (cons 'star *) (cons 'slash quotient) (cons 'pct remainder))
- toks))
-
-(define (%pp-cx-unary toks)
- (cond
- ((null? toks) (die #f "#if: unexpected end of expression"))
- ((%pp-punct? (car toks) 'plus) (%pp-cx-unary (cdr toks)))
- ((%pp-punct? (car toks) 'minus)
- (let-values (((v r) (%pp-cx-unary (cdr toks))))
- (values (- 0 v) r)))
- ((%pp-punct? (car toks) 'bang)
- (let-values (((v r) (%pp-cx-unary (cdr toks))))
- (values (if (= v 0) 1 0) r)))
- ((%pp-punct? (car toks) 'tilde)
- (let-values (((v r) (%pp-cx-unary (cdr toks))))
- (values (bit-not v) r)))
- (else (%pp-cx-primary toks))))
-
-(define (%pp-cx-primary toks)
- (cond
- ((null? toks) (die #f "#if: expected expression"))
- ((%pp-int? (car toks)) (values (tok-value (car toks)) (cdr toks)))
- ((eq? (tok-kind (car toks)) 'CHAR)
- (values (tok-value (car toks)) (cdr toks)))
- ((%pp-punct? (car toks) 'lparen)
- (let-values (((v r) (%pp-cx-expr (cdr toks))))
- (cond
- ((or (null? r) (not (%pp-punct? (car r) 'rparen)))
- (die (if (null? r) #f (tok-loc (car r))) "#if: missing ')'"))
- (else (values v (cdr r))))))
- (else (die (tok-loc (car toks)) "#if: unexpected token" (tok-kind (car toks))))))
;; cc/cg.scm — codegen state and emission API.
;; Conversion split: parse owns promotion etc; cg owns sign extension,
;; signed/unsigned dispatch, pointer scaling.
@@ -4571,93 +4484,60 @@
(cond ((%const-bool? c) t) (else e))))
(else c))))
+;; Generic left-associative binary level.
+;; ops: alist of punct-sym → (vp vp → vp).
+(define (%const-binl ps next ops)
+ (let lp ((a (next ps)))
+ (let* ((t (peek ps))
+ (hit (and (eq? (tok-kind t) 'PUNCT)
+ (alist-ref/eq (tok-value t) ops))))
+ (cond ((not hit) a)
+ (else (advance ps) (lp (hit a (next ps))))))))
+
+;; Arithmetic combiner: promote both, arith-conv, apply fn, truncate.
+(define (%const-arith-op fn a b)
+ (let-values (((av bv rt) (%const-arith-conv (%const-promote a) (%const-promote b))))
+ (cons (%const-trunc (fn av bv) rt) rt)))
+
+;; Like %const-arith-op but rejects a zero divisor.
+(define (%const-div-op fn a b)
+ (let-values (((av bv rt) (%const-arith-conv (%const-promote a) (%const-promote b))))
+ (cond ((= bv 0) (die #f "const-expr: divide by zero")))
+ (cons (%const-trunc (fn av bv) rt) rt)))
+
+;; Comparison combiner: result is always (0-or-1 . %t-i32).
+(define (%const-cmp-op fn a b)
+ (let-values (((av bv _rt) (%const-arith-conv (%const-promote a) (%const-promote b))))
+ (cons (if (fn av bv) 1 0) %t-i32)))
+
(define (parse-const-lor ps)
- (let lp ((a (parse-const-land ps)))
- (cond
- ((at-punct? ps 'lor)
- (advance ps)
- (let ((b (parse-const-land ps)))
- (lp (cons (if (or (%const-bool? a) (%const-bool? b)) 1 0)
- %t-i32))))
- (else a))))
+ (%const-binl ps parse-const-land
+ (list (cons 'lor (lambda (a b)
+ (cons (if (or (%const-bool? a) (%const-bool? b)) 1 0) %t-i32))))))
(define (parse-const-land ps)
- (let lp ((a (parse-const-bor ps)))
- (cond
- ((at-punct? ps 'land)
- (advance ps)
- (let ((b (parse-const-bor ps)))
- (lp (cons (if (and (%const-bool? a) (%const-bool? b)) 1 0)
- %t-i32))))
- (else a))))
+ (%const-binl ps parse-const-bor
+ (list (cons 'land (lambda (a b)
+ (cons (if (and (%const-bool? a) (%const-bool? b)) 1 0) %t-i32))))))
(define (parse-const-bor ps)
- (let lp ((a (parse-const-bxor ps)))
- (cond
- ((at-punct? ps 'bar)
- (advance ps)
- (let ((b (parse-const-bxor ps)))
- (let-values (((av bv rt) (%const-arith-conv (%const-promote a)
- (%const-promote b))))
- (lp (cons (bit-or av bv) rt)))))
- (else a))))
-
+ (%const-binl ps parse-const-bxor (list (cons 'bar (lambda (a b) (%const-arith-op bit-or a b))))))
(define (parse-const-bxor ps)
- (let lp ((a (parse-const-band ps)))
- (cond
- ((at-punct? ps 'caret)
- (advance ps)
- (let ((b (parse-const-band ps)))
- (let-values (((av bv rt) (%const-arith-conv (%const-promote a)
- (%const-promote b))))
- (lp (cons (bit-xor av bv) rt)))))
- (else a))))
-
+ (%const-binl ps parse-const-band (list (cons 'caret (lambda (a b) (%const-arith-op bit-xor a b))))))
(define (parse-const-band ps)
- (let lp ((a (parse-const-eq ps)))
- (cond
- ((at-punct? ps 'amp)
- (advance ps)
- (let ((b (parse-const-eq ps)))
- (let-values (((av bv rt) (%const-arith-conv (%const-promote a)
- (%const-promote b))))
- (lp (cons (bit-and av bv) rt)))))
- (else a))))
+ (%const-binl ps parse-const-eq (list (cons 'amp (lambda (a b) (%const-arith-op bit-and a b))))))
(define (parse-const-eq ps)
- (let lp ((a (parse-const-rel ps)))
- (let ((t (peek ps)))
- (cond
- ((and (eq? (tok-kind t) 'PUNCT)
- (or (eq? (tok-value t) 'eq2) (eq? (tok-value t) 'ne)))
- (let ((op (tok-value (advance ps)))
- (b (parse-const-rel ps)))
- (let-values (((av bv _rt) (%const-arith-conv (%const-promote a)
- (%const-promote b))))
- (lp (cons
- (cond ((eq? op 'eq2) (if (= av bv) 1 0))
- (else (if (= av bv) 0 1)))
- %t-i32)))))
- (else a)))))
+ (%const-binl ps parse-const-rel
+ (list (cons 'eq2 (lambda (a b) (%const-cmp-op = a b)))
+ (cons 'ne (lambda (a b) (%const-cmp-op (lambda (x y) (not (= x y))) a b))))))
(define (parse-const-rel ps)
- (let lp ((a (parse-const-shift ps)))
- (let ((t (peek ps)))
- (cond
- ((and (eq? (tok-kind t) 'PUNCT)
- (let ((v (tok-value t)))
- (or (eq? v 'lt) (eq? v 'le) (eq? v 'gt) (eq? v 'ge))))
- (let ((op (tok-value (advance ps)))
- (b (parse-const-shift ps)))
- (let-values (((av bv _rt) (%const-arith-conv (%const-promote a)
- (%const-promote b))))
- (lp (cons
- (cond ((eq? op 'lt) (if (< av bv) 1 0))
- ((eq? op 'le) (if (<= av bv) 1 0))
- ((eq? op 'gt) (if (> av bv) 1 0))
- (else (if (>= av bv) 1 0)))
- %t-i32)))))
- (else a)))))
+ (%const-binl ps parse-const-shift
+ (list (cons 'lt (lambda (a b) (%const-cmp-op < a b)))
+ (cons 'le (lambda (a b) (%const-cmp-op <= a b)))
+ (cons 'gt (lambda (a b) (%const-cmp-op > a b)))
+ (cons 'ge (lambda (a b) (%const-cmp-op >= a b))))))
(define (parse-const-shift ps)
;; Shift result type is the (promoted) lhs type — rhs is just a count.
@@ -4679,38 +4559,15 @@
(else a)))))
(define (parse-const-add ps)
- (let lp ((a (parse-const-mul ps)))
- (let ((t (peek ps)))
- (cond
- ((and (eq? (tok-kind t) 'PUNCT)
- (or (eq? (tok-value t) 'plus) (eq? (tok-value t) 'minus)))
- (let ((op (tok-value (advance ps)))
- (b (parse-const-mul ps)))
- (let-values (((av bv rt) (%const-arith-conv (%const-promote a)
- (%const-promote b))))
- (let ((raw (cond ((eq? op 'plus) (+ av bv)) (else (- av bv)))))
- (lp (cons (%const-trunc raw rt) rt))))))
- (else a)))))
+ (%const-binl ps parse-const-mul
+ (list (cons 'plus (lambda (a b) (%const-arith-op + a b)))
+ (cons 'minus (lambda (a b) (%const-arith-op - a b))))))
(define (parse-const-mul ps)
- (let lp ((a (parse-const-cast ps)))
- (let ((t (peek ps)))
- (cond
- ((and (eq? (tok-kind t) 'PUNCT)
- (let ((v (tok-value t)))
- (or (eq? v 'star) (eq? v 'slash) (eq? v 'pct))))
- (let ((op (tok-value (advance ps)))
- (b (parse-const-cast ps)))
- (let-values (((av bv rt) (%const-arith-conv (%const-promote a)
- (%const-promote b))))
- (cond
- ((and (or (eq? op 'slash) (eq? op 'pct)) (= bv 0))
- (die (tok-loc t) "const-expr: divide by zero")))
- (let ((raw (cond ((eq? op 'star) (* av bv))
- ((eq? op 'slash) (quotient av bv))
- (else (remainder av bv)))))
- (lp (cons (%const-trunc raw rt) rt))))))
- (else a)))))
+ (%const-binl ps parse-const-cast
+ (list (cons 'star (lambda (a b) (%const-arith-op * a b)))
+ (cons 'slash (lambda (a b) (%const-div-op quotient a b)))
+ (cons 'pct (lambda (a b) (%const-div-op remainder a b))))))
(define (parse-const-cast ps)
;; (typename) operand — distinguished from ( expr ) by paren-is-group?.
@@ -4940,13 +4797,17 @@
;; discarded. Returns the operand's byte size as a non-negative int.
;; If `paren?`, consumes the closing `)` after parsing.
(define (%const-sizeof-expr ps paren?)
- (let ((tag (cg-snapshot (ps-cg ps))))
- (cond (paren? (parse-expr ps) (expect-punct ps 'rparen))
- (else (parse-unary ps)))
- (let* ((tp (cg-top (ps-cg ps)))
- (sz (max (ctype-size (opnd-type tp)) 0)))
- (cg-rewind (ps-cg ps) tag)
- sz)))
+ (cond
+ ((not (ps-cg ps))
+ (die #f "#if: sizeof of expression not valid in preprocessor context"))
+ (else
+ (let ((tag (cg-snapshot (ps-cg ps))))
+ (cond (paren? (parse-expr ps) (expect-punct ps 'rparen))
+ (else (parse-unary ps)))
+ (let* ((tp (cg-top (ps-cg ps)))
+ (sz (max (ctype-size (opnd-type tp)) 0)))
+ (cg-rewind (ps-cg ps) tag)
+ sz)))))
;; Convenience: returns the integer value alone (callers that don't
;; need the type half of parse-const-expr's (value . ctype) result).
