From 73618309385169bae14669cf0abb6b5e8216c7db Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 15:23:34 +0700 Subject: [PATCH] A char minus a char takes the integer width its site wants, a chain of + or - folds left step by step, and a char plus a u64 is checked unsigned. --- lib/check.ml | 150 +++++++++++++++++++++++++--------- lib/emit.ml | 1 + runtime/flan_rt.c | 15 ++++ test/programs/char-arith.flan | 16 +++- test/test_acceptance.ml | 11 ++- test/test_flan.ml | 8 +- 6 files changed, 158 insertions(+), 43 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index b19f1553..89df4fba 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -11233,45 +11233,84 @@ and char_arith loc name = (* One step of char arithmetic (decision 131, Kotlin's rules): a char plus or minus an integer is a char, checked to be a scalar value — at compile time - when both sides are constants, by [flan_char_of] at run time otherwise — - and a char minus a char is the distance between them, an i32. Anything - else with a char in it is refused. *) -and char_step _ctx loc name (a : Tast.expr) (b : Tast.expr) : Tast.expr = + when both sides are constants, at run time otherwise — and a char minus a + char is the distance between them, an integer at the width the site wants + (i32 when it wants none), as any integer expression is. A step with no char + in it is the ordinary one. Anything else with a char in it is refused. *) +and char_step ~want loc name (a : Tast.expr) (b : Tast.expr) : Tast.expr = let i64 e = widen loc dyn_i64 e in let const (e : Tast.expr) = match e.Tast.e with Tast.Int (n, _) -> Some n | _ -> None in let op = if String.equal name "+" then Tast.Add else Tast.Sub in - let fold f = match const a, const b with - | Some x, Some y -> Some (f x y) | _ -> None + let scalar n = + Int64.compare n 0L >= 0 && Int64.compare n 0x10ffffL <= 0 + && not (Int64.compare n 0xd800L >= 0 && Int64.compare n 0xdfffL <= 0) in - let apply x y = if String.equal name "+" then Int64.add x y else Int64.sub x y in + let not_scalar n = + Loc.failk "check/char-range" loc + "this is %s, which is not a Unicode scalar value, so it is not a \ + char. A char is a code point from 0 to 0x10FFFF, outside 0xD800 \ + to 0xDFFF" n + in + let kind = match want with Some (Types.Int k) -> k | _ -> Types.I32 in match a.Tast.ty, b.Tast.ty with | Types.Char, Types.Char when String.equal name "-" -> - (match fold Int64.sub with - | Some n -> mk loc (Types.Int Types.I32) (Tast.Int (n, Types.I32)) - | None -> - let i32 e = widen loc (Types.Int Types.I32) e in - mk loc (Types.Int Types.I32) (Tast.Prim (Tast.Sub, [ i32 a; i32 b ]))) - | Types.Char, Types.Int _ | Types.Int _, Types.Char + let t = Types.Int kind in + (match const a, const b with + | Some x, Some y -> int_literal loc ~want:(Some t) (Int64.sub x y) + | _ -> mk loc t (Tast.Prim (Tast.Sub, [ widen loc t a; widen loc t b ]))) + | Types.Char, Types.Int k | Types.Int k, Types.Char when not (String.equal name "-" && b.Tast.ty = Types.Char) -> - (match fold apply with - | Some n -> - if Int64.compare n 0L >= 0 && Int64.compare n 0x10ffffL <= 0 - && not (Int64.compare n 0xd800L >= 0 && Int64.compare n 0xdfffL <= 0) - then mk loc Types.Char (Tast.Int (n, Types.U32)) - else - Loc.failk "check/char-range" loc - "this is %Ld, which is not a Unicode scalar value, so it is not a \ - char. A char is a code point from 0 to 0x10FFFF, outside 0xD800 \ - to 0xDFFF" n - | None -> + let c, n = if a.Tast.ty = Types.Char then a, b else b, a in + (match const c, const n with + (* A u64 past the largest i64 is held as a negative i64: no char. *) + | Some _, Some v when k = Types.U64 && Int64.compare v 0L < 0 -> + not_scalar (Printf.sprintf "past 0x10FFFF") + | Some x, Some y -> + let r = if op = Tast.Add then Int64.add x y else Int64.sub x y in + if scalar r then mk loc Types.Char (Tast.Int (r, Types.U32)) + else not_scalar (Int64.to_string r) + (* A u64 is taken as itself, so no large one wraps round to a char. *) + | _ when k = Types.U64 -> + rt loc Types.Char "flan_char_step_u64" + [ widen loc (Types.Int Types.I32) c; n; + mk loc (Types.Int Types.I32) + (Tast.Int ((if op = Tast.Sub then 1L else 0L), Types.I32)); + here loc ] + | _ -> let sum = mk loc dyn_i64 (Tast.Prim (op, [ i64 a; i64 b ])) in rt loc Types.Char "flan_char_of" [ sum; here loc ]) | _ -> char_arith (if a.Tast.ty = Types.Char then a.Tast.loc else b.Tast.loc) name; assert false +(* Whether [e] may be a char, read off its form without checking it: a name + bound to one, a (char n), a function returning one, or [+]/[-] over any + of those. What decides whether a [+] or [-] is checked as char + arithmetic before the want of its site reaches its operands. A char + literal is not on the list: beside a number it is that number. *) +and maybe_char ctx (e : Ast.expr) = + match e.Ast.e with + | Ast.Var n -> + (match lookup ctx n with + | Some b -> b.bty = Types.Char + | None -> + match peek_outer ctx n with + | Some b -> b.bty = Types.Char + | None -> + (match Hashtbl.find_opt ctx.env.globals n with + | Some (t, _) -> t = Types.Char + | None -> false)) + | Ast.Call ({ Ast.e = Ast.Var "char"; _ }, [ _ ]) -> true + | Ast.Call ({ Ast.e = Ast.Var ("+" | "-"); _ }, args) -> + List.exists (maybe_char ctx) args + | Ast.Call ({ Ast.e = Ast.Var f; _ }, _) -> + (match Hashtbl.find_opt ctx.env.fns f with + | Some (_, r) -> r = Types.Char + | None -> false) + | _ -> false + (* ── A conversion whose operand is a type variable ───────────────────── [(i32 x)] where [x] is a [$t]. The concrete question — is this a number — has no answer during the abstract pass, and asking it anyway is what @@ -11347,30 +11386,61 @@ and fold_left_prim ctx ~want loc name p ~needs ok what args = match args with x :: y :: rest -> x, y, rest | _ -> assert false in let charish = String.equal name "+" || String.equal name "-" in + let nwant = numeric_want want in + (* A char literal is a char here, not the number, when no number is + wanted; one that may be a char by its form keeps the want off the pair, + which a char minus a char answers at the want's width itself. *) + let int_lit (e : Ast.expr) = match e.Ast.e with Ast.Int _ -> true | _ -> false in + (* A char literal later in the chain is a char only while everything + before it is an integer literal too; beside a typed number it is that + number, as in (+ b c \0) over bytes. *) + let untyped = ref (int_lit x && int_lit y) in + let char_lit (e : Ast.expr) = + match e.Ast.e with Ast.Byte _ -> nwant = None && !untyped | _ -> false + in let a, b = try - (* An integer literal then a char literal, where no number is wanted: - char arithmetic, which the join would read the other way round. *) - (match x.Ast.e, y.Ast.e, numeric_want want with - | Ast.Int _, Ast.Byte _, None when charish -> + (match x.Ast.e, y.Ast.e with + | Ast.Int _, Ast.Byte _ when charish && nwant = None -> raise_notrace (Char_pair (check ctx x, check ctx y)) | _ -> ()); + let pwant = if charish && (maybe_char ctx x || maybe_char ctx y) then None else nwant in char_operands ctx ~charish name [ x; y ] (fun () -> - binary ctx ~dyn_ok:true ~char_ok:charish name loc - ~want:(numeric_want want) [ x; y ]) + binary ctx ~dyn_ok:true ~char_ok:charish name loc ~want:pwant [ x; y ]) with Char_pair (a, b) -> a, b in (* One dyn operand makes the whole fold dyn, whichever side it is on. The typed side is boxed by [dyn_fold]; a literal was already built at dyn by [binary], so [(+ x 1)] over a dyn x folds an i64 one. *) - if charish && (a.Tast.ty = Types.Char || b.Tast.ty = Types.Char) - && a.Tast.ty <> Types.Dyn && b.Tast.ty <> Types.Dyn then - let acc = - List.fold_left - (fun acc arg -> char_step ctx loc name acc (check ctx arg)) - (char_step ctx loc name a b) rest + let is_char (e : Tast.expr) = e.Tast.ty = Types.Char in + if charish && a.Tast.ty <> Types.Dyn && b.Tast.ty <> Types.Dyn + && (is_char a || is_char b + || List.exists (maybe_char ctx) rest + || (let rec any = function + | [] -> false + | r :: tl -> char_lit r || (untyped := !untyped && int_lit r; any tl) + in + let was = !untyped in + let r = any rest in + untyped := was; r)) then + (* Left to right, each step char arithmetic when a char is in it and the + ordinary join when none is: (- \z \a 1) is 25 - 1, and (+ 1 2 \a) is + 3 + \a. *) + let step acc (arg : Ast.expr) = + let lit = char_lit arg in + untyped := !untyped && int_lit arg; + if is_char acc || maybe_char ctx arg || lit then + let v = check ctx arg in + if is_char acc || is_char v then char_step ~want:nwant loc name acc v + else mk loc acc.Tast.ty (Tast.Prim (p, [ acc; expect ctx arg.Ast.loc ~want:(Some acc.Tast.ty) v ])) + else + mk loc acc.Tast.ty (Tast.Prim (p, [ acc; check ctx ~want:acc.Tast.ty arg ])) in - expect ctx loc ~want acc + let first = + if is_char a || is_char b then char_step ~want:nwant loc name a b + else mk loc a.Tast.ty (Tast.Prim (p, [ a; b ])) + in + expect ctx loc ~want (List.fold_left step first rest) else if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then dyn_fold ctx ~want loc name [ a; b ] rest else begin @@ -12853,6 +12923,12 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Ast.Float v, _ -> check ctx ?want { Ast.e = Ast.Float (-.v); loc } | _ -> let v = check ctx ?want:(numeric_want want) x in + if v.Tast.ty = Types.Char then + Loc.failk "check/char-arithmetic" x.Ast.loc + "- does not negate a char. Take its code point with %s, and make a \ + char of one with %s" + (if fln_source loc then "i32(c)" else "(i32 c)") + (if fln_source loc then "char(n)" else "(char n)"); if v.Tast.ty = Types.Dyn then expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_neg" [ v; here loc ]) else begin diff --git a/lib/emit.ml b/lib/emit.ml index e156bf39..5d732f9c 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -5148,6 +5148,7 @@ declare i64 @flan_dyn_int_of(i64) declare i32 @flan_dyn_need_char(i64, ptr, i64) declare i32 @flan_char_of(i64, ptr, i64) declare i32 @flan_char_of_u64(i64, ptr, i64) +declare i32 @flan_char_step_u64(i32, i64, i32, ptr, i64) ; A numeric cast written on a dyn answers which numeric tag the box holds; ; check.ml's [cast_dyn] branches on it and each arm is an ordinary need plus ; the ordinary cast. The two slices are the site's location and the target's diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 680edde3..45f1b79c 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -2994,6 +2994,21 @@ uint32_t flan_char_of_u64(uint64_t n, const uint8_t *loc, int64_t loclen) { rt_trap((const uint8_t *)"InvalidChar", 11); } +/* A char plus or minus a u64 ([sub] 1 for minus), taken unsigned so no u64 + * past the largest i64 wraps round to a char. */ +uint32_t flan_char_step_u64(int32_t cp, uint64_t n, int32_t sub, + const uint8_t *loc, int64_t loclen) { + uint64_t r; + if (sub ? n > (uint64_t)cp : n > 0x10ffff) { + flan_say(loc, loclen, "%lld %s %llu is %s, so it is not a char", + (long long)cp, sub ? "minus" : "plus", (unsigned long long)n, + sub ? "below zero" : "past 0x10FFFF"); + rt_trap((const uint8_t *)"InvalidChar", 11); + } + r = sub ? (uint64_t)cp - n : (uint64_t)cp + n; + return flan_char_of_u64(r, loc, loclen); +} + /* [n] elements from [src] onto the end of a Vec, growing it once. [src] may * point into the Vec's own block — (append s (str s)) — so where it lies is * found before the grow and read again after it: the grow frees the old diff --git a/test/programs/char-arith.flan b/test/programs/char-arith.flan index 815f77f3..a37e1f4a 100644 --- a/test/programs/char-arith.flan +++ b/test/programs/char-arith.flan @@ -2,12 +2,21 @@ ;;;; integer is a char, an integer plus a char is too, and a char minus a char ;;;; is the distance, an i32. Dyn chars do the same. Byte code beside it is ;;;; unchanged. With "past" a char past U+10FFFF traps, with "surrogate" one -;;;; landing on a surrogate does, and with "dyn" a dyn char below zero does. +;;;; landing on a surrogate does, with "dyn" a dyn char below zero does, and +;;;; with "u64" a char plus the largest u64 does rather than wrapping round. (defn show [x] () (println x)) (defn add [a b] dyn (+ a b)) (defn sub [a b] dyn (- a b)) (defn upper [c char] char (if (and (>= c \a) (<= c \z)) (- c 32) c)) +;; A char minus a char where an integer is wanted is that integer. +(defn digit [c char] i32 (- c \0)) +(defn gap [a char b char] u8 (- a b)) +(defn gaps [a char b char] i32 + (let [v (vec-new i32)] + (push v (- a b)) + (+ (- a b) (at v 0) 1))) +(defn plus-u64 [c char n u64] char (+ c n)) (defn main [args [str]] i32 ;; The fork case with arithmetic: a let-bound char stays a char. @@ -19,6 +28,9 @@ n 3] (println (+ c n) (+ n c) (- c n) (- c \a) (- \a \A) (+ \a 1 1))) (println (upper \q) (upper \Q) (upper \é)) + (println (digit \7) (gap \c \a) (gaps \c \a) (plus-u64 \a (u64 2))) + ;; Longer chains fold left, each step by its own operands. + (println (- \z \a 1) (+ 1 2 \a) (- \z 1 \a)) ;; += and -= on a char local. (let [c \a] (set c (+ c 2)) @@ -38,6 +50,8 @@ (println (+ (char 0x10FFFF) (- k 1))) (= (at args 1) "surrogate") (println (+ (char 0xD7FF) (- k 1))) + (= (at args 1) "u64") + (println (plus-u64 \a (- (u64 0) (u64 (- k 1))))) :else (println (sub \a (* k 100)))))) 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 0c364e20..ea95a277 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5603,7 +5603,7 @@ level "1" with arithmetic, and a byte beside it; then a char past U+10FFFF, one on a surrogate, and a dyn one below zero, each trapping at its form. *) let char_arith_out = - "a\nb\ng g a 3 32 c\nQ Q é\nb\nb b y 32 z\n97 true\n" + "a\nb\ng g a 3 32 c\nQ Q é\n7 2 5 c\n24 d 24\nb\nb b y 32 z\n97 true\n" in outputs "char: arithmetic" "programs/char-arith.flan" char_arith_out; outputs ~opt:"-O0" "char: arithmetic, -O0" "programs/char-arith.flan" @@ -5623,11 +5623,14 @@ level "1" %d)\n wanted: %S (exit 134)\n" arg (if x86 then ", --x86" else "") text code want end) - [ ("past", "programs/char-arith.flan:38:18: 1114112 is not a \ + [ ("past", "programs/char-arith.flan:50:18: 1114112 is not a \ Unicode scalar value, so it is not a char"); - ("surrogate", "programs/char-arith.flan:40:18: 55296 is not a \ + ("surrogate", "programs/char-arith.flan:52:18: 55296 is not a \ Unicode scalar value, so it is not a char"); - ("dyn", "programs/char-arith.flan:9:21: dyn -: -103 is not a \ + ("u64", "programs/char-arith.flan:19:36: 97 plus \ + 18446744073709551615 is past 0x10FFFF, so it is not a \ + char"); + ("dyn", "programs/char-arith.flan:10:21: dyn -: -103 is not a \ Unicode scalar value, so it is not a char") ]) [ false; true ]; (* A String, and a str made from one, cross into dyn as text measured diff --git a/test/test_flan.ml b/test/test_flan.ml index 74ac68fb..2e8d3f8b 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3251,7 +3251,13 @@ let () = "(defn f [] char (- \\a 200))" ~needle:"this is -103, which is not a Unicode scalar value"; rejects_check "nor negated" - "(defn f [c char] char (- c))" ~needle:"- takes an integer or a char"; + "(defn f [c char] char (- c))" ~needle:"- does not negate a char"; + accepts "a char minus a char where an i32 is wanted" + "(defn f [c char] i32 (- c \\0))"; + accepts "a char minus a char where a u8 is wanted" + "(defn f [a char b char] u8 (- a b))"; + accepts "a char distance in arithmetic" + "(defn f [a char b char] i32 (+ (- a b) 1))"; rejects_check "nor bitwise" "(defn f [c char] char (bit-and c c))" ~needle:"bit-and does no arithmetic on a char";