From d138155eae82e1778484207fefcdce7c9dffcf5e Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 16:08:08 +0700 Subject: [PATCH] A dyn operand anywhere in an arithmetic, bitwise or comparison fold makes the fold dyn from there on, and min or max refuses one past its first pair as it does in it. --- TODO.org | 3 - lib/check.ml | 93 +++++++++++++++++++--------- test/programs/dyn-fold-position.flan | 33 ++++++++++ test/test_acceptance.ml | 13 ++++ test/test_flan.ml | 9 +++ 5 files changed, 120 insertions(+), 31 deletions(-) create mode 100644 test/programs/dyn-fold-position.flan diff --git a/TODO.org b/TODO.org index 01421891..6f5d96bb 100644 --- a/TODO.org +++ b/TODO.org @@ -787,9 +787,6 @@ One spelling for one operation; != stays, and not= is refused with a suggestion of !=. * Checker -** TODO A dyn operand past the second in a + fold is converted to the running type -=(+ 1 2 d)= with d a dyn char prints 100: the dyn is unboxed to i32 before adding, where -rule 117 says typed beside dyn gives dyn (=(+ 3 d)= gives =\d=). Predates the char lane. ** WAIT Checking a wide fold of let operands is slow Parked 2026-09-26: design first; remeasure on a quiet machine, it was timed under load 20. A 2000-operand (bit-and (let …) …) takes 32 s to check (37 s before the bit operators); diff --git a/lib/check.ml b/lib/check.ml index 5dacae87..6331cba6 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -11427,21 +11427,30 @@ and fold_left_prim ctx ~want loc name p ~needs ok what args = (* 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 ])) + let rec steps acc = function + | [] -> expect ctx loc ~want acc + | (arg : Ast.expr) :: tl -> + 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 v.Tast.ty = Types.Dyn then dyn_fold ctx ~want loc name [ acc; v ] tl + else if is_char acc || is_char v then + steps (char_step ~want:nwant loc name acc v) tl + else + match fold_operand ctx acc.Tast.ty (expect ctx arg.Ast.loc ~want:(Some acc.Tast.ty) v) with + | `Typed v -> steps (mk loc acc.Tast.ty (Tast.Prim (p, [ acc; v ]))) tl + | `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl + else + match fold_operand ctx acc.Tast.ty (check ctx ~want:acc.Tast.ty arg) with + | `Typed v -> steps (mk loc acc.Tast.ty (Tast.Prim (p, [ acc; v ]))) tl + | `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl in 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) + steps 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 @@ -11457,16 +11466,27 @@ and fold_left_prim ctx ~want loc name p ~needs ok what args = answered again, per copy, at the instantiation. *) if not (ok a.Tast.ty || generic_ty a.Tast.ty) then not_numeric name what a; let ty = a.Tast.ty in - let acc = - List.fold_left - (fun acc arg -> - mk loc ty (Tast.Prim (p, [ acc; check ctx ~want:ty arg ]))) - (mk loc ty (Tast.Prim (p, [ a; b ]))) - rest + let rec steps acc = function + | [] -> expect ctx loc ~want acc + | arg :: tl -> + match fold_operand ctx ty (check ctx ~want:ty arg) with + | `Typed v -> steps (mk loc ty (Tast.Prim (p, [ acc; v ]))) tl + | `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl in - expect ctx loc ~want acc + steps (mk loc ty (Tast.Prim (p, [ a; b ]))) rest end +(* An operand past a fold's first pair, checked at the type so far. A dyn one + is taken back as the dyn it was, not opened at that type: a typed operand + beside a dyn gives dyn (rule 117), so from there on the fold is the dyn + runtime's, and (+ 1 2 d) is (+ 3 d). *) +and fold_operand ctx ty (v : Tast.expr) = + if v.Tast.ty = Types.Dyn && not (Types.equal ty Types.Dyn) then `Dyn v + else + match opened_dyn ~box:(to_dyn ctx) v with + | Some d -> `Dyn d + | None -> `Typed v + (* A pair an arithmetic operator refused, when one operand is a char: that is the refusal to give, rather than the mismatch between the two. Asked only after the refusal, so a pair that checks costs nothing more. *) @@ -13026,7 +13046,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = two things being unalike is the answer to "are these equal", not an error. The orderings do trap, and rightly — there is no true answer to whether a string is less than a vector. *) - if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then begin + (* [ops] are every operand, boxed. *) + let dyn_chain ops = let sym = match name with | "=" | "!=" -> "flan_dyn_eq" @@ -13053,15 +13074,15 @@ and named_call ?(qualified = false) ctx ~want loc name args = let r = match rest with | [] -> link (box loc a) (box loc b) - | _ -> - let ops = - box loc a :: box loc b - :: map_lr (fun e -> box loc (check ctx ~want:Types.Dyn e)) rest - in - cmp_over ctx loc Types.Dyn ~pairs ~link ops + | _ -> cmp_over ctx loc Types.Dyn ~pairs ~link (ops ()) in expect ctx loc ~want r - end else begin + in + if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then + dyn_chain (fun () -> + box loc a :: box loc b + :: map_lr (fun e -> box loc (check ctx ~want:Types.Dyn e)) rest) + else begin (* [=] and [!=] admit types [<] does not. A handle is one: a pair of numbers in one word and where being the same entity is the question the type exists to answer — ordering handles would order a slot index, @@ -13096,8 +13117,18 @@ and named_call ?(qualified = false) ctx ~want loc name args = | _ -> let ty = a.Tast.ty in let link u v = mk loc Types.Bool (Tast.Prim (p, [ u; v ])) in - let ops = a :: b :: map_lr (fun e -> check ctx ~want:ty e) rest in - expect ctx loc ~want (cmp_over ctx loc ty ~pairs ~link ops) + let rest = map_lr (fun e -> fold_operand ctx ty (check ctx ~want:ty e)) rest in + (* A dyn past the first pair makes the whole chain the dyn runtime's, + for [fold_operand]'s reason: a chain is its pairs, and a pair with a + dyn in it is a dyn comparison. *) + if List.exists (function `Dyn _ -> true | `Typed _ -> false) rest then + dyn_chain (fun () -> + box loc a :: box loc b + :: List.map (function `Dyn d -> d | `Typed v -> box loc v) rest) + else + let ops = + a :: b :: List.map (function `Typed v -> v | `Dyn d -> d) rest in + expect ctx loc ~want (cmp_over ctx loc ty ~pairs ~link ops) end | "not" -> arity ctx loc name 1 args; @@ -13236,7 +13267,13 @@ and named_call ?(qualified = false) ctx ~want loc name args = [ mk loc ty (Tast.If (test, la, lb)) ])) in expect ctx loc ~want - (List.fold_left (fun acc arg -> pick acc (check ctx ~want:ty arg)) + (List.fold_left + (fun acc arg -> + (* A dyn is refused here as it is in the first pair, rather than + opened at the type so far. *) + match fold_operand ctx ty (check ctx ~want:ty arg) with + | `Typed v -> pick acc v + | `Dyn d -> not_numeric name "numbers" d; acc) (pick a b) rest) (* A type handed to the prelude's slice reductions: the reach for the type-limit constants under the name of the reduction beside them. *) diff --git a/test/programs/dyn-fold-position.flan b/test/programs/dyn-fold-position.flan new file mode 100644 index 00000000..e3e80b7f --- /dev/null +++ b/test/programs/dyn-fold-position.flan @@ -0,0 +1,33 @@ +;;;; A dyn operand anywhere in a fold makes the fold dyn from there on: the +;;;; typed operands before it are folded typed, and the dyn runtime takes the +;;;; rest. (+ 1 2 d) is (+ 3 d), whichever position the dyn is in. + +(defn as-i32 [x i32] i32 x) +(defn as-f64 [x f64] f64 x) + +(defn main [] i32 + (let [d (the dyn \a) + f (the dyn 2.5) + n (the dyn 4) + c \a] + ;; + and - over a dyn char: first, middle, last. + (println (+ d 1 2) (+ 1 d 2) (+ 1 2 d)) + (println (- d 1 2) (- 10 n 1) (- 10 1 n)) + ;; A dyn float past an integer pair promotes, as (* 6 f) does. + (println (* f 2 3) (* 2 f 3) (* 2 3 f)) + (println (/ f 2 5) (/ 9 f 2) (/ 9 2 f)) + (println (+ 1 2 3 f) (- 10 1 2 f)) + ;; A char fold with a dyn past the pair. + (println (+ c 1 n) (- c 1 n) (+ c 1 2 n)) + ;; The bitwise folds. + (println (bit-or n 1 2) (bit-or 1 n 2) (bit-or 1 2 n)) + (println (bit-and n 7 6) (bit-and 7 n 6) (bit-and 7 6 n)) + (println (bit-xor n 1 2) (bit-xor 1 n 2) (bit-xor 1 2 n)) + ;; Comparison chains: a float past an integer pair is compared as one. + (println (< f 3 4) (< 1 f 3) (< 1 2 f) (< 1 3 f)) + (println (<= 2 2 f) (> 3 2 f) (>= 3 3 f) (>= 3 3 n)) + (println (= 4 4 n) (= 4 n 4) (= n 4 4) (= 4 4 f)) + (println (!= 1 2 n) (!= 1 4 n) (!= 2 f 3)) + ;; At a typed want the dyn answer is opened at the end. + (println (as-i32 (+ 1 2 n)) (as-f64 (* 2 3 f)))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index f05d9a78..522e9ae8 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5610,6 +5610,19 @@ level "1" char_arith_out; outputs ~x86:true "char: arithmetic, --x86" "programs/char-arith.flan" char_arith_out; + (* A dyn anywhere in a fold makes it dyn from there on (rule 117): each + family with the dyn first, in the middle and last. *) + let fold_out = + "d d d\n^ 5 5\n15 15 15\n0.25 1.8 1.6\n8.5 4.5\nf \\ h\n7 7 7\n\ + 4 4 4\n7 7 7\ntrue true true false\ntrue false true false\n\ + true true true false\ntrue false true\n7 15\n" + in + outputs "dyn: a dyn in any fold position" "programs/dyn-fold-position.flan" + fold_out; + outputs ~opt:"-O0" "dyn: a dyn in any fold position, -O0" + "programs/dyn-fold-position.flan" fold_out; + outputs ~x86:true "dyn: a dyn in any fold position, --x86" + "programs/dyn-fold-position.flan" fold_out; List.iter (fun x86 -> let exe = compile ~x86 "programs/char-arith.flan" in diff --git a/test/test_flan.ml b/test/test_flan.ml index 2e8d3f8b..60ede47d 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -8450,5 +8450,14 @@ let () = "(defn f [n i32] (Option i32) (cond (= n 1) 10 (= n 2) 20))\n(defn main [] ())"; rejects_check "a map's get takes one key" ~needle:"a map's get takes one key" "(defn main [] () (let [m (map-new i32 i32)] (println (get m 1 2))))"; + (* min and max have no dyn lowering: a dyn past the first pair is refused + as one in it is, not opened at the type so far. *) + List.iter + (fun op -> + rejects_check (op ^ " refuses a dyn past its first pair") + ~needle:(op ^ " takes numbers, found dyn") + (Printf.sprintf + "(defn main [] () (let [f (the dyn 2.5)] (println (%s 3 4 f))))" op)) + [ "min"; "max" ]; Test_support.report ()