From 0b9ae9318e2f1eca33d9908da4a92b9ed0fc1780 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:26:13 +0700 Subject: [PATCH 01/16] flan build and flan run of a file with no main say so and show one, rather than failing at the link --- bin/main.ml | 4 ++++ lib/build.ml | 16 ++++++++++++++++ lib/dev.ml | 13 ++----------- test/test_acceptance.ml | 12 ++++++++++++ 4 files changed, 34 insertions(+), 11 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index f4564016..f15d5066 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -736,6 +736,8 @@ let () = if List.mem warn_memory_flag rest then print_memory_warnings ~file:path p) in + Flan.Build.need_main ~file:path ~doing:"flan build has nothing to link" + f.program; ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks; dev; debug; sanitize; target; x86; @@ -915,6 +917,8 @@ let () = (Printf.sprintf "flan-run-%d" (Unix.getpid ())) in let f = Flan.Front.linked ~all:true path in + Flan.Build.need_main ~file:path ~doing:"flan run has nothing to run" + f.program; ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks; debug; sanitize; x86; diff --git a/lib/build.ml b/lib/build.ml index 899310d2..70e94449 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -744,6 +744,22 @@ let compile_c ~opts ?tflags ?(warn = []) ~src ~name () = end; obj +(* A program with no [main] builds every function and then fails at the link, + as an undefined reference from the C startup code — a message about crt1.o + for a mistake in the .flan file. Asked here, by the commands that make an + executable, rather than inside [executable], whose callers include hosts + and tests that supply their own [main]. *) +let need_main ~file ~doing (p : Tast.program) = + if not (List.exists (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns) + then + failwith + (Printf.sprintf + "%s has no main, so %s. A program starts at a function named main, \ + for example:\n\n\ + \ (defn main [] i32\n\ + \ 0)" + file doing) + (* [csrcs] and [lflags] come from the imported packages (see [Load]): the C shim a package binds through, and the arguments needed to link the library it binds to. diff --git a/lib/dev.ml b/lib/dev.ml index d83191d7..44fd3fa4 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -4520,17 +4520,8 @@ let make_session_dir ~file dir = would find that out at the link — as a missing symbol, or as the merged build's rename finding nothing to rename. *) let need_main ~file (session : Session.t) = - if not - (List.exists (fun (f : Tast.fn) -> f.Tast.name = "main") - session.Session.host.Tast.fns) - then - failwith - (Printf.sprintf - "%s has no main, so flan dev has nothing to run. A program starts at \ - a function named main, for example:\n\n\ - \ (defn main [] i32\n\ - \ 0)" - file) + Build.need_main ~file ~doing:"flan dev has nothing to run" + session.Session.host (* [debug] is off by default, which keeps [flan dev] exactly what it was: a -O2 host and -O2 modules. It is opt-in rather than always-on because a debug diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 6ced8956..cbb7a993 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -6472,6 +6472,18 @@ level "1" cli_case "--debug and an explicit -O are refused together" "build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2 ~says:[ "--debug"; "-O2"; "Drop one of the two" ]; + (* A file with no main is refused by name before the link, which would + otherwise report an undefined reference from crt1.o. *) + let nomain = Filename.concat scratch "no-main.flan" in + Out_channel.with_open_bin nomain (fun oc -> + output_string oc "(defn f [] i32 0)\n"); + cli_case "build of a file with no main names main" + (Printf.sprintf "build %s -o /dev/null" (Filename.quote nomain)) ~code:1 + ~says:[ "has no main"; "(defn main [] i32" ]; + cli_case "run of a file with no main names main" + (Printf.sprintf "run %s" (Filename.quote nomain)) ~code:1 + ~says:[ "has no main"; "(defn main [] i32" ]; + Sys.remove nomain; (* Every row above that went through the pool has been forked; nothing after this point may look at [failures] until every one of them has From 14bac84f536adc850e6392637f20bbfeb17c6a09 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:27:49 +0700 Subject: [PATCH 02/16] != over floats is unordered, so a NaN is unequal to itself on both backends as it already was on the dyn side --- TODO.org | 6 ------ lib/check.ml | 3 ++- lib/emit.ml | 5 ++++- lib/x86.ml | 22 +++++++++++++++------- test/programs/limits.flan | 13 +++++++++++++ test/test_acceptance.ml | 4 +++- 6 files changed, 37 insertions(+), 16 deletions(-) diff --git a/TODO.org b/TODO.org index 081c65c5..fb114628 100644 --- a/TODO.org +++ b/TODO.org @@ -146,12 +146,6 @@ missed, so a program's own binding of one wins. Negative infinity is =(- 0.0 f64-inf)=: the decision wrote =(- f64-inf)=, and there is no unary minus. Rules out Clojure's =##Inf= reader literal. -** TODO (!= x x) is false for a NaN -=!== on floats is LLVM's ordered =one= on both backends (=lib/emit.ml= =fcmp_op=, -=lib/x86.ml= =float_cc=), so =(!= f64-nan f64-nan)= is =false= where C, Odin and -IEEE 754 say =true=; =(not (= x x))= is the only NaN test that works. Changing it -to =une= is a decision about what =!== means. - ** DONE A u64 constant above 2^63 cannot be written in decimal CLOSED: [2026-09-25] An integer written at or above 2^63 — a decimal up to 2^64 - 1, or hex with the diff --git a/lib/check.ml b/lib/check.ml index e5106991..6d06c7cd 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -10064,7 +10064,8 @@ let builtins : (string * string * string) list = ordered."); ("!=", "!= [equal? ...] bool", "All different: (!= a b c) is true when every operand differs from every \ - other, so (!= 1 2 1) is false. Over everything = accepts."); + other, so (!= 1 2 1) is false. Over everything = accepts. A float NaN \ + is != to everything, itself included."); ("<", "< [ordered? ...] bool", "Less than, chained: (< a b c) is a < b and b < c, and every operand is \ evaluated once. Machine numbers and enums only — ordering a handle \ diff --git a/lib/emit.ml b/lib/emit.ml index 800e4a71..f2d40eb2 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -1966,8 +1966,11 @@ let icmp_op signed = function | Tast.Ge -> if signed then "sge" else "uge" | _ -> assert false +(* [!=] is unordered and the rest are ordered, so a NaN is unequal to + everything, itself included, and neither less, greater nor equal: IEEE 754's + answers, and C's and Odin's. *) let fcmp_op = function - | Tast.Eq -> "oeq" | Tast.Ne -> "one" | Tast.Lt -> "olt" + | Tast.Eq -> "oeq" | Tast.Ne -> "une" | Tast.Lt -> "olt" | Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge" | _ -> assert false diff --git a/lib/x86.ml b/lib/x86.ml index 9d6f15a3..6b353da0 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -1317,18 +1317,20 @@ let int_cc ~signed (p : Tast.prim) = (* Parity, which on [ucomis] means "unordered": one of the operands was a NaN. Nothing else in this file reads it. *) -let cc_np = 11 +let cc_p = 10 and cc_np = 11 (* [ucomis] sets the flags the *unsigned* codes read, whichever way the operands are signed, so a float comparison never uses l/g — and it sets CF, ZF and PF all at once when either operand is a NaN. That last part is why this is not simply the unsigned table. Every - comparison Flan has is LLVM's *ordered* one ([emit.ml]'s [fcmp_op]: oeq, - one, olt, ...), which answers false for a NaN, and [setb] after an - unordered compare answers true. So [<] and [<=] swap their operands and ask - for a/ae, which are the two codes a NaN makes false; [=] and [!=] cannot be - spelled by one code at all and take a second [setnp] beside them. + comparison Flan has but one is LLVM's *ordered* one ([emit.ml]'s + [fcmp_op]: oeq, olt, ...), which answers false for a NaN, and [setb] after + an unordered compare answers true. So [<] and [<=] swap their operands and + ask for a/ae, which are the two codes a NaN makes false; [=] cannot be + spelled by one code at all and takes a second [setnp] beside it. The one is + [!=], which is [une] — true for a NaN, as IEEE 754 and C have it — and is + [setne] or'd with [setp]. [(not (= x x))] is how [format-f64] in the prelude detects a NaN, and it is the whole of the difference: with [sete] alone, [(/ 0.0 0.0)] formatted as @@ -1344,7 +1346,7 @@ let float_cc (p : Tast.prim) = | _ -> unsupported "not a comparison" let float_ordered (p : Tast.prim) = - match p with Tast.Eq | Tast.Ne -> true | _ -> false + match p with Tast.Eq -> true | _ -> false let is_cmp (p : Tast.prim) = match p with @@ -3179,6 +3181,12 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst = movzx8 f.b ~dst:rcx ~src:rcx; and_rr f.b ~dst:rax ~src:rcx end + else if p = Tast.Ne then begin + movzx8 f.b ~dst:rax ~src:rax; + setcc f.b ~cc:cc_p ~dst:rcx; + movzx8 f.b ~dst:rcx ~src:rcx; + or_rr f.b ~dst:rax ~src:rcx + end end else begin load_loc f ~reg:rax la a.Tast.ty; load_loc f ~reg:rcx lb b.Tast.ty; diff --git a/test/programs/limits.flan b/test/programs/limits.flan index bd284465..c38bdb4e 100644 --- a/test/programs/limits.flan +++ b/test/programs/limits.flan @@ -60,6 +60,10 @@ (print " ") (println (if ok "ok" "WRONG"))) +(defn ne-f64 [a f64 b f64] bool (!= a b)) +(defn ne-f32 [a f32 b f32] bool (!= a b)) +(defn ne-dyn [a dyn b dyn] bool (!= a b)) + (defn main [] i32 ;; The integers, each printed as the exact decimal the expected output pins. (println i8-max) @@ -128,4 +132,13 @@ (say "f32-inf negated" (< (- (f32 0.0) f32-inf) (- (f32 0.0) f32-max))) (say "f64-nan" (not (= f64-nan f64-nan))) (say "f32-nan" (not (= f32-nan f32-nan))) + ;; != is the one unordered comparison: a NaN is unequal to everything, + ;; itself included, and the dyn side agrees. The operands arrive as + ;; parameters so that no constant folder answers in the backend's place. + (say "f64-nan != itself" (ne-f64 f64-nan f64-nan)) + (say "f32-nan != itself" (ne-f32 f32-nan f32-nan)) + (say "!= over ordinary floats" + (and (ne-f64 1.0 2.0) (not (ne-f64 1.5 1.5)) + (ne-f32 (f32 1.0) (f32 2.0)) (not (ne-f32 (f32 1.5) (f32 1.5))))) + (say "a dyn NaN != itself" (ne-dyn f64-nan f64-nan)) 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index cbb7a993..a88787ea 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5440,7 +5440,9 @@ level "1" f32's least value negates its greatest ok\n\ f64's least value negates its greatest ok\n\ f64-inf ok\nf32-inf ok\nf64-inf negated ok\nf32-inf negated ok\n\ - f64-nan ok\nf32-nan ok\n" + f64-nan ok\nf32-nan ok\n\ + f64-nan != itself ok\nf32-nan != itself ok\n\ + != over ordinary floats ok\na dyn NaN != itself ok\n" in outputs "type limits" "programs/limits.flan" limits_out; outputs ~opt:"-O0" "type limits, -O0" "programs/limits.flan" limits_out; From 315125c677301191ccf9c125bd3000165714e1fb Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:32:54 +0700 Subject: [PATCH 03/16] A literal arm of an if, a cond or a match takes its type from the arms that are not literals --- lib/check.ml | 55 +++++++++++++++++++++++++++++----- test/programs/literal-arm.flan | 18 +++++++++++ test/test_acceptance.ml | 7 +++++ 3 files changed, 72 insertions(+), 8 deletions(-) create mode 100644 test/programs/literal-arm.flan diff --git a/lib/check.ml b/lib/check.ml index 6d06c7cd..278c614c 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -1991,6 +1991,12 @@ let mk loc ty e : Tast.expr = { Tast.e; ty; loc } let unit_at loc = mk loc Types.Unit Tast.Unit +(* The compiler temp an [and] leaves in its else arm; see [check_if]. *) +let and_sentinel (x : Ast.expr) = + match x.Ast.e with + | Ast.Var n -> String.length n > 4 && String.sub n 0 4 = "and~" + | _ -> false + (* Integer arithmetic over literals alone, folded. Unlike [const_int] no name is read: a defconst has a type of its own, and only an untyped constant may stand at a type variable. *) @@ -2015,6 +2021,10 @@ let rec literal_arith (e : Ast.expr) : int64 option = (literal_arith x) (y :: rest) | _ -> None +(* A value with no type until one is asked of it: a literal, or arithmetic + over literals alone. *) +let lone_literal (e : Ast.expr) = is_literal e || literal_arith e <> None + (* The environment for a lifted body, built once its own body has been checked and [caught] is therefore final. spec-memory.md's case 2, and the whole of @@ -5102,6 +5112,16 @@ and check_if ctx ?(tail = false) ?want loc c t e = no value on the missing side. `when` desugars to this. *) let t = branch ctx (fun () -> in_tail (fun () -> check ctx t)) in expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc))) + | Some e when want = None && lone_literal t && not (lone_literal e) + && not (and_sentinel e) -> + (* A literal has no type of its own until something asks, so with no + expectation the other arm decides: [(if c 4000000 n)] over an i64 [n] + is an i64, as [(+ 4000000 n)] is. *) + let e = branch ctx (fun () -> in_tail (fun () -> check ctx e)) in + let twant = if e.Tast.ty = Types.Never then None else Some e.Tast.ty in + let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:twant t)) in + let ty = if e.Tast.ty = Types.Never then t.Tast.ty else e.Tast.ty in + mk loc ty (Tast.If (c, t, e)) | Some e -> let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in (* With no expectation the then-branch supplies one for the else-branch, @@ -5125,12 +5145,6 @@ and check_if ctx ?(tail = false) ?want loc c t e = sentinel in the then arm, so every operand is already blamed at its own location; and with an expectation in hand both arms are checked against it rather than against each other, so nothing here runs. *) - let and_sentinel (x : Ast.expr) = - match x.Ast.e with - | Ast.Var n -> - String.length n > 4 && String.sub n 0 4 = "and~" - | _ -> false - in let e = match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with | v -> v @@ -5840,7 +5854,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = let want = ref want in let seen = Hashtbl.create 8 in let saw_wild = ref false in - let arms = + let resolved = map_lr (fun (a : Ast.arm) -> let ctor, binds = resolve_pat a in @@ -5850,6 +5864,28 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = if Hashtbl.mem seen c then fail a.Ast.aloc "this match has two %s arms" c; Hashtbl.add seen c ()); + (a, ctor, binds)) + arms + in + (* With nothing expected of the match, the first arm's type is every arm's — + unless that arm is a bare literal, which has no type until asked. So the + arms whose value is a literal are checked last, and take their type from + the others, as an [if]'s literal arm does. The order is only the order + they are checked in; they are put back in source order below. *) + let literal_arm ((a : Ast.arm), _, _) = + match List.rev a.Ast.body with last :: _ -> lone_literal last | [] -> false + in + let order = + let idx = List.mapi (fun i r -> (i, r)) resolved in + if !want <> None then idx + else + List.filter (fun (_, r) -> not (literal_arm r)) idx + @ List.filter (fun (_, r) -> literal_arm r) idx + in + let checked = + map_lr + (fun (i, ((a : Ast.arm), ctor, binds)) -> + i, branch ctx (fun () -> (* What each name in this arm is, in words, for the one refusal that needs it: a case pattern binds fields positionally, so the @@ -5885,7 +5921,10 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = if !want = None && body.Tast.ty <> Types.Never then want := Some body.Tast.ty; { Tast.acase = ctor; binds; abody = [ body ] })) - arms + order + in + let arms = + List.map snd (List.sort (fun (i, _) (j, _) -> compare i j) checked) in (* Exhaustiveness is refused, not defaulted. A match that silently fell through would have to produce a value of the match's type out of nothing, diff --git a/test/programs/literal-arm.flan b/test/programs/literal-arm.flan new file mode 100644 index 00000000..5459e906 --- /dev/null +++ b/test/programs/literal-arm.flan @@ -0,0 +1,18 @@ +;;;; A literal arm takes its type from the arm that is not a literal, in an +;;;; if, a cond and a match alike, as a literal operand of + does. +(defn g [c bool n i64] i64 (let [x (if c 4000000 n)] x)) +(defn h [k i32 n i64] i64 + (let [x (cond (= k 0) 5000000000 (= k 1) 7 :else n)] x)) +(defn m [o (Option i64)] i64 + (let [x (match o None 3 (Some v) v)] x)) +(defn f32s [c bool y f32] f32 (let [x (if c 2.5 y)] x)) +(defn main [] i32 + (println (g true (i64 3))) + (println (g false (i64 9000000000))) + (println (h 0 (i64 1))) + (println (h 1 (i64 1))) + (println (h 2 (i64 9000000000))) + (println (m None)) + (println (m (Some (i64 9000000000)))) + (println (f32s true (f32 1.0))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index a88787ea..8466b85e 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -558,6 +558,13 @@ let () = "programs/array-first-element.flan" first_out; outputs ~x86:true "an array literal's first element types the rest, x86" "programs/array-first-element.flan" first_out; + (* A literal arm takes the other arm's type. *) + let arm_out = + "4000000\n9000000000\n5000000000\n7\n9000000000\n3\n9000000000\n2.5\n" in + outputs "a literal arm takes the other arm's type" + "programs/literal-arm.flan" arm_out; + outputs ~x86:true "a literal arm takes the other arm's type, x86" + "programs/literal-arm.flan" arm_out; (* into. The count of pulls is the assertion a unit test cannot make: one pass, one call per element per stage it reaches, and no intermediate collection anywhere. The two show lines either side of it are the same From 3cb6cebdbeffd0b703be4fd43efb49165a0a540f Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:37:56 +0700 Subject: [PATCH 04/16] (- x) negates a typed number, a type variable and a dyn, and a float's negation of zero is -0.0 --- TODO.org | 3 +-- lib/check.ml | 43 +++++++++++++++++++++++++++++---------- lib/emit.ml | 1 + lib/prelude.ml | 2 +- runtime/flan_dyn.c | 8 ++++++++ runtime/flan_dyn.h | 1 + test/programs/limits.flan | 8 ++++---- test/programs/negate.flan | 25 +++++++++++++++++++++++ test/test_acceptance.ml | 7 +++++++ test/test_flan.ml | 12 +++++++---- 10 files changed, 88 insertions(+), 22 deletions(-) create mode 100644 test/programs/negate.flan diff --git a/TODO.org b/TODO.org index fb114628..65c7ead2 100644 --- a/TODO.org +++ b/TODO.org @@ -143,8 +143,7 @@ CLOSED: [2026-09-25] =f64-inf=, =f64-nan=, =f32-inf= and =f32-nan= are names the checker supplies (=Check.special_float=), reached only after every local, global and function has missed, so a program's own binding of one wins. Negative infinity is -=(- 0.0 f64-inf)=: the decision wrote =(- f64-inf)=, and there is no unary minus. -Rules out Clojure's =##Inf= reader literal. +=(- f64-inf)=. Rules out Clojure's =##Inf= reader literal. ** DONE A u64 constant above 2^63 cannot be written in decimal CLOSED: [2026-09-25] diff --git a/lib/check.ml b/lib/check.ml index 278c614c..93edcb32 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2003,6 +2003,8 @@ let and_sentinel (x : Ast.expr) = let rec literal_arith (e : Ast.expr) : int64 option = match e.Ast.e with | Ast.Int n -> Some n + | Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ x ]) -> + Option.map Int64.neg (literal_arith x) | Ast.Call ({ Ast.e = Ast.Var op; _ }, x :: y :: rest) -> let step a b = match op with @@ -6355,12 +6357,9 @@ and arity _ctx loc name n args = Two is the floor, and the two missing cases are refused rather than invented. Zero operands would have to mean an identity element, 0 for + and 1 for *, and a sum with no terms in it is a typo far more often than it is - an intent. One operand would have to mean negation for [-] and reciprocal - for [/], and this language has no unary minus anywhere: the prelude writes - every negation as [(- 0 n)] or [(- 0.0 x)], and [(- x)] meaning something - else than the [-] two lines above it is a rule a reader has to carry rather - than see. Integer division makes the reciprocal worse still: [(/ 3)] would - be 0. + an intent. One operand is refused for every operator but [-], whose one + operand form is negation and is [named_call]'s. For [/] it would be the + reciprocal, and integer division makes that a trap: [(/ 3)] would be 0. A one-operand comparison would have to be [true] — there is no pair to disagree, and nothing for a lone value to be distinct from — and a test @@ -6369,10 +6368,6 @@ and arity _ctx loc name n args = and fold_arity loc name args = match args with | _ :: _ :: _ -> () - | [ _ ] when String.equal name "-" -> - fail loc - "- takes two arguments or more, given 1 — there is no unary minus; \ - write (- 0 x) to negate" | [ _ ] when String.equal name "/" -> fail loc "/ takes two arguments or more, given 1 — there is no reciprocal; \ @@ -7029,6 +7024,31 @@ and named_call ?(qualified = false) ctx ~want loc name args = | _ when (not qualified) && shadows_builtin ctx loc name -> ordinary_call ctx ~want loc name args (* ── arithmetic and comparison ─────────────────────────────────── *) + (* (- x) negates, Clojure's rule. A literal operand is the negative literal, + so it takes its type from the site as any literal does. A float is + subtracted from -0.0, which is exact negation — 0.0 - 0.0 would answer + +0.0 — and an integer from 0, which wraps as (- 0 x) does. *) + | "-" when List.length args = 1 -> + let x = List.hd args in + (match x.Ast.e with + | Ast.Int n when n <> Int64.min_int -> + check ctx ?want { Ast.e = Ast.Int (Int64.neg n); loc } + | 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.Dyn then + expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_neg" [ v; here loc ]) + else begin + unconstrained ctx.env loc name ~needs:"numeric?" v.Tast.ty; + if not (Types.is_numeric v.Tast.ty || generic_ty v.Tast.ty) then + not_numeric name "numbers" v; + let zero = + match v.Tast.ty with + | Types.Float k -> mk loc v.Tast.ty (Tast.Float (-0.0, k)) + | ty -> int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L + in + expect ctx loc ~want (mk loc v.Tast.ty (Tast.Prim (Tast.Sub, [ zero; v ]))) + end) | "+" | "-" | "*" | "/" -> let p = match name with | "+" -> Tast.Add | "-" -> Tast.Sub | "*" -> Tast.Mul @@ -10087,7 +10107,8 @@ let builtins : (string * string * string) list = numeric types meet at the wider one when that cannot lose — i32 and i64 \ add at i64 — and i32 with u32 has no such type and is refused."); ("-", "- [numeric? ...] numeric?", - "Difference, folded left: (- a b c) is ((a - b) - c)."); + "Difference, folded left: (- a b c) is ((a - b) - c). With one operand, \ + its negation: (- x)."); ("*", "* [numeric? ...] numeric?", "Product, folded left over two or more operands of one numeric type."); ("/", "/ [numeric? ...] numeric?", diff --git a/lib/emit.ml b/lib/emit.ml index f2d40eb2..73fe71ab 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4389,6 +4389,7 @@ declare i64 @flan_dyn_sub(i64, i64, ptr, i64) declare i64 @flan_dyn_mul(i64, i64, ptr, i64) declare i64 @flan_dyn_div(i64, i64, ptr, i64) declare i64 @flan_dyn_rem(i64, i64, ptr, i64) +declare i64 @flan_dyn_neg(i64, ptr, i64) declare i64 @flan_dyn_lt(i64, i64, ptr, i64) declare i64 @flan_dyn_le(i64, i64, ptr, i64) declare i64 @flan_dyn_gt(i64, i64, ptr, i64) diff --git a/lib/prelude.ml b/lib/prelude.ml index dee1d391..ff520d4b 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -695,7 +695,7 @@ let source = {flan| ;; The floats are three questions and not two, which is why there is no ;; f32-min here to sit beside f32-max. ;; -;; A float's least value is just the negation of its greatest — (- 0.0 f32-max) +;; A float's least value is just the negation of its greatest — (- f32-max) ;; — so a constant for it would say nothing the language cannot. What a caller ;; actually reaches for under the name "min" is the smallest positive one, and ;; that is a different number entirely. Naming it f32-min would make the two diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index c7a8c724..04a432a6 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1759,6 +1759,14 @@ flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen) { return arith(loc, loclen, "-", a, b); } +/* (- x): an int wraps, as (- 0 x) does, and a float flips its sign, so the + * negation of 0.0 is -0.0 and not the 0.0 a subtraction from zero gives. */ +flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen) { + if (!is_num(a)) trap1(loc, loclen, TYPE_TRAP, "-", "it takes a number", a); + if (flan_dyn_tag(a) == FLAN_DYN_TAG_INT) + return flan_dyn_from_i64((int64_t)(0 - (uint64_t)dyn_int_value(a))); + return flan_dyn_from_f64(-dyn_num_value(a)); +} flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen) { return arith(loc, loclen, "*", a, b); diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 889be2e7..aac34cdf 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -151,6 +151,7 @@ flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); +flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen); /* Answer a bool dyn. Numbers compare as numbers and text compares bytewise; * a mixture of the two, or anything else, traps. */ diff --git a/test/programs/limits.flan b/test/programs/limits.flan index c38bdb4e..954cc082 100644 --- a/test/programs/limits.flan +++ b/test/programs/limits.flan @@ -119,17 +119,17 @@ ;; the absence is recorded rather than merely unmentioned: a float's least ;; value is the negation of its greatest, and there is nothing to derive. (say "f32's least value negates its greatest" - (< (- (f32 0.0) f32-max) (- (f32 0.0) f32-min-positive))) + (< (- f32-max) (- f32-min-positive))) (say "f64's least value negates its greatest" - (< (- 0.0 f64-max) (- 0.0 f64-min-positive))) + (< (- f64-max) (- f64-min-positive))) ;; The infinities and NaNs, which no literal writes. Each infinity is the ;; overflow of its type's greatest value, negated it is below the least ;; finite one, and a NaN is the one value not equal to itself. (say "f64-inf" (= f64-inf (* f64-max 2.0))) (say "f32-inf" (= f32-inf (* f32-max (f32 2.0)))) - (say "f64-inf negated" (< (- 0.0 f64-inf) (- 0.0 f64-max))) - (say "f32-inf negated" (< (- (f32 0.0) f32-inf) (- (f32 0.0) f32-max))) + (say "f64-inf negated" (< (- f64-inf) (- f64-max))) + (say "f32-inf negated" (< (- f32-inf) (- f32-max))) (say "f64-nan" (not (= f64-nan f64-nan))) (say "f32-nan" (not (= f32-nan f32-nan))) ;; != is the one unordered comparison: a NaN is unequal to everything, diff --git a/test/programs/negate.flan b/test/programs/negate.flan new file mode 100644 index 00000000..51821e23 --- /dev/null +++ b/test/programs/negate.flan @@ -0,0 +1,25 @@ +;;;; (- x) negates: an integer wraps, a float flips its sign — the negation of +;;;; 0.0 is -0.0, which 1/x tells apart — and a dyn does either by its tag. +(defn negi [x i32] i32 (- x)) +(defn negf [x f64] f64 (- x)) +(defn negf32 [x f32] f32 (- x)) +(defn negu [x u8] u8 (- x)) +(defn negd [x dyn] dyn (- x)) +(defn negg [x $t] $t {:where (numeric? $t)} (- x)) +(defn main [] i32 + (println (negi 3)) + (println (negi -7)) + (println (negf 2.5)) + (println (/ 1.0 (negf 0.0))) + (println (negf32 (f32 1.5))) + (println (negu (u8 1))) + (println (negd 4)) + (println (negd 2.5)) + (println (/ 1.0 (negd 0.0))) + (println (negg (i64 9000000000))) + (println (negg 0.5)) + (let [a (- 5) b (i64 (- 3))] + (println (+ a (i32 b)))) + (println (- f64-inf)) + (println (< (- f64-inf) (- f64-max))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 8466b85e..46eae007 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -558,6 +558,13 @@ let () = "programs/array-first-element.flan" first_out; outputs ~x86:true "an array literal's first element types the rest, x86" "programs/array-first-element.flan" first_out; + (* (- x) negates, on every numeric type, a type variable and a dyn. *) + let neg_out = + "-3\n7\n-2.5\n-inf\n-1.5\n255\n-4\n-2.5\n-inf\n-9000000000\n\ + -0.5\n-8\n-inf\ntrue\n" in + outputs "unary minus" "programs/negate.flan" neg_out; + outputs ~opt:"-O0" "unary minus, -O0" "programs/negate.flan" neg_out; + outputs ~x86:true "unary minus, x86" "programs/negate.flan" neg_out; (* A literal arm takes the other arm's type. *) let arm_out = "4000000\n9000000000\n5000000000\n7\n9000000000\n3\n9000000000\n2.5\n" in diff --git a/test/test_flan.ml b/test/test_flan.ml index d7857883..f6c8cb19 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1300,14 +1300,18 @@ let () = infers "min at four" "(min 4 1 3 2)" "i32"; infers "max at four" "(max 4 1 3 2)" "i32"; (* And the two counts below the floor. Zero would have to mean an identity - element and one a unary operator this language does not have; both are a - typo far more often than an intent, so both are refused by name. *) + element, and one is refused for every operator but -, whose one-operand + form negates. *) rejects_check "a sum with no terms" "(defn f [] i32 (+))" ~needle:"+ takes two arguments or more, given 0"; rejects_check "a product with no factors" "(defn f [] i32 (*))" ~needle:"* takes two arguments or more, given 0"; - rejects_check "there is no unary minus" - "(defn f [] i32 (- 1))" ~needle:"there is no unary minus"; + infers "a negated literal" "(- 1)" "i32"; + infers "a negated literal takes its type from the site" "(i64 (- 1))" "i64"; + rejects_check "unary minus over a string names the operand" + "(defn f [s string] () (println (- s)))" ~needle:"- takes numbers"; + rejects_check "unary minus at an unsigned literal is out of range" + "(defn f [] u8 (- 1))" ~needle:"does not fit in u8"; rejects_check "there is no reciprocal" "(defn f [] f64 (/ 2.0))" ~needle:"there is no reciprocal"; rejects_check "one operand is not a bitwise and" From 2682214499b5b25ba65a956c5935bc47cc5b3ec0 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:40:08 +0700 Subject: [PATCH 05/16] A defclass slot may declare a type that every store into it checks, and set writes a declared slot --- lib/ast.ml | 19 +- lib/check.ml | 111 +++++++- lib/classes.ml | 59 +++-- lib/dev.ml | 26 +- lib/emit.ml | 5 +- lib/load.ml | 28 +- lib/parse.ml | 29 ++- lib/session.ml | 35 +-- runtime/flan_dyn.c | 400 ++++++++++++++++++++++++----- runtime/flan_dyn.h | 23 +- test/dyn_ops.c | 6 +- test/programs/dyn-class-slots.flan | 38 +++ test/programs/dyn-slot-trap.flan | 18 ++ test/test_acceptance.ml | 41 +++ test/test_flan.ml | 36 ++- test/test_session.ml | 14 + web/examples/classes.flan | 4 +- web/index.html | 18 +- 18 files changed, 744 insertions(+), 166 deletions(-) create mode 100644 test/programs/dyn-class-slots.flan create mode 100644 test/programs/dyn-slot-trap.flan diff --git a/lib/ast.ml b/lib/ast.ml index 41708a09..b40b1765 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -199,6 +199,11 @@ and place = | Pfield of expr * string (* (set (.hp e) v) *) | Pindex of expr * expr list (* (set (at grid r c) v) *) | Pderef of expr (* (set (deref p) v) *) + (* (set (get inst :slot) v) — a class instance's declared slot. A map has + no such place: an absent key has no location, and [put] is how one is + written. Which of the two a value is, is known only at run time, so + this is a runtime store that refuses a plain map. *) + | Pslot of expr * expr and arm = { pat : pattern; body : expr list; aloc : Loc.t } @@ -282,8 +287,10 @@ and decl_kind = | Defvar of string * texpr option * init * reinit | Defconst of string * texpr option * expr (* ── The dyn side's classes and generic functions ────────────────── - None of these four reaches [Check]. [Classes.expand] turns the whole set - into ordinary [Defn]s before pass one collects anything, the way [Shim] + None of these four reaches [Check]'s signature pass. [Classes.expand] + turns the generic forms into ordinary [Defn]s before pass one collects + anything, and [Check.pair_decls] turns a [Defclass] into its constructor + once its slot vector can be paired, the way [Shim] already turns a [DeclareC] into a [Declare] plus a [Defn]: a class is a constructor, and a generic function is one function whose body is a dispatch over the methods written for it. @@ -293,8 +300,11 @@ and decl_kind = anywhere in the file, or arrive at a reload long after the generic did, and a macro sees one form. *) - (* (defclass point [x y]) — the slot names, in constructor order. *) - | Defclass of string * (string * Loc.t) list + (* (defclass point [x y]) or (defclass state [pause bool step bool]) — the + slot vector, in constructor order, left unpaired for the reason a + [defn]'s is: [[x y]] is two slots or one slot [x] of type [y] depending + on whether [y] names a type. [Check.pair_decls] pairs it. *) + | Defclass of string * pitem list (* (defgeneric area [self] dyn) — CLOS's class dispatch: the dispatch value is the shape tag of the first argument. The parameter vector and the return slot are a [defn]'s, and there is no body. *) @@ -413,6 +423,7 @@ let map_children f (e : expr) : expr = | Pfield (x, n) -> Pfield (ex x, n) | Pindex (x, is) -> Pindex (ex x, List.map ex is) | Pderef x -> Pderef (ex x) + | Pslot (x, k) -> Pslot (ex x, ex k) in let kind = match e.e with diff --git a/lib/check.ml b/lib/check.ml index e5106991..279aa172 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -181,6 +181,13 @@ type env = { flag is what lets [resolve_name] say the honest thing in each place instead of a suggestion that cannot be followed. *) mutable in_field : bool; + (* Every [defclass], by name: its slots in constructor order, each with the + type a value stored in it must have — [Types.Dyn] for a slot written + with no type. Filled by [pair_decls], which is where a slot vector is + first readable. The type is a declaration about the values and not a + layout: an instance is a dyn map whatever this says, and what reads it + is [class_spec], which is what the runtime checks a store against. *) + classes : (string, (string * Types.t) list) Hashtbl.t; } let new_env () = { @@ -210,6 +217,7 @@ let new_env () = { tvpreds = []; chain = []; in_field = false; + classes = Hashtbl.create 8; } (* Where a named type was declared, and what it has, as a note. @@ -1491,6 +1499,40 @@ let pair_params env (items : Ast.pitem list) : Ast.field list = in go items +(* A class slot's type, resolved and held to the set a stored dyn value can + be checked against: its tag says bool, int, float or text and nothing + finer, so those are the types there are. A narrower integer is a range on + top of the int tag. Everything else a type can be — a struct, a Vec, a + pointer — does not cross into dyn at all, so a slot of one could never be + written. *) +let slot_type env cls (f : Ast.field) : Types.t = + let t = resolve env f.Ast.fty in + match t with + | Types.Dyn | Types.Bool | Types.Int _ | Types.Float _ | Types.String -> t + | other -> + Loc.failk "check/slot-type" f.Ast.fty.Ast.tloc + "the slot %s of %s is declared %s, and a class slot holds a dyn value, \ + which can be checked as bool, an integer type, f32, f64 or string. \ + Write one of those, or leave the type out and the slot holds any dyn \ + value: [%s]" + f.Ast.fname cls (Types.to_string other) f.Ast.fname + +(* What the runtime is told a class is: one line per slot, in constructor + order, the slot's name and then its type's name after a space — no type + for a dyn slot. The same string goes to [flan_dyn_map_new_class] from the + constructor and to [flan_dyn_class_def] from a reload, so the two cannot + describe one class differently. *) +let class_spec_of (slots : (string * Types.t) list) = + String.concat "\n" + (List.map + (fun (n, t) -> + match t with + | Types.Dyn -> n + | t -> n ^ " " ^ Types.to_string t) + slots) + +let class_slots env n = Hashtbl.find_opt env.classes n + (* Every [defn] in the program, with its parameter vector paired. Run as a pass of its own, after the type names are registered and before any signature is resolved, so that nothing downstream ever sees an unpaired one. *) @@ -1503,6 +1545,18 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = List.map (fun (d : Ast.decl) -> match d.Ast.d with + (* A class's slot vector is paired here and nowhere earlier, for the + reason a [defn]'s is, and its constructor is written from the + pairs — [Classes.expand] left the declaration as it was for exactly + this. *) + | Ast.Defclass (n, items) -> + let slots = pair_params env items in + Hashtbl.replace env.classes n + (List.map + (fun (f : Ast.field) -> + (f.Ast.fname, slot_type env n f)) + slots); + Classes.constructor n slots d.Ast.dloc | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn f) } | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn f, c) } | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn f, c) } @@ -3450,10 +3504,14 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.MapLit (tag, kvs) -> let m = fresh_slot ctx Types.Dyn in let mval = mk loc Types.Dyn (Tast.Local m) in + (* A class's constructor stores through [flan_dyn_slot_init], which is + the plain store plus the slot's type check, worded for the + constructor rather than for a [put] nobody wrote. *) + let store = if tag = None then "flan_dyn_map_set" else "flan_dyn_slot_init" in let sets = List.map (fun (k, v) -> - rt loc Types.Unit "flan_dyn_map_set" + rt loc Types.Unit store [ mval; check ctx ~want:Types.Dyn k; check ctx ~want:Types.Dyn v ]) kvs @@ -3466,8 +3524,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = match tag with | None -> rt loc Types.Dyn "flan_dyn_map_new" [] | Some cls -> + (* The class's slots and their types ride along, so the first + instance built registers the class with the runtime and every + store after it — this literal's own included — is checked. A + class registered already, by an earlier instance or by a reload, + keeps what it has: redefining one is a reload's business. *) + let spec = + match Hashtbl.find_opt ctx.env.classes cls with + | Some slots -> class_spec_of slots + | None -> "" + in rt loc Types.Dyn "flan_dyn_map_new_class" - [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ] ] + [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ]; + mk loc Types.String (Tast.Str spec) ] in expect ctx loc ~want (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) @@ -3586,6 +3655,23 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = let v = check ctx ~want:pty v in expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) end + (* (set (get inst :slot) x) — a class instance's declared slot. A call and + not a place for [flan_dyn_set_at]'s reason: the runtime has to look at + the value to know it is an instance, which of its slots the key names, + and whether [x] fits the type that slot was declared with, and it traps + on each with a sentence of its own. A typed map has no such place; its + entries are written with [put]. *) + | Ast.Set (Ast.Pslot (target, k), v) -> + let target = check ctx target in + if target.Tast.ty <> Types.Dyn then + fail loc + "(get m k) is a place only on a class instance, and this is %s. A \ + map's entries are written with (put m k v)" + (Types.to_string target.Tast.ty); + let k = check ctx ~want:Types.Dyn k in + let v = check ctx ~want:Types.Dyn v in + expect ctx loc ~want + (rt loc Types.Unit "flan_dyn_slot_set" [ target; k; v; here loc ]) | Ast.Set (p, v) -> let p, pty = check_place ctx loc p in let v = check ctx ~want:pty v in @@ -6187,6 +6273,13 @@ and check_place ctx loc (p : Ast.place) : Tast.place * Types.t = | Types.Ptr t -> Tast.Pderef target, t | other -> fail loc "deref takes a (Ptr T), found %s" (Types.to_string other)) + (* Only [set] writes a class slot, and it has its own arm above. A slot + lives in a map the collector may move entries of, so it has no address + to hand out. *) + | Ast.Pslot _ -> + fail loc + "a class slot (get inst :slot) is written with set and has no address. \ + Read it into a local with let" (* An index or a slice bound that is a literal is known now, so it is an error now rather than a trap later. Only literals: a [defconst] is a global in the @@ -7829,12 +7922,14 @@ and named_call ?(qualified = false) ctx ~want loc name args = let target = check ctx target in (* A put into a dyn map is a call and nothing else, the way a push into a dyn vec is: the runtime owns the storage, so there is no guard, no - restart and no region check. An equal key's value is replaced. *) + restart and no region check. An equal key's value is replaced. The + site rides along for the one refusal a put can meet, a class + instance's typed slot. *) if target.Tast.ty = Types.Dyn then expect ctx loc ~want - (rt loc Types.Unit "flan_dyn_map_set" + (rt loc Types.Unit "flan_dyn_map_put" [ target; check ctx ~want:Types.Dyn k; - check ctx ~want:Types.Dyn v ]) + check ctx ~want:Types.Dyn v; here loc ]) else begin let kt, vt = map_kv loc "put" target.Tast.ty in let k = check ctx ~want:kt k in @@ -10845,7 +10940,11 @@ let collect env (decls : Ast.decl list) = driver that assembled a declaration list and skipped that pass would otherwise get a missing name from wherever the constructor was called, with nothing pointing here. *) - | Ast.Defclass (n, _) | Ast.Defgeneric { Ast.name = n; _ } + | Ast.Defclass (n, _) -> + fail loc + "internal: the class %s reached the checker unpaired — \ + pair_decls writes its constructor, and did not run" n + | Ast.Defgeneric { Ast.name = n; _ } | Ast.Defmulti { Ast.name = n; _ } -> fail loc "internal: %s reached the checker unexpanded — Classes.expand did \ diff --git a/lib/classes.ml b/lib/classes.ml index a6b7325b..15b9440a 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -4,9 +4,11 @@ [(defclass point [x y])] is a constructor. [(defgeneric area [self] dyn)] and [(defmulti describe [x] dyn (get x :kind))] are each one function whose body is a dispatch, and [(defmethod area point [p] ...)] is a branch of - one. Nothing below this pass knows any of the four forms exists: what it - writes is [defn]s, and they are checked, emitted, rooted, redefined and - inspected as any other function is. + one. What it writes is [defn]s, and they are checked, emitted, rooted, + redefined and inspected as any other function is. The one exception is + [defclass], which passes through untouched: its slot vector reads like a + [defn]'s and cannot be paired until every type name is known, so + [Check.pair_decls] pairs it and calls [constructor] below. **Why a pass and not a macro.** A macro sees one form. This needs the whole declaration list, because a method may be written anywhere — above @@ -65,23 +67,7 @@ let collect (decls : Ast.decl list) = List.iter (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> - (* Two slots of one name would write one entry and read one value, - and the constructor would take two arguments for it. The duplicate - parameter that falls out of it is refused by the checker anyway; - this says which declaration it came from. *) - let seen = Hashtbl.create 8 in - List.iter - (fun (s, sloc) -> - if Hashtbl.mem seen s then - Loc.failk "check/duplicate-slot" sloc - "%s names the slot %s twice. A slot is a key in the \ - instance's map, so the second would replace the first and \ - the constructor would take an argument that goes nowhere" - n s; - Hashtbl.replace seen s ()) - slots; - Hashtbl.replace classes n d.Ast.dloc + | Ast.Defclass (n, _) -> Hashtbl.replace classes n d.Ast.dloc | Ast.Defgeneric fn -> Hashtbl.replace generics fn.Ast.name { gkind = `Class; gfn = fn; gloc = d.Ast.dloc; gms = [] } @@ -162,14 +148,37 @@ let collect (decls : Ast.decl list) = omitted slot meaning nil — is deferred, and so is refusing an unknown slot at [(get p :z)]. Both are recorded in TODO.org, "Class features deferred, each with its reason". *) -let constructor n slots loc : Ast.decl = +let constructor n (slots : Ast.field list) loc : Ast.decl = + (* Two slots of one name would write one entry and read one value, and the + constructor would take two arguments for it. The duplicate parameter + that falls out of it is refused by the checker anyway; this says which + declaration it came from. *) + let seen = Hashtbl.create 8 in + List.iter + (fun (f : Ast.field) -> + if Hashtbl.mem seen f.Ast.fname then + Loc.failk "check/duplicate-slot" f.Ast.floc + "%s names the slot %s twice. A slot is a key in the instance's \ + map, so the second would replace the first and the constructor \ + would take an argument that goes nowhere" + n f.Ast.fname; + Hashtbl.replace seen f.Ast.fname ()) + slots; + (* Every parameter is dyn whatever its slot's type. The type is checked + where the value is stored — the constructor's own stores included — so + a caller holding a dyn passes it as it is, and a caller holding an i32 + boxes it; neither has to convert to the slot's type first. *) let params = List.map - (fun (s, sloc) -> { Ast.fname = s; fty = dyn_at sloc; floc = sloc }) + (fun (f : Ast.field) -> + { Ast.fname = f.Ast.fname; fty = dyn_at f.Ast.floc; floc = f.Ast.floc }) slots in let pairs = - List.map (fun (s, sloc) -> (ex sloc (Ast.Kw s), ex sloc (Ast.Var s))) slots + List.map + (fun (f : Ast.field) -> + (ex f.Ast.floc (Ast.Kw f.Ast.fname), ex f.Ast.floc (Ast.Var f.Ast.fname))) + slots in { Ast.d = Ast.Defn @@ -343,7 +352,9 @@ let expand (decls : Ast.decl list) : Ast.decl list = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (constructor n slots d.Ast.dloc) + (* Kept: its slot vector cannot be paired until every type name is + known, so [Check.pair_decls] writes the constructor. *) + | Ast.Defclass _ -> Some d | Ast.Defgeneric fn | Ast.Defmulti fn -> Some (dispatcher (Hashtbl.find generics fn.Ast.name)) (* Gone: its body is inside its generic's dispatch. *) diff --git a/lib/dev.ml b/lib/dev.ml index d83191d7..a22901a7 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1422,17 +1422,29 @@ let defs t = [M-.] on a prelude macro from "the prelude is not a file on disk" into a shrug about the daemon having no location. *) let macro_locs = Hashtbl.create 16 in - (* The classes, off the session's declarations: [Classes.expand] turns a - [defclass] into its constructor [defn] before the checker runs, so the - class is not in [Tast.program] or the checker's environment, and the - declarations are the one place that still has it. Its constructor is - dropped from the [fn] rows for the macro rows' reason: one name, one row, - and [class] is what was written. *) + (* The classes: where each was written, off the session's declarations, + and its slots as the checker paired them, off its environment — the + slot vector is unreadable before pairing. The constructor the checker + wrote is dropped from the [fn] rows for the macro rows' reason: one name, + one row, and [class] is what was written. *) let classes = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (n, List.map fst slots, d.Ast.dloc) + | Ast.Defclass (n, _) -> + let slots = + Option.value ~default:[] + (Check.class_slots t.session.Session.env n) + in + Some + (n, + List.map + (fun (s, ty) -> + match ty with + | Types.Dyn -> s + | ty -> s ^ " " ^ Types.to_string ty) + slots, + d.Ast.dloc) | _ -> None) t.session.Session.decls in diff --git a/lib/emit.ml b/lib/emit.ml index 800e4a71..13dc14fc 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4370,7 +4370,10 @@ declare i64 @flan_dyn_from_bool(i32) declare i64 @flan_dyn_from_bytes(ptr, i64) declare i64 @flan_dyn_vec_new() declare i64 @flan_dyn_map_new() -declare i64 @flan_dyn_map_new_class(i64) +declare i64 @flan_dyn_map_new_class(i64, ptr, i64) +declare void @flan_dyn_slot_set(i64, i64, i64, ptr, i64) +declare void @flan_dyn_slot_init(i64, i64, i64) +declare void @flan_dyn_map_put(i64, i64, i64, ptr, i64) declare i64 @flan_dyn_class_of(i64) declare void @flan_dyn_class_def(i64, ptr, i64) declare i64 @flan_dyn_kw(ptr, i64) diff --git a/lib/load.ml b/lib/load.ml index a3f28a9b..97a5220d 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -390,6 +390,7 @@ and rename_place owned alias bound (p : Ast.place) : Ast.place = | Ast.Pfield (t, f) -> Ast.Pfield (go t, f) | Ast.Pindex (t, idx) -> Ast.Pindex (go t, List.map go idx) | Ast.Pderef t -> Ast.Pderef (go t) + | Ast.Pslot (t, k) -> Ast.Pslot (go t, go k) let rename_field owned alias (f : Ast.field) : Ast.field = { f with Ast.fty = rename_texpr owned alias f.Ast.fty } @@ -501,12 +502,17 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = and the rename is the ordinary one: the declared name, plus whatever inside them is a name of this package. - A class's slots are not renamed. They are keywords in the map the + A class's slot names are not renamed. They are keywords in the map the constructor builds, and a keyword belongs to nobody — the same line the - [MapLit] arm above takes about a map literal's keys. The *class's* name - is qualified, so [pkg/point] is what an instance's shape tag reads and - two packages' [point] classes are two classes. *) - | Ast.Defclass (n, slots) -> Ast.Defclass (qualify alias n, slots) + [MapLit] arm above takes about a map literal's keys. A slot's *type* is + a type like any other, and the vector is unpaired, so it goes through + [rename_pitem] as a [defn]'s does: a bare symbol the package owns is a + type of this package, since no slot name is ever an owned name that + matters. The *class's* name is qualified, so [pkg/point] is what an + instance's shape tag reads and two packages' [point] classes are two + classes. *) + | Ast.Defclass (n, slots) -> + Ast.Defclass (qualify alias n, List.map (rename_pitem owned alias) slots) (* A generic's parameters are dyn and were written out by the parser, so there is no unpaired vector here and [bound] is exactly the parameter names. *) @@ -832,6 +838,7 @@ and place_uses acc loc (p : Ast.place) = | Ast.Pfield (t, _) -> expr_uses acc t | Ast.Pindex (t, idx) -> expr_uses acc t; List.iter (expr_uses acc) idx | Ast.Pderef t -> expr_uses acc t + | Ast.Pslot (t, k) -> expr_uses acc t; expr_uses acc k let decl_uses acc (d : Ast.decl) = let field (f : Ast.field) = texpr_uses acc f.Ast.fty in @@ -873,9 +880,14 @@ let decl_uses acc (d : Ast.decl) = | Ast.Zeroed | Ast.Uninit -> ()) | Ast.Defconst (_, t, v) -> Option.iter (texpr_uses acc) t; expr_uses acc v - (* A class's slots are keywords and name nothing. Its constructor's body is - written by [Classes.expand], long after this, out of the slots alone. *) - | Ast.Defclass _ -> () + (* A class's slot names are keywords and name nothing; its slot types are + uses, recorded the way an unpaired [defn] vector's are. *) + | Ast.Defclass (_, slots) -> + List.iter + (function + | Ast.Pname (n, loc) -> acc := (n, loc) :: !acc + | Ast.Ptype t -> texpr_uses acc t) + slots | Ast.Defgeneric f | Ast.Defmulti f -> fn f (* The generic is a use — a method in one package extending another's has to pull that package in — and so is the class in the dispatch slot, for the diff --git a/lib/parse.ml b/lib/parse.ml index c380830b..2b596ab5 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1205,13 +1205,19 @@ and place (f : Form.t) : Ast.place = either inserts or replaces — so there is no store into a lookup, and an entry that is absent has no location to store into. Refused here rather than parsed into a place form the language does not have. *) + (* A class instance's slot: declared by its defclass, so it always exists + and is a place, where a map's absent key is not. Whether the value is an + instance or a map is a run-time fact, so the store is a run-time call + and a map there is refused by it. *) + | List [ { v = Sym "get"; _ }; target; key ] -> + Ast.Pslot (expr target, expr key) | List ({ v = Sym "get"; _ } :: _) -> fail f "(get m k) is not a place — a map is written with (put m k v)" | List [ { v = Sym "deref"; _ }; p ] -> Ast.Pderef (expr p) | _ -> fail f "%s is not assignable. set takes a name, (.field x), (at a i ...), \ - or (deref p)" + (deref p), or a class slot (get inst :slot)" (Form.to_string f) and arms f (items : Form.t list) : Ast.arm list = @@ -1484,20 +1490,15 @@ let rec decl (f : Form.t) : Ast.decl = only names can be read here. *) | List ({ v = Sym "defclass"; _ } :: args) -> (match args with + (* The slot vector is a [defn]'s parameter vector in every respect — + [[x y]] two dyn slots, [[pause bool step bool]] two typed ones — and + is carried undecided for the same reason. *) | [ n; { v = Vec slots; _ } ] -> - mk (Ast.Defclass - (dname n, - List.map - (fun (s : Form.t) -> - match s.v with - | Sym name -> no_sigil s; (name, s.loc) - | _ -> - fail s - "a class slot is a name — its value is dyn, so there \ - is no type to write. Read one with (get p :%s)" - (Form.to_string s)) - slots)) - | _ -> fail f "defclass is (defclass Name [slot ...])") + List.iter + (fun (s : Form.t) -> match s.v with Sym _ -> no_sigil s | _ -> ()) + slots; + mk (Ast.Defclass (dname n, pitems slots)) + | _ -> fail f "defclass is (defclass Name [slot Type ...])") | List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) -> let generic = String.equal which "defgeneric" in diff --git a/lib/session.ml b/lib/session.ml index 00a4c241..c682fad7 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -747,27 +747,27 @@ let eval ?(origin = "") ?pause t src : change = A class whose slot list did not change is not in here at all: its constructor has the same signature and goes through [compatible] untouched. *) - let class_slots (ds : Ast.decl list) n = - List.fold_left - (fun acc (d : Ast.decl) -> - match d.Ast.d with - | Ast.Defclass (m, slots) when String.equal m n -> - Some (List.map fst slots) - | _ -> acc) - None ds + (* The slots as the checker paired them, off each side's environment: the + vector is not readable before pairing, and [t.env] is the one the + running program was checked against. Only the names decide the + constructor's arity; the types are the registration's business below. *) + let slot_names env n = + Option.map (List.map fst) (Check.class_slots env n) in let incoming_classes = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (n, List.map fst slots) + | Ast.Defclass (n, _) -> + Some (n, Option.value ~default:[] (Check.class_slots env n)) | _ -> None) incoming in let relaxed = List.filter_map (fun (n, slots) -> - match class_slots t.decls n with + let slots = List.map fst slots in + match slot_names t.env n with | Some old when old <> slots -> (* Every function of the running program that calls the constructor or takes its address, minus the ones this @@ -971,15 +971,16 @@ let eval ?(origin = "") ?pause t src : change = { Tast.e = Tast.Prim (Tast.Rt "flan_dyn_kw", [ str n ]); ty = Types.Dyn; loc } in - (* The slot names in one string, newline between: the runtime - splits them. A dyn vector would have been the obvious shape - and is the wrong one — it is a collector object, so the - registry would hold something the marker has to reach, where - a packed string reaches interned keywords that are immortal - already. *) + (* The slots in one string, a line each with the slot's type + after its name: the runtime splits them. A dyn vector would + have been the obvious shape and is the wrong one — it is a + collector object, so the registry would hold something the + marker has to reach, where a packed string reaches interned + keywords that are immortal already. The constructor carries + the same string, from the same function. *) { Tast.e = Tast.Prim (Tast.Rt "flan_dyn_class_def", - [ kw; str (String.concat "\n" slots) ]); + [ kw; str (Check.class_spec_of slots) ]); ty = Types.Unit; loc }) incoming_classes in diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index c7a8c724..d2849afe 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1172,12 +1172,14 @@ flan_dyn flan_dyn_map_new(void) { * of dyn vectors would have needed both, and would have needed them to * survive a collection triggered from inside a migration. * - * **What the registry does not do.** It does not constrain [put]. A class + * **What the registry constrains.** A store into a slot the class declares + * — the constructor's, [put]'s, [set]'s — is checked against the slot's + * type. A key the class does not declare is not refused by [put]: a class * instance is an open map — TODO.org, "Class features deferred, each with its - * reason", already defers unknown-slot checking — so a key nobody declared - * can be written to one, and the migration below will *drop* it at the next + * reason", defers unknown-slot checking — so a key nobody declared can be + * written to one, and the migration below will *drop* it at the next * redefinition, because its rule is that an instance's keys are the class's - * slots. That is real data loss and it is written down as such in TODO.org, + * slots. [set] does refuse one, because a slot it writes has to exist. That is real data loss and it is written down as such in TODO.org, * "A redefined defclass migrates its instances lazily", rather than dressed * up as enforcement. * @@ -1219,9 +1221,26 @@ flan_dyn flan_dyn_map_new(void) { * runs ahead of its definition declares itself. */ flan_dyn flan_dyn_kw(const uint8_t *p, int64_t n); +/* What a slot may hold. A dyn value's tag is the whole of what can be asked + * of it, so these are the tags, plus a range on top of the int tag for a + * slot declared with a narrower integer type. [word] is the type as the + * defclass wrote it, for the sentence a refusal prints. */ +enum { ST_ANY, ST_BOOL, ST_INT, ST_FLOAT, ST_TEXT }; + +typedef struct slot_type { + uint8_t kind; + int64_t lo, hi; /* ST_INT only */ + const char *word; /* static; NULL for ST_ANY */ +} slot_type; + typedef struct class_entry { kw_entry *name; kw_entry **slots; /* interned, immortal, in declaration order */ + slot_type *types; /* one per slot, same order */ + /* Per slot, the generation a migration last warned about a value that no + * longer fits the slot's type. One warning per slot per redefinition, + * however many instances carry such a value. */ + uint32_t *warned; int64_t nslots; uint32_t gen; } class_entry; @@ -1237,74 +1256,99 @@ static class_entry *class_find(kw_entry *name) { } /* The generation a new instance of [name] is stamped with. Zero for a class - * no definition has been registered for, which is every class in a program - * that was built and never reloaded: nothing has changed shape, so nothing - * needs to migrate, and the registry earns its keep only once an editor has - * sent a new definition. */ + * no definition has been registered for — which, now that the constructor + * registers its class, is only an instance built by something other than a + * constructor: test/dyn_ops.c, calling the runtime directly. */ static uint32_t class_gen(kw_entry *name) { class_entry *e = class_find(name); return e == NULL ? 0u : e->gen; } -/* One class's current slot list, as the compiler's per-reload thunk hands it - * over: the class's name as a keyword, and the slot names packed into one - * string, newline between and no leading colons — the shape a string literal - * already crosses in, rather than a dyn vector this would have to root. - * - * The generation is bumped only when the list actually differs. That is what - * makes C-c C-k idempotent: reloading a file re-runs every one of its class - * definitions, and a bump per reload would migrate every instance in the - * program every time anybody saved, for no change. */ -void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { - kw_entry *k; - kw_entry **list = NULL; - int64_t count = 0, i, start; - class_entry *e; - if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD) - /* No location: the caller is the thunk a reload runs, which has no - source position of its own — the class's own [defclass] is where a - reader would look, and it is not on any stack by the time this runs. - Unreachable from written Flan in any case; only the compiler emits - this call, and it emits a keyword. */ - trap1(NULL, 0, TYPE_TRAP, "class definition", - "a class name is a keyword", name); - k = dyn_kw(name); +static slot_type slot_type_of(const uint8_t *w, int64_t n) { + static const struct { const char *w; uint8_t kind; int64_t lo, hi; } known[] = { + { "bool", ST_BOOL, 0, 0 }, + { "string", ST_TEXT, 0, 0 }, + { "f32", ST_FLOAT, 0, 0 }, + { "f64", ST_FLOAT, 0, 0 }, + { "i8", ST_INT, INT8_MIN, INT8_MAX }, + { "i16", ST_INT, INT16_MIN, INT16_MAX }, + { "i32", ST_INT, INT32_MIN, INT32_MAX }, + { "i64", ST_INT, INT64_MIN, INT64_MAX }, + { "u8", ST_INT, 0, UINT8_MAX }, + { "u16", ST_INT, 0, UINT16_MAX }, + { "u32", ST_INT, 0, UINT32_MAX }, + { "u64", ST_INT, 0, INT64_MAX }, + }; + slot_type t = { ST_ANY, 0, 0, NULL }; + size_t i; + for (i = 0; i < sizeof known / sizeof known[0]; i++) + if ((int64_t)strlen(known[i].w) == n && memcmp(known[i].w, w, (size_t)n) == 0) { + t.kind = known[i].kind; + t.lo = known[i].lo; + t.hi = known[i].hi; + t.word = known[i].w; + return t; + } + /* A word this table does not know is a compiler newer than this runtime. + Holding anything is the answer that loses no data. */ + return t; +} + +static int slot_fits(const slot_type *t, flan_dyn v) { + int tag = flan_dyn_tag(v); + switch (t->kind) { + case ST_BOOL: return tag == FLAN_DYN_TAG_BOOL; + case ST_TEXT: return tag == FLAN_DYN_TAG_TEXT; + case ST_FLOAT: return tag == FLAN_DYN_TAG_FLOAT; + case ST_INT: { + int64_t x; + if (tag != FLAN_DYN_TAG_INT) return 0; + x = dyn_int_value(v); + return x >= t->lo && x <= t->hi; + } + default: return 1; + } +} + +/* A class's slots as the compiler hands them over: one line per slot, the + * slot's name and then, after a space, its type's name — nothing for a slot + * written with no type. The same string comes from a constructor and from a + * reload, so it is read in one place. The count is returned; both arrays are + * NULL for a class with no slots, which allocates nothing. */ +static int64_t class_spec(const uint8_t *spec, int64_t n, kw_entry ***names, + slot_type **types) { + int64_t count = 0, i, start; if (n < 0) n = 0; - /* Count first, then fill: one allocation of the right size, and an empty - * class — (defclass marker []) is in the corpus — allocates nothing. */ + *names = NULL; + *types = NULL; for (i = 0, start = 0; i <= n; i++) - if (i == n ? i > start : slots[i] == '\n') { + if (i == n ? i > start : spec[i] == '\n') { if (i > start) count++; start = i + 1; } - if (count > 0) { - list = (kw_entry **)malloc((size_t)count * sizeof *list); - if (list == NULL) trap_oom(NULL, 0, count * (int64_t)sizeof *list); - count = 0; - for (i = 0, start = 0; i <= n; i++) - if (i == n ? i > start : slots[i] == '\n') { - if (i > start) - list[count++] = dyn_kw(flan_dyn_kw(slots + start, i - start)); - start = i + 1; + if (count == 0) return 0; + *names = (kw_entry **)malloc((size_t)count * sizeof **names); + *types = (slot_type *)malloc((size_t)count * sizeof **types); + if (*names == NULL || *types == NULL) + trap_oom(NULL, 0, count * (int64_t)(sizeof **names + sizeof **types)); + count = 0; + for (i = 0, start = 0; i <= n; i++) + if (i == n ? i > start : spec[i] == '\n') { + if (i > start) { + int64_t sp = start; + while (sp < i && spec[sp] != ' ') sp++; + (*names)[count] = dyn_kw(flan_dyn_kw(spec + start, sp - start)); + (*types)[count] = sp < i ? slot_type_of(spec + sp + 1, i - sp - 1) + : slot_type_of(NULL, 0); + count++; } - } - e = class_find(k); - if (e != NULL) { - int same = e->nslots == count; - if (same) - for (i = 0; i < count; i++) - if (e->slots[i] != list[i]) { same = 0; break; } - if (same) { free(list); return; } - free(e->slots); - e->slots = list; - e->nslots = count; - /* Wrapping is not a correctness question — what matters is that the new - * generation differs from the one the live instances carry — but zero is - * reserved for "no definition registered", so it is stepped over. */ - e->gen = e->gen + 1u; - if (e->gen == 0u) e->gen = 1u; - return; - } + start = i + 1; + } + return count; +} + +static void class_add(kw_entry *k, kw_entry **list, slot_type *types, + int64_t count) { if (classes_n == classes_cap) { int64_t cap = classes_cap ? classes_cap * 2 : 8; class_entry *t = @@ -1315,6 +1359,11 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { } classes[classes_n].name = k; classes[classes_n].slots = list; + classes[classes_n].types = types; + classes[classes_n].warned = + count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL; + if (count > 0 && classes[classes_n].warned == NULL) + trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); classes[classes_n].nslots = count; /* One, never zero: an instance built before this registration carries zero * and has to be seen as stale, because the definition it was built from is @@ -1323,6 +1372,61 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { classes_n++; } +/* One class's current definition, as the compiler's per-reload thunk hands + * it over: the class's name as a keyword, and [class_spec]'s string. + * + * The generation is bumped only when the definition actually differs — a + * slot's name or its type. That is what makes C-c C-k idempotent: reloading + * a file re-runs every one of its class definitions, and a bump per reload + * would migrate every instance in the program every time anybody saved, for + * no change. */ +void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { + kw_entry *k; + kw_entry **list; + slot_type *types; + int64_t count, i; + class_entry *e; + if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD) + /* No location: the caller is the thunk a reload runs, which has no + source position of its own — the class's own [defclass] is where a + reader would look, and it is not on any stack by the time this runs. + Unreachable from written Flan in any case; only the compiler emits + this call, and it emits a keyword. */ + trap1(NULL, 0, TYPE_TRAP, "class definition", + "a class name is a keyword", name); + k = dyn_kw(name); + count = class_spec(slots, n, &list, &types); + e = class_find(k); + if (e != NULL) { + int same = e->nslots == count; + if (same) + for (i = 0; i < count; i++) + if (e->slots[i] != list[i] || e->types[i].kind != types[i].kind + || e->types[i].lo != types[i].lo || e->types[i].hi != types[i].hi) { + same = 0; + break; + } + if (same) { free(list); free(types); return; } + free(e->slots); + free(e->types); + free(e->warned); + e->slots = list; + e->types = types; + e->warned = + count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL; + if (count > 0 && e->warned == NULL) + trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); + e->nslots = count; + /* Wrapping is not a correctness question — what matters is that the new + * generation differs from the one the live instances carry — but zero is + * reserved for "no definition registered", so it is stepped over. */ + e->gen = e->gen + 1u; + if (e->gen == 0u) e->gen = 1u; + return; + } + class_add(k, list, types, count); +} + /* The migration. [o] is left holding exactly the class's current slots, in * the class's order, with the values it already had for the ones it still * has and nil for the ones it has just gained — which is precisely the @@ -1367,6 +1471,27 @@ static void class_sync(flan_obj *o) { if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD && dyn_kw(key) == e->slots[j]) { v = o->u.v.items[i * 2 + 1]; + /* A kept value that the slot's new type does not admit is kept + anyway: throwing it away would be the data loss a redefinition + exists to avoid, and there is nothing to convert it to. What it + gets is a warning, once per slot per redefinition, and the next + write to the slot is checked like any other. A slot the class + has only just gained holds nil without a word: it holds nothing, + rather than something of the wrong type. */ + if (!slot_fits(&e->types[j], v) && e->warned[j] != e->gen) { + char sv[SAY_MAX]; + kw_entry *c = o->u.v.klass, *sl = e->slots[j]; + e->warned[j] = e->gen; + say(sv, SAY_MAX, v); + fflush(stdout); + fprintf(stderr, + "warning: %.*s was redefined, and its slot :%.*s is now " + "declared %s. An instance holds %s there, which is %s; it " + "keeps that value, and the next write to :%.*s is checked\n", + (int)c->len, (const char *)(c + 1), + (int)sl->len, (const char *)(sl + 1), e->types[j].word, sv, + tag_of(v), (int)sl->len, (const char *)(sl + 1)); + } break; } } @@ -1386,11 +1511,25 @@ static void class_sync(flan_obj *o) { /* The same map with a shape tag on it: what a (defclass ...) constructor * calls. [k] is a keyword and anything else traps by name — the compiler - * hands it the class's own name and nothing else can reach this. */ -flan_dyn flan_dyn_map_new_class(flan_dyn k) { + * hands it the class's own name and nothing else can reach this. + * + * [spec] is the class's definition, [class_spec]'s string, and it registers + * the class the first time any instance of it is built. That is what makes + * a slot's type checked in a program that is never reloaded — the registry + * used to be filled only by a reload. A class already registered keeps + * what it has, and has to: a constructor compiled before a redefinition may + * still be on some stack, and letting its definition win would put the + * class back the way it was. Redefining is [flan_dyn_class_def]'s alone. */ +flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n) { flan_obj *o; if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) trap1(NULL, 0, TYPE_TRAP, "class instance", "a class tag is a keyword", k); + if (class_find(dyn_kw(k)) == NULL) { + kw_entry **list; + slot_type *types; + int64_t count = class_spec(spec, n, &list, &types); + class_add(dyn_kw(k), list, types, count); + } o = gc_alloc(OBJ_MAP, 0); o->len = 0; o->u.v.items = NULL; @@ -2265,8 +2404,141 @@ flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) { return flan_dyn_from_bool(map_find(o, k) >= 0); } -void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) { +/* A class slot's type, checked at the store — SBCL's place for it + * (src/pcl/slots.lisp, [set-slot-value]'s typecheck before the write), + * because the store is where the wrong value is. -1 when [k] is not a slot + * the class declares. */ +static int64_t class_slot(class_entry *e, flan_dyn k) { + int64_t j; + if (e == NULL || flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) return -1; + for (j = 0; j < e->nslots; j++) + if (e->slots[j] == dyn_kw(k)) return j; + return -1; +} + +/* The three stores that reach a declared slot, for the sentence a refusal + * prints: the call as it would have been written. */ +enum { BY_PUT, BY_SET, BY_NEW }; + +static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, + int by, flan_obj *o, class_entry *e, + int64_t j, flan_dyn m, flan_dyn v) { + char sm[SAY_MAX], sv[SAY_MAX]; + kw_entry *sl = e->slots[j], *c = o->u.v.klass; + int sn = (int)sl->len, cn = (int)c->len; + const char *ss = (const char *)(sl + 1), *cs = (const char *)(c + 1); + say(sm, SAY_MAX, m); + say(sv, SAY_MAX, v); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, "dyn %s: the slot :%.*s of %.*s is declared %s, and ", + by == BY_PUT ? "put" : by == BY_SET ? "set" : "construct", sn, ss, + cn, cs, e->types[j].word); + /* An int of the wrong size is the right tag, so the tag is not the news. */ + if (e->types[j].kind == ST_INT && flan_dyn_tag(v) == FLAN_DYN_TAG_INT) + fprintf(stderr, "%s is outside its range — ", sv); + else + fprintf(stderr, "this is %s — ", tag_of(v)); + if (by == BY_PUT) + fprintf(stderr, "(put %s :%.*s %s)\n", sm, sn, ss, sv); + else if (by == BY_SET) + fprintf(stderr, "(set (get %s :%.*s) %s)\n", sm, sn, ss, sv); + else + fprintf(stderr, "(%.*s ...) with :%.*s %s\n", cn, cs, sn, ss, sv); + flan_trap((const uint8_t *)"DynType", 7); +} + +static void check_slot(const uint8_t *loc, int64_t loclen, int by, + flan_obj *o, flan_dyn m, flan_dyn k, flan_dyn v) { + class_entry *e; + int64_t j; + if (o->u.v.klass == NULL) return; + e = class_find(o->u.v.klass); + j = class_slot(e, k); + if (j >= 0 && !slot_fits(&e->types[j], v)) + trap_slot_type(loc, loclen, by, o, e, j, m, v); +} + +static void map_store(flan_obj *o, flan_dyn k, flan_dyn v); + +/* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for + * the constructor call it happened inside rather than for a [put] nobody + * wrote. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v) { + flan_obj *o = want_map("construct", m, k); + check_slot(NULL, 0, BY_NEW, o, m, k, v); + map_store(o, k, v); +} + +/* (set (get inst :slot) v). Three refusals, each its own sentence, because + * they are three different mistakes: the value is not a class instance at + * all (a map's entries are written with [put], which is where inserting a + * key is real); the key is not a slot the class declares; the value does not + * fit the slot's type. The first two are why this is not [put]: a declared + * slot always exists, so writing one is a store and never an insertion. */ +void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen) { + flan_obj *o; + class_entry *e; + int64_t j; + if (!is_map(m) || dyn_obj(m)->u.v.klass == NULL) { + char sm[SAY_MAX]; + say(sm, SAY_MAX, m); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, + "dyn set: (get m k) is a place only on a class instance, and " + "this is %s%s — %s. A map's entries are written with " + "(put m k v)\n", + is_map(m) ? "a map with no class" : "a ", + is_map(m) ? "" : tag_of(m), sm); + flan_trap((const uint8_t *)"DynType", 7); + } + o = dyn_obj(m); + class_sync(o); + e = class_find(o->u.v.klass); + j = class_slot(e, k); + if (j < 0) { + char sk[SAY_MAX]; + kw_entry *c = o->u.v.klass; + int64_t i; + say(sk, SAY_MAX, k); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, "dyn set: %.*s has no slot %s. Its slots are", + (int)c->len, (const char *)(c + 1), sk); + if (e == NULL || e->nslots == 0) fprintf(stderr, " none"); + else + for (i = 0; i < e->nslots; i++) + fprintf(stderr, " :%.*s", (int)e->slots[i]->len, + (const char *)(e->slots[i] + 1)); + fprintf(stderr, "; a key the class does not declare is written with " + "(put inst k v)\n"); + flan_trap((const uint8_t *)"DynType", 7); + } + if (!slot_fits(&e->types[j], v)) + trap_slot_type(loc, loclen, BY_SET, o, e, j, m, v); + map_store(o, k, v); +} + +/* [put]: a key the class declares is checked against its type, and the + * refusal names [loc]. A key it does not declare is let through: an + * instance is an open map to [put], and the next redefinition drops such a + * key — see "Classes" above. */ +void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, + int64_t loclen) { flan_obj *o = want_map("put", m, k); + check_slot(loc, loclen, BY_PUT, o, m, k, v); + map_store(o, k, v); +} + +/* The same with no site: a map literal's stores, and test/dyn_ops.c. */ +void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) { + flan_dyn_map_put(m, k, v, NULL, 0); +} + +/* The store under all three, with the instance already brought up to date. */ +static void map_store(flan_obj *o, flan_dyn k, flan_dyn v) { int64_t i = map_find(o, k); if (i >= 0) { o->u.v.items[i * 2 + 1] = v; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 889be2e7..8b73adf6 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -88,15 +88,28 @@ flan_dyn flan_dyn_map_new(void); * * The tag is not traced and does not have to be: an interned keyword entry is * immortal and is not a collector object. */ -flan_dyn flan_dyn_map_new_class(flan_dyn k); +flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n); + +/* A constructor's store into a slot, checked against the slot's declared + * type — [flan_dyn_map_set] with a refusal worded for the constructor. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v); + +/* (set (get inst :slot) v): [m] must be a class instance and [k] a slot its + * class declares, and [v] must fit the slot's type; each is a trap with its + * own sentence, at [loc]. A declared slot always exists, so this stores and + * never inserts. */ +void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); /* The class's name as a keyword, or nil for anything that is not an instance * — an ordinary map included. Never traps. */ flan_dyn flan_dyn_class_of(flan_dyn v); /* A class definition, registered or re-registered: [name] is the class's name - * as a keyword and [slots]/[n] is its slot names packed into one string, - * newline between and no leading colons. The compiler emits one call per + * as a keyword and [slots]/[n] is its slots packed into one string, a line + * each, the slot's name and then — after a space, for a typed slot — its + * type's name: "x i64\ny" is an i64 slot :x and a slot :y of any value. + * [flan_dyn_map_new_class] takes the same string. The compiler emits one call per * (defclass ...) into the thunk a reload runs, so a definition that changed * lands here before anything touches an instance. * @@ -185,6 +198,10 @@ void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen); * key in place, so a key occurs once and insertion order is print order. */ flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k); void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v); +/* [put]'s: [flan_dyn_map_set], with the site a typed class slot's refusal + * prints. */ +void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k); /* Structural, and per type it renders what typed [print] renders. Never diff --git a/test/dyn_ops.c b/test/dyn_ops.c index dd9eb728..c4f4d292 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -1061,7 +1061,8 @@ static void define(const char *name, const char *slots) { * Built through the same entry point a constructor uses, so it is stamped * exactly as compiled code would stamp it. */ static flan_dyn a_point(int64_t x, int64_t y) { - flan_dyn p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5)); + flan_dyn p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5), + (const uint8_t *)"x\ny", 3); flan_dyn_map_set(p, flan_dyn_kw((const uint8_t *)"x", 1), flan_dyn_from_i64(x)); flan_dyn_map_set(p, flan_dyn_kw((const uint8_t *)"y", 1), @@ -1176,7 +1177,8 @@ static void classes(void) { define("point", "x\ny\nn"); /* Built by hand rather than through [a_point], because it is the instance the *new* constructor would build: three slots, stamped current. */ - q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5)); + q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5), + (const uint8_t *)"x\ny\nn", 5); flan_dyn_map_set(q, flan_dyn_kw((const uint8_t *)"x", 1), flan_dyn_from_i64(1)); flan_dyn_map_set(q, flan_dyn_kw((const uint8_t *)"y", 1), diff --git a/test/programs/dyn-class-slots.flan b/test/programs/dyn-class-slots.flan new file mode 100644 index 00000000..ea38ef7e --- /dev/null +++ b/test/programs/dyn-class-slots.flan @@ -0,0 +1,38 @@ +;;;; Typed class slots, and set on a slot. +;;;; +;;;; A slot vector reads as a defn's parameter vector: [pause bool] is a slot +;;;; of type bool, and a name followed by another name is a slot with no type, +;;;; which holds any dyn value. The type is checked when a value is stored -- +;;;; by the constructor, by put and by set -- and not when one is read: an +;;;; instance is a dyn map whatever its slots say. +;;;; +;;;; set writes a declared slot. A class declares its slots, so one always +;;;; exists and (get s :pause) is a place, where a plain map's absent key is +;;;; not. dyn-slot-trap.flan has the refusals. + +(defclass state [pause bool step i32 speed f64 name string tag]) + +(defn twelve [] i64 12) + +(defn main [] i32 + (let [s (state false 3 1.5 "sand" :x)] + (println s) + (set (get s :pause) true) + (println (get s :pause)) + ;; An i32 slot takes any int in i32's range; a dyn caller passes the + ;; value as it is, with nothing converted first. + (set (get s :step) -7) + (println (get s :step)) + (set (get s :tag) [1 2]) + (println (get s :tag)) + ;; put reaches the same check for a declared slot, and still inserts a + ;; key the class does not declare -- an instance is an open map to put. + (put s :speed 2.5) + (put s :scratch 9) + (println (get s :speed)) + (println (get s :scratch)) + (println (length s)) + ;; A typed caller boxes into the dyn parameter as any call does. + (set (get s :step) (twelve)) + (println (get s :step))) + 0) diff --git a/test/programs/dyn-slot-trap.flan b/test/programs/dyn-slot-trap.flan new file mode 100644 index 00000000..15a025ca --- /dev/null +++ b/test/programs/dyn-slot-trap.flan @@ -0,0 +1,18 @@ +;;;; The refusals of a typed class slot, one per run because each ends the +;;;; process. The argument chooses which. The line numbers are asserted by +;;;; the test, so an edit above them moves them. +(defclass state [pause bool step i32 tag]) + +(defn as-dyn [d dyn] dyn d) + +(defn main [args [string]] i32 + (let [which (if (> (length args) 1) (i32 (bytes->i64 (bytes-view (at args 1)))) 0) + s (state false 3 nil)] + (println "before") + (cond + (= which 0) (println (state 1 2 3)) + (= which 1) (put s :pause 1) + (= which 2) (set (get s :step) 5000000000) + (= which 3) (set (get s :paws) true) + :else (set (get (as-dyn {:pause 1}) :pause) true))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 6ced8956..5487ece0 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -4935,6 +4935,47 @@ level "1" index_site (); index_site ~x86:true (); + (* Typed class slots and set on a slot: the stores that fit, then one + run per refusal. The constructor, put and set each check a declared + slot's type, set refuses a slot the class does not declare and a + value that is not an instance, and put still inserts an undeclared + key. On both backends, because every one of these is a runtime call + whose arguments the two emit separately. *) + let slots_out = + "#state{ :pause false :step 3 :speed 1.5 :name \"sand\" :tag :x}\n\ + true\n-7\n[ 1 2]\n2.5\n9\n6\n12\n" + in + outputs "dyn: typed class slots" "programs/dyn-class-slots.flan" slots_out; + outputs ~x86:true "dyn: typed class slots, --x86" + "programs/dyn-class-slots.flan" slots_out; + let slot_trap ?x86 () = + let exe = compile ?x86 "programs/dyn-slot-trap.flan" in + List.iter + (fun (arg, want) -> + let code, text = run exe (Some arg) in + if code <> 134 || not (contains text want) then begin + incr failures; + Printf.printf + "FAIL dyn: a class slot's refusal%s\n got: %S \ + (exit %d)\n wanted: %S (exit 134)\n" + (match x86 with Some true -> ", --x86" | _ -> "") + text code want + end) + [ ("0", "dyn construct: the slot :pause of state is declared bool, \ + and this is int — (state ...) with :pause 1"); + ("1", "dyn-slot-trap.flan:14:19: dyn put: the slot :pause of state \ + is declared bool, and this is int"); + ("2", "dyn-slot-trap.flan:15:19: dyn set: the slot :step of state \ + is declared i32, and 5000000000 is outside its range"); + ("3", "dyn-slot-trap.flan:16:19: dyn set: state has no slot :paws. \ + Its slots are :pause :step :tag"); + ("4", "dyn-slot-trap.flan:17:13: dyn set: (get m k) is a place only \ + on a class instance, and this is a map with no class") ]; + (try Sys.remove exe with Sys_error _ -> ()) + in + slot_trap (); + slot_trap ~x86:true (); + (* A numeric cast opening a dyn box — TODO.org, "A numeric cast opens a dyn box". programs/dyn-cast.flan is one program because the three behaviours are one story told in order: the same-kind casts print, the diff --git a/test/test_flan.ml b/test/test_flan.ml index d7857883..1c3fddf0 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -2611,14 +2611,31 @@ let () = rejects_check "a constructor takes one argument per slot" "(defclass point [x y])\n(defn main [] i32 (let [p (point 1)] 0))" ~needle:"point"; - (* A slot vector holds names and nothing else. [(defclass point [x i64])] - is therefore two slots, one of them unfortunately named — the parser - cannot tell a type's name from a slot's and does not have to, since a - slot has no type to write. What it can tell is a form that is not a name - at all. *) - rejects_check "a slot is a name, not a type expression" + (* A slot vector is a defn's parameter vector: a name followed by a type + is a typed slot, a name followed by another name is an untyped one. The + type is what a stored dyn value is checked against, so it is one a dyn + value can be checked as, and nothing else. *) + accepts "typed slots, and untyped ones beside them" + "(defclass state [pause bool step bool n i32 tag])\n\ + (defn main [] i32 (let [s (state false true 3 :x)] (if (= (get s :n) 3) 0 1)))"; + rejects_check "a slot's type is one a dyn value can be checked as" "(defclass point [x (Ptr i64)])\n(defn main [] i32 0)" - ~needle:"a class slot is a name"; + ~needle:"the slot x of point is declared (Ptr i64)"; + rejects_check "a capitalised name in a slot vector is an unknown type" + "(defclass point [x Widget])\n(defn main [] i32 0)" + ~needle:"unknown type Widget"; + rejects_check "a slot's type is resolved like any other" + "(defclass point [x f65])\n(defn main [] i32 0)" + ~needle:"did you mean f64"; + (* The slot is a place: its class declares it, so it always exists. *) + accepts "set writes a class slot" + "(defclass state [pause bool])\n\ + (defn main [] i32 (let [s (state false)] (set (get s :pause) true) \ + (if (get s :pause) 0 1)))"; + rejects_check "a class slot has no address" + "(defclass state [pause bool])\n\ + (defn main [] i32 (let [s (state false)] (addr (get s :pause)) 0))" + ~needle:"addr takes the address of a place"; rejects_check "a class does not name a slot twice" "(defclass point [x x])\n(defn main [] i32 0)" ~needle:"names the slot x twice"; @@ -3710,7 +3727,10 @@ let () = into a lookup and no place form for one. Refused with that reason rather than as a milestone that will never arrive. *) rejects_check "a map entry as a place" - "(defn f [] () (set (get m 1) 2))" + "(defn f [m (Map i64 i64)] () (set (get m 1) 2))" + ~needle:"entries are written with (put m k v)"; + rejects_check "get with three arguments is not a place" + "(defn f [m dyn] () (set (get m 1 2) 2))" ~needle:"a map is written with (put m k v)"; (* ── restart-case and invoke-restart, §3 to §6 ─────────────────── *) diff --git a/test/test_session.ml b/test/test_session.ml index 78a3936d..758cb23f 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1384,6 +1384,20 @@ let () = (String.concat " " c.Session.fns) | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a class and its caller evaluated together: %s" m); + (* A slot's type changed and nothing else. Every constructor parameter is + dyn whatever the slot says, so the signature is the one it was and a + compiled caller is no reason to refuse — the type is checked where a + value is stored, at run time. What has to reach the program is the new + definition, and the registration carries it with the type after the + name, which is what makes the runtime see a change and migrate. *) + (let t, _ = Session.create ~file:"programs/dev-class.flan" () in + ignore (Session.eval t "(defn origin [] dyn (point 0 0))"); + match Session.eval t "(defclass point [x i64 y])" with + | c -> + if not (has c.Session.ir "c\"x i64\\0Ay\"") then + fail "a slot's new type did not reach the registration" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a slot's type changed under a compiled caller was refused: %s" m); (* ── What a slot is shown as ────────────────────────────────────────── [strip_rebind] takes only a trailing ~N — [~] is the reader's delimiter diff --git a/web/examples/classes.flan b/web/examples/classes.flan index b79f5b5f..d036b73c 100644 --- a/web/examples/classes.flan +++ b/web/examples/classes.flan @@ -1,5 +1,5 @@ -;; A class is a named dyn map with a shape tag. Its slots are names and -;; carry no types, and its constructor is the class's own name, positional. +;; A class is a named dyn map with a shape tag. A slot with no type holds +;; any value, and its constructor is the class's own name, positional. (defclass point [x y]) (defclass circle [r]) diff --git a/web/index.html b/web/index.html index 7584f36e..0805ca50 100644 --- a/web/index.html +++ b/web/index.html @@ -710,10 +710,16 @@ unit carries nothing for a dyn word to hold, and boxing it is refused — and

Classes and generic functions

A class is a named dyn map with a shape tag. defclass names its -slots, which carry no types; the constructor is the class's own name and is -positional; and class-of answers the tag, or nil for -anything that is not an instance. The slots are map keys, so nothing was added to -read or write one.

+slots, and a slot may be followed by a type, the way a parameter is: +[x y] is two slots that hold any value, and [pause bool] +is one that holds only a bool. The type is checked whenever a value is stored, +and a slot may be bool, an integer type, f32, +f64 or string. The constructor is the class's own name +and is positional, and class-of answers the tag, or nil +for anything that is not an instance. The slots are map keys: get +reads one, and set writes one, as in +(set (get s :pause) true). put writes one too, and is +also how a key the class does not declare is added.

Dispatch comes in the two styles and they are one mechanism. defgeneric dispatches on the class of the first argument, which is @@ -725,8 +731,8 @@ which is last whatever order it was written in. The generic states the return ty once, for every method; a method has no return slot; and every parameter of both is dyn, written or not.

-
;; A class is a named dyn map with a shape tag. Its slots are names and
-;; carry no types, and its constructor is the class's own name, positional.
+
;; A class is a named dyn map with a shape tag. A slot with no type holds
+;; any value, and its constructor is the class's own name, positional.
 (defclass point [x y])
 (defclass circle [r])
 

From c671bba490f689ce7a940efd54696e40b1d64b50 Mon Sep 17 00:00:00 2001
From: Joseph Ferano 
Date: Fri, 25 Sep 2026 11:47:28 +0700
Subject: [PATCH 06/16] (the T e) gives any expression its type, and an array
 literal nothing names is typed when its elements agree and a dyn vector when
 they mix

---
 TODO.org                               |  27 ++-
 lib/ast.ml                             |   5 +
 lib/check.ml                           | 237 +++++++++++++++++--------
 lib/load.ml                            |   2 +
 lib/parse.ml                           |   9 +
 test/programs/array-first-element.flan |   4 +-
 test/programs/array-mixed.flan         |  59 ++++++
 test/test_acceptance.ml                |  13 +-
 test/test_flan.ml                      |  63 +++++--
 9 files changed, 311 insertions(+), 108 deletions(-)
 create mode 100644 test/programs/array-mixed.flan

diff --git a/TODO.org b/TODO.org
index 65c7ead2..77327b25 100644
--- a/TODO.org
+++ b/TODO.org
@@ -923,19 +923,13 @@ type an expression cannot hold, such as =(Fn [i32] ())=, is parsed as
 
 ** DONE An array literal cannot say it is [f32]
 CLOSED: [2026-09-25]
-With nothing outside an array literal naming its element type, the first
-element's type is the want for the rest, so =[(f32 1.0) 2.5]= is a =[2 f32]=. A
-refusal of a later element carries a note at the first saying it set the type.
-Rules out a =1.0f= suffix for now.
+=(the [f32] [1 2.5])= names the element type; with nothing naming one, a literal
+element takes the other elements' type. Rules out a =1.0f= suffix for now.
 
-** NEXT A let binding takes no type annotation
-Decided 2026-09-25: =(the T expr)=, Common Lisp's special operator, gives any expression its want; checked at compile time like any other want, and it compiles to nothing. =let= is unchanged. On a =dyn= operand it is refused, naming the cast. The refusals that say "annotate the binding" — =None=, an empty =[]=, and =(zeroed)=/=(filled)=/=(dead-beef)= with no want — suggest it instead, because today their suggestion cannot compile.
-Everything under the surface is there — the binding carries a type slot and the
-checker consumes it as the want — and only the way it is written is open, because
-=let= is a flat list of pairs and cannot disambiguate by count. No longer the
-blocker it was, since =(array 4 T)= answers the case that raised it. plan.org's
-rule is "annotate function signatures, infer locals", so a general annotation is a
-deliberate absence.
+** DONE A let binding takes no type annotation
+CLOSED: [2026-09-25]
+=(the T expr)= gives any expression its want and =let= stays a flat list of
+pairs. Rules out a type slot in =let=.
 
 ** NEXT A read-only slice type
 Decided 2026-09-25: =[const u8]=, Zig's spelling in Flan's brackets. =bytes-view= answers one and a =set= through it is a compile error; a =[T]= converts to =[const T]= and not back, and the prelude's read-only functions take it. =const= is reserved as a name, since =[n T]= accepts a constant's name for =n=.
@@ -1513,11 +1507,10 @@ incarnation it was made for; every use compares the incarnation, so a destroyed
 arena traps whether or not a later arena-new reused its record. Rules out
 static tracking of destroy, which is move semantics.
 
-** NEXT A mixed array literal with no want is a dyn vector
-Decided 2026-09-25: with nothing expected of it, an array literal whose elements
-agree (numbers widening together) is typed; one whose elements mix — [10 "Hi"],
-[nil 1] — is a dyn vector. (the [T] ...) forces a typed one, and a want from
-context still wins. Replaces the first-element carry-over.
+** DONE A mixed array literal with no want is a dyn vector
+CLOSED: [2026-09-25]
+Elements that agree, numbers meeting at the wider, are typed; elements that mix
+are a dyn vector. Rules out the first element typing the rest.
 
 * Dev loop
 
diff --git a/lib/ast.ml b/lib/ast.ml
index 41708a09..f90d3d83 100644
--- a/lib/ast.ml
+++ b/lib/ast.ml
@@ -126,6 +126,10 @@ and expr_kind =
      dimension; [ArrayFill]'s is the element value itself, evaluated once. *)
   | ArrayFill of len list * expr
   | ArrayGen  of len list * expr
+  (* (the T e) — [e] checked with [T] as its expectation, Common Lisp's
+     special operator. A binding has no type slot, and this is what gives any
+     expression one; it compiles to [e]. *)
+  | The of texpr * expr
   (* These bind names or alter control flow, so none of them can be a call. *)
   | Fn      of string list * expr list        (* (fn [x y] ...) — non-escaping *)
   (* (dotimes :o [i n] ...), (dotimes [i start stop] ...) and
@@ -437,6 +441,7 @@ let map_children f (e : expr) : expr =
        subexpressions. The dimensions are [len]s and hold none. *)
     | ArrayFill (ds, v) -> ArrayFill (ds, ex v)
     | ArrayGen (ds, f) -> ArrayGen (ds, ex f)
+    | The (t, x) -> The (t, ex x)
     | Fn (ps, es) -> Fn (ps, List.map ex es)
     | Dotimes (l, n, b, es) ->
       Dotimes (l, n,
diff --git a/lib/check.ml b/lib/check.ml
index 93edcb32..f78661da 100644
--- a/lib/check.ml
+++ b/lib/check.ml
@@ -3619,18 +3619,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
      {:xs [1 2]} mean what it reads as. Everywhere else brackets stay the
      fixed-array literal they always were. *)
   | Ast.Arr items when want = Some Types.Dyn ->
-    let v = fresh_slot ctx Types.Dyn in
-    let vval = mk loc Types.Dyn (Tast.Local v) in
-    let pushes =
-      List.map
-        (fun x ->
-           rt loc Types.Unit "flan_dyn_push"
-             [ vval; check ctx ~want:Types.Dyn x; here loc ])
-        items
-    in
-    mk loc Types.Dyn
-      (Tast.Let ([ (v, rt loc Types.Dyn "flan_dyn_vec_new" []) ],
-                 pushes @ [ vval ]))
+    dyn_vec ctx loc (map_lr (fun x -> check ctx ~want:Types.Dyn x) items)
   | Ast.Arr items -> check_arr ctx ~want loc items
   (* (array 4 rl/Vector2). Parse already assembled the whole array type, so
      there is nothing to infer: resolve it and hand back its all-bytes-zero
@@ -3645,6 +3634,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
     fail loc "this is a type, and a value is wanted here"
   | Ast.ArrayFill (dims, v) -> check_array_fill ctx ~want loc dims v
   | Ast.ArrayGen (dims, f) -> check_array_gen ctx ~want loc dims f
+  | Ast.The (t, v) -> check_the ctx ~want loc t v
   | Ast.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms
   (* Constant integer arithmetic where a type variable is wanted is folded to
      the literal it computes first, so [(+ x (+ 1 2))] is admitted wherever
@@ -3922,8 +3912,8 @@ and var ctx ?(qualified = false) loc ~want name =
        fail loc "expected %s, found None" (Types.to_string other)
      | _ ->
        fail loc
-         "nothing here says what None is an Option of — annotate the \
-          function's return type or the binding")
+         "nothing here says what None is an Option of — use it where an \
+          Option is expected, or name one, as in (the (Option i32) None)")
   (* spec-memory.md puts the allocator in the calling convention as
      [context/allocator] and [context/temp]. They read as names rather than
      calls because that is how the spec writes them, and they are dynamic
@@ -5493,63 +5483,27 @@ and check_arr ctx ~want loc items =
     | Some (Types.Slice t) -> Some t
     | _ -> None
   in
-  (* With nothing outside saying what the elements are, the first one says:
-     [[(f32 1.0) 2.5]] is an [[2 f32]], its [2.5] checked at [f32] the way it
-     would be at an [f32] parameter. *)
-  let items =
-    match elem_want, items with
-    | Some _, _ | None, [] -> map_lr (fun i -> check ctx ?want:elem_want i) items
-    | None, first :: rest ->
-      let first_ast = first in
-      let first = check ctx first in
-      let want =
-        match first.Tast.ty with Types.Never -> None | t -> Some t
-      in
-      (* A refusal of the element itself says where its type came from. *)
-      let one (i : Ast.expr) =
-        (match i.Ast.e, want with
-         | Ast.UInt (_, text), Some (Types.Int k) when k <> Types.U64 ->
-           let first_src =
-             match first_ast.Ast.e with
-             | Ast.Int _ | Ast.Byte _ -> Some (spell_arg "" first_ast)
-             | _ -> None
-           in
-           Loc.failk literal_at_want i.Ast.loc
-             ~notes:
-               [ Loc.note first.Tast.loc
-                   (Printf.sprintf
-                      "this array's first element is %s, so every element is"
-                      (Types.ikind_name k)) ]
-             "%s does not fit in %s, and only a u64 holds it%s" text
-             (Types.ikind_name k)
-             (match first_src with
-              | Some f ->
-                Printf.sprintf " — write the first element as (u64 %s) for an \
-                                array of u64" f
-              | None -> " — make the first element a u64 for an array of u64")
-         | _ -> ());
-        try check ctx ?want i with
-        | Loc.Error d when d.Loc.dloc = i.Ast.loc && want <> None ->
-          raise
-            (Loc.Error
-               { d with
-                 Loc.notes =
-                   d.Loc.notes
-                   @ [ Loc.note first.Tast.loc
-                         (Printf.sprintf
-                            "this array's first element is %s, so every \
-                             element is"
-                            (Types.to_string first.Tast.ty)) ] })
-      in
-      first :: map_lr one rest
-  in
+  match elem_want, items with
+  | None, _ :: _ ->
+    (match arr_elem_type ctx items with
+     | Some t ->
+       let n = Int64.of_int (List.length items) in
+       expect ctx loc ~want
+         (check_arr ctx ~want:(Some (Types.Array (n, t))) loc items)
+     | None ->
+       expect ctx loc ~want
+         (dyn_vec ctx loc (map_lr (fun i -> check ctx ~want:Types.Dyn i) items)))
+  | _ ->
+  let items = map_lr (fun i -> check ctx ?want:elem_want i) items in
   let n = Int64.of_int (List.length items) in
   let elem =
     match elem_want, items with
     | Some t, _ -> t
     | None, first :: _ -> first.Tast.ty
     | None, [] ->
-      fail loc "an empty array literal needs a type — annotate the binding"
+      fail loc
+        "an empty array literal needs a type — use it where one is expected, \
+         or name it, as in (the [0 i32] [])"
   in
   List.iter
     (fun (i : Tast.expr) ->
@@ -5565,6 +5519,96 @@ and check_arr ctx ~want loc items =
      an array literal does not satisfy a slice expectation. *)
   expect ctx loc ~want (mk loc (Types.Array (n, elem)) (Tast.Arr items))
 
+(* The element type of an array literal nothing outside it names, or [None]
+   for a dyn vector. Every element is looked at on its own terms first, by
+   [probe], so nothing here is checked for real — [check_arr] does that once,
+   at the answer.
+
+   Elements that agree are a typed array: one type, or numbers that meet at
+   the wider of them the way two operands of [+] do. A literal takes the
+   others' type if it fits it, so [[(f32 1.0) 2.5]] is an [[2 f32]] and
+   [[(u8 1) 300]] an [[2 i32]]. An element that cannot be checked without
+   being told what it is — [None], a bare struct — takes the same type.
+   Elements that do not agree — [[10 "Hi"]], a dyn beside anything that is
+   not one — are a dyn vector, which is what the same brackets are where a
+   dyn is expected. *)
+and arr_elem_type ctx (items : Ast.expr list) : Types.t option =
+  let natural (i : Ast.expr) =
+    match i.Ast.e with
+    (* Refused with no want, and only a u64 holds one. *)
+    | Ast.UInt _ -> Some (Types.Int Types.U64)
+    | _ -> probe ctx i.Ast.loc (fun () -> (check ctx i).Tast.ty)
+  in
+  let fits t (i : Ast.expr) =
+    probe ctx i.Ast.loc (fun () -> ignore (check ctx ~want:t i)) <> None
+  in
+  let lits, rest = List.partition lone_literal items in
+  let typed, needs =
+    List.partition_map
+      (fun i ->
+         match natural i with Some t -> Left (i, t) | None -> Right i)
+      rest
+  in
+  let tys =
+    List.filter (fun t -> t <> Types.Never) (List.map snd typed)
+  in
+  let lit_tys = List.filter_map natural lits in
+  let join_all = function
+    | [] -> None
+    | t :: ts ->
+      List.fold_left
+        (fun acc t -> Option.bind acc (fun a -> Types.join a t)) (Some t) ts
+  in
+  let mixed_dyn =
+    List.mem Types.Dyn tys
+    && (List.exists (fun t -> t <> Types.Dyn) tys || lits <> [])
+  in
+  let all_fit t = List.for_all (fits t) lits && List.for_all (fits t) needs in
+  (* A candidate the literals do not all fit is widened by the ones that do
+     not, once: [[x 2.5]] over an i32 [x] meets at f64. *)
+  let settle = function
+    | None -> None
+    | Some t when all_fit t -> Some t
+    | Some t ->
+      let t' =
+        List.fold_left
+          (fun acc i ->
+             if fits t i then acc
+             else Option.bind acc (fun a -> Option.bind (natural i) (Types.join a)))
+          (Some t) lits
+      in
+      (match t' with
+       | Some t' when not (Types.equal t' t) && all_fit t' -> Some t'
+       | _ -> None)
+  in
+  let candidates =
+    if tys <> [] then [ join_all tys ]
+    else join_all lit_tys :: List.map Option.some lit_tys
+  in
+  if mixed_dyn then None
+  else if tys = [] && lits = [] then
+    (match typed, needs with
+     | _ :: _, [] -> Some Types.Never
+     (* Nothing here says what any of them is. The first one's own refusal is
+        the one worth reading. *)
+     | _, first :: _ -> ignore (check ctx first); None
+     | [], [] -> None)
+  else List.fold_left
+      (fun found c -> match found with Some _ -> found | None -> settle c)
+      None candidates
+
+(* A dyn vector built where it stands from elements already checked at dyn:
+   the runtime's own vec, pushed to in order. *)
+and dyn_vec ctx loc (items : Tast.expr list) =
+  let v = fresh_slot ctx Types.Dyn in
+  let vval = mk loc Types.Dyn (Tast.Local v) in
+  let pushes =
+    List.map (fun x -> rt loc Types.Unit "flan_dyn_push" [ vval; x; here loc ])
+      items
+  in
+  mk loc Types.Dyn
+    (Tast.Let ([ (v, rt loc Types.Dyn "flan_dyn_vec_new" []) ], pushes @ [ vval ]))
+
 (* ── (array-fill [r c] v) and (array-gen [r c] f) ──────────────────────
 
    TODO.org, "A value-producing array constructor". [(array 4 T)] is
@@ -5683,6 +5727,59 @@ and array_build ctx loc ns elem ~pre ~element =
     (Tast.Let (pre @ [ (arr, mk loc aty (Tast.Zero aty)) ],
                [ nest ns islots; arrv ]))
 
+(* (the T e): [e] with [T] as its expectation, which is every conversion an
+   annotation would make — a literal built at T, a narrower number widened —
+   and nothing more. A dyn operand is the exception: an expectation would
+   unbox it and trap at run time on a mismatch, and [the] is a statement about
+   the type rather than a conversion, so it is refused and the cast named.
+
+   [(the [T] [...])] asks for the literal's element type and answers the
+   [n T] the literal is, since an array literal is never a slice. *)
+and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) =
+  let ty = resolve ctx.env t in
+  let is_nil = match v.Ast.e with Ast.Var "nil" -> true | _ -> false in
+  if ty <> Types.Dyn && not is_nil
+     && probe ctx loc (fun () -> (check ctx v).Tast.ty) = Some Types.Dyn
+  then begin
+    let tn = Types.to_string ty in
+    let numeric = match ty with Types.Int _ | Types.Float _ -> true | _ -> false in
+    if numeric then
+      fail v.Ast.loc
+        "the checks a value as %s and does not convert one, and this is a dyn \
+         — %s"
+        tn
+        (match spell_arg "" v with
+         | "" -> Printf.sprintf "convert it with the %s cast instead" tn
+         | s -> Printf.sprintf "write (%s %s) to convert it" tn s)
+    else
+      fail v.Ast.loc
+        "the checks a value as %s and does not convert one, and this is a dyn \
+         — a dyn becomes a %s where a %s is passed, returned or stored"
+        tn tn tn
+  end;
+  let r =
+    match ty, v.Ast.e with
+    | Types.Slice elem, Ast.Arr items ->
+      check_arr ctx
+        ~want:(Some (Types.Array (Int64.of_int (List.length items), elem)))
+        v.Ast.loc items
+    | _ -> expect ctx v.Ast.loc ~want:(Some ty) (check ctx ~want:ty v)
+  in
+  expect ctx loc ~want r
+
+(* [f] run for its answer alone: whatever it wrote into the context is put
+   back whether it succeeded or not, so a form can be checked once to see what
+   it is and then checked again for real. [None] if it was refused. *)
+and probe : 'a. ctx -> Loc.t -> (unit -> 'a) -> 'a option = fun ctx loc f ->
+  let answer = ref None in
+  (match
+     trial ctx (fun () ->
+       answer := Some (f ());
+       raise (Loc.Error (Loc.diag loc "probe")))
+   with
+   | _ -> ());
+  !answer
+
 and check_array_fill ctx ~want loc dims v =
   let ns = array_dims ctx loc dims in
   let elem_want = array_elem_want (List.length ns) want in
@@ -7285,7 +7382,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
      | _ ->
        fail loc
          "zeroed needs to know the type it is zeroing — use it where one is \
-          expected, as in (set grid (zeroed))")
+          expected, or name it, as in (the [4 i32] (zeroed))")
 
   (* [zeroed]'s two siblings, and the same shape exactly: a value of whatever
      type is expected of it, so [(set grid (filled 0xFF))] is how a place is
@@ -7382,7 +7479,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
      | _ ->
        fail loc
          "%s needs to know the type it is filling — use it where one is \
-          expected, as in (set grid (%s))"
+          expected, or name it, as in (the [4 u32] (%s))"
          name (if is_byte then "filled 0xFF" else name))
 
   (* The one half of a destructuring [let] that [Parse] cannot do on its own.
@@ -10400,9 +10497,9 @@ let builtins : (string * string * string) list =
       not hold. It becomes None where an (Option T) is wanted, and stays dyn \
       everywhere else.");
     ("None", "None (Option T)",
-     "The absent Option. It takes its type from its context — a return type \
-      or an annotated binding — because nothing about the word says what it \
-      is an Option of.");
+     "The absent Option. It takes its type from its context — a return type, \
+      a parameter, or (the (Option i32) None) — because nothing about the \
+      word says what it is an Option of.");
     ("context/allocator", "context/allocator Allocator",
      "The allocator in effect here: what with-allocator rebinds, and what an \
       allocating operation uses when none is named at the site.");
diff --git a/lib/load.ml b/lib/load.ml
index a3f28a9b..0c575dde 100644
--- a/lib/load.ml
+++ b/lib/load.ml
@@ -315,6 +315,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr =
        other reference to it. *)
     | Ast.ArrayFill (ds, v) -> Ast.ArrayFill (List.map (rename_len owned alias) ds, go v)
     | Ast.ArrayGen (ds, v) -> Ast.ArrayGen (List.map (rename_len owned alias) ds, go v)
+    | Ast.The (t, v) -> Ast.The (rename_texpr owned alias t, go v)
     | Ast.Fn (ps, body) ->
       Ast.Fn (ps, List.map (rename_expr owned alias (ps @ bound)) body)
     | Ast.Dotimes (l, i, b, body) ->
@@ -790,6 +791,7 @@ let rec expr_uses acc (e : Ast.expr) =
   | Ast.MapLit (_, kvs) -> List.iter (fun (k, v) -> go k; go v) kvs
   | Ast.Arr items -> gos items
   | Ast.ArrayOf t | Ast.TypeArg t -> texpr_uses acc t
+  | Ast.The (t, v) -> texpr_uses acc t; go v
   (* A dimension written as a name is a use of that constant, exactly as it is
      inside [Tarray]. *)
   | Ast.ArrayFill (ds, v) | Ast.ArrayGen (ds, v) ->
diff --git a/lib/parse.ml b/lib/parse.ml
index c380830b..1feba6e7 100644
--- a/lib/parse.ml
+++ b/lib/parse.ml
@@ -496,6 +496,15 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
      array of integers — the wrong reading, and a silent one. Read here, the
      brackets are [len]s: the same integer-or-constant's-name the [n T] type
      spelling takes, refused by [len] when they are anything else. *)
+  (* ── (the T e) ──────────────────────────────────────────────────── *)
+  | Sym "the" ->
+    (match args with
+     | [ t; v ] -> mk (Ast.The (texpr t, expr v))
+     | _ ->
+       fail f
+         "the is (the TYPE value), as in (the u8 0) — the value, checked as \
+          a TYPE")
+
   | Sym (("array-fill" | "array-gen") as which) ->
     let usage () =
       fail f
diff --git a/test/programs/array-first-element.flan b/test/programs/array-first-element.flan
index a667a60a..e50876e8 100644
--- a/test/programs/array-first-element.flan
+++ b/test/programs/array-first-element.flan
@@ -1,6 +1,6 @@
 ;;;; An array literal with nothing outside it saying what its elements are
-;;;; takes that from its first element: [(f32 1.0) 2.5] is a [2 f32], and the
-;;;; 2.5 is an f32 literal rather than an f64 refused for not being one.
+;;;; takes that from the elements that are not literals: [(f32 1.0) 2.5] is a
+;;;; [2 f32], and the 2.5 is an f32 literal rather than an f64.
 (defn sum3 [a [3 f32]] f32 (+ (at a 0) (at a 1) (at a 2)))
 
 (defn main [] i32
diff --git a/test/programs/array-mixed.flan b/test/programs/array-mixed.flan
new file mode 100644
index 00000000..f4238c73
--- /dev/null
+++ b/test/programs/array-mixed.flan
@@ -0,0 +1,59 @@
+;;;; An array literal with nothing outside it naming a type: elements that agree
+;;;; are a typed array, numbers meeting at the wider and a literal taking the
+;;;; others' type, and elements that do not are a dyn vector.
+(defstruct P [x i32 y i32])
+(defn mixed [] i32
+  (let [x (i32 4)
+        a [(f32 1.0) 2.5 3.25]
+        b [(i64 1) 2 3]
+        c [(u8 1) 300]
+        d [x 2.5]
+        e [1 18446744073709551615]
+        f [10 "Hi"]
+        g [nil 1]
+        h [None (Some 3)]
+        i [(P 1 2) {.x 3 .y 4}]
+        j [[1 2] [3 4]]
+        k [1 2.5]
+        m [x (i64 5)]
+        dd [:a "b" 3]]
+    (println (length a))
+    (println (+ (at c 1) (i32 (at c 0))))
+    (println (at d 1))
+    (println (at e 1))
+    (println f)
+    (println g)
+    (println (length f))
+    (println (match (at h 1) None 0 (Some v) v))
+    (println (.y (at i 1)))
+    (println (at (at j 1) 0))
+    (println (at k 0))
+    (println (+ (at m 0) (i64 9000000000)))
+    (println dd))
+  0)
+
+;; (the T e) gives any expression its type.
+(defn the-forms [] i32
+  (let [a (the u8 200)
+        b (the i64 5000000000)
+        c (the f32 2.5)
+        d (the [3 f32] [1 2 3.5])
+        e (the [f32] [1 2.5])
+        f (the (Option i32) None)
+        g (the (Option i32) nil)
+        h (the dyn 3)
+        n (the i64 (+ (the i32 1) 2))
+        v (the (Vec i32) (vec-new))]
+    (println (+ a (u8 55)))
+    (println b)
+    (println (* c (f32 2.0)))
+    (println (+ (at d 0) (at d 2)))
+    (println (length e))
+    (println (match f None 0 (Some x) x))
+    (println (match g None 7 (Some x) x))
+    (println h)
+    (println n)
+    (println (length v)))
+  0)
+
+(defn main [] i32 (mixed) (the-forms))
diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml
index 46eae007..deb4807a 100644
--- a/test/test_acceptance.ml
+++ b/test/test_acceptance.ml
@@ -551,13 +551,22 @@ let () =
       fpu_out;
     outputs ~x86:true "a pointer and a union filled, x86"
       "programs/fill-ptr-union.flan" fpu_out;
-    (* An array literal takes its element type from its first element when
-       nothing outside it names one. *)
+    (* A literal element takes its type from the other elements when nothing
+       outside the array names one. *)
     let first_out = "3\n6.75\n9000000002\n255\n" in
     outputs "an array literal's first element types the rest"
       "programs/array-first-element.flan" first_out;
     outputs ~x86:true "an array literal's first element types the rest, x86"
       "programs/array-first-element.flan" first_out;
+    (* An array literal whose elements agree is typed and one whose elements
+       mix is a dyn vector; (the T e) gives any expression its type. *)
+    let mixed_out =
+      "3\n301\n2.5\n18446744073709551615\n[ 10 \"Hi\"]\n[ nil 1]\n2\n3\n4\n\
+       3\n1\n9000000004\n[ :a \"b\" 3]\n\
+       255\n5000000000\n5\n4.5\n2\n0\n7\n3\n3\n0\n" in
+    outputs "mixed array literals and the" "programs/array-mixed.flan" mixed_out;
+    outputs ~x86:true "mixed array literals and the, x86"
+      "programs/array-mixed.flan" mixed_out;
     (* (- x) negates, on every numeric type, a type variable and a dyn. *)
     let neg_out =
       "-3\n7\n-2.5\n-inf\n-1.5\n255\n-4\n-2.5\n-inf\n-9000000000\n\
diff --git a/test/test_flan.ml b/test/test_flan.ml
index f6c8cb19..74e694ba 100644
--- a/test/test_flan.ml
+++ b/test/test_flan.ml
@@ -1214,7 +1214,7 @@ let () =
   accepts "return type types the literal" "(defn f [] u8 0)";
   accepts "return type types None"        "(defn f [] (Option f64) None)";
   rejects_check "bare None has no type"   "(defconst x None)"
-    ~needle:"what None is an Option of";
+    ~needle:"(the (Option i32) None)";
   accepts "param types the literal"
     "(defn g [x u8] ()) (defn f [] () (g 3))";
   rejects_check "wrong argument type"
@@ -2905,7 +2905,7 @@ let () =
     ~needle:"needs to know the type it is filling";
   rejects_check "a dead-beef in a position with no expected type"
     "(defn f [] () (print (dead-beef)))"
-    ~needle:"needs to know the type it is filling";
+    ~needle:"(the [4 u32] (dead-beef))";
   (* The byte is a u8 and the ordinary literal rule applies to it — there is
      no range check of this builtin's own, and there does not need to be. *)
   rejects_check "a fill byte out of range"
@@ -6365,17 +6365,49 @@ let () =
   parse_rejects "the $ refusal names the bare spelling"
     "(defn $foo [x i32] i32 x)" ~needle:"Name it foo";
 
-  (* ── An array literal's first element types the rest ───────────── *)
-  accepts "an f32 array literal from its first element"
-    "(defn main [] i32 (let [a [(f32 1.0) 2.5]] (i32 (length a))))";
-  (match checked "(defn main [] i32 (let [a [(u8 1) 256]] 0))" with
-   | _ -> check "an element that does not fit the first element's type" false
-   | exception Loc.Error d ->
-     check "the refusal says the first element set the type"
-       (List.exists
-          (fun (n : Loc.note) ->
-             contains n.Loc.nmsg "this array's first element is u8")
-          d.Loc.notes));
+  (* ── An array literal with nothing outside it naming a type ────── *)
+  infers "a literal takes the other elements' type" "[(f32 1.0) 2.5]" "[2 f32]";
+  infers "numbers meet at the wider" "[(u8 1) 256]" "[2 i32]";
+  infers "an int and a float literal meet at f64" "[1 2.5]" "[2 f64]";
+  infers "a wide literal makes the array u64" "[1 18446744073709551615]" "[2 u64]";
+  infers "None takes the other element's Option" "[None (Some 1)]" "[2 (Option i32)]";
+  infers "a number and a string are a dyn vector" "[10 \"Hi\"]" "dyn";
+  infers "nil beside a number is a dyn vector" "[nil 1]" "dyn";
+  infers "two dyns are a typed array of dyn" "[nil nil]" "[2 dyn]";
+  infers "the names the element type of a mixed literal" "(the [dyn] [1 2.5])" "[2 dyn]";
+  infers "the with a slice type gives the literal's array type"
+    "(the [f32] [1 2.5])" "[2 f32]";
+  rejects_check "every element needing a type names the first's refusal"
+    "(defn main [] i32 (let [a [None None]] 0))"
+    ~needle:"what None is an Option of";
+
+  (* ── (the T e) ─────────────────────────────────────────────────── *)
+  infers "the gives a literal its type" "(the u8 200)" "u8";
+  infers "the widens as an annotation does" "(the i64 (the i32 1))" "i64";
+  rejects_check "the does not narrow"
+    "(defn f [x i64] i32 (the i32 x))" ~needle:"expected i32, found i64";
+  rejects_check "the refuses a dyn and names the cast"
+    "(defn f [x dyn] i32 (the i32 x))" ~needle:"write (i32 x) to convert it";
+  accepts "the cast that refusal names compiles" "(defn f [x dyn] i32 (i32 x))";
+  rejects_check "the refuses a dyn at a type that has no cast"
+    "(defn f [x dyn] string (the string x))"
+    ~needle:"a dyn becomes a string where a string is passed";
+  accepts "the at an Option takes nil" "(defn f [] (Option i32) (the (Option i32) nil))";
+  parse_rejects "the takes a type and a value" "(defn f [] i32 (the i32))"
+    ~needle:"the is (the TYPE value)";
+  (* The refusals of a form with no type of its own name the as a way out, and
+     the spellings they name compile. *)
+  rejects_check "an empty array literal names the"
+    "(defn main [] i32 (let [a []] 0))" ~needle:"(the [0 i32] [])";
+  accepts "the empty array that refusal names compiles"
+    "(defn main [] i32 (let [a (the [0 i32] [])] (length a)))";
+  accepts "the None that refusal names compiles"
+    "(defn main [] i32 (let [a (the (Option i32) None)] 0))";
+  accepts "the zeroed that refusal names compiles"
+    "(defn main [] i32 (let [a (the [4 i32] (zeroed))] (at a 0)))";
+  accepts "the fills that refusal names compile"
+    "(defn main [] i32 (let [a (the [4 u32] (filled 0xFF)) \
+                             b (the [4 u32] (dead-beef))] 0))";
 
   (* ── A wide literal's follow-ups ──────────────────────────────── *)
   parse_rejects "a wide enum member is refused for its range"
@@ -6396,10 +6428,7 @@ let () =
     "(defmacro idm [x] x) \
      (defn f [] u64 (idm 18446744073709551615))";
 
-  rejects_check "a wide element after a narrow first names the u64 array"
-    "(defn main [] i32 (let [a [1 18446744073709551615]] 0))"
-    ~needle:"write the first element as (u64 1) for an array of u64";
-  accepts "the u64 array that refusal names compiles"
+  accepts "a u64 array with a cast first element"
     "(defn main [] i32 (let [a [(u64 1) 18446744073709551615]] 0))";
 
   (* ── Suggestions that compile ─────────────────────────────────── *)

From 2ea47f91eb0ead61856c05eee235ec222b9376b3 Mon Sep 17 00:00:00 2001
From: Joseph Ferano 
Date: Fri, 25 Sep 2026 11:51:58 +0700
Subject: [PATCH 07/16] A program's function named as a prelude function takes
 the name over for its own file, with a warning, and the prelude's own calls
 keep the prelude's

---
 emacs/flan-mode.el                |  2 +-
 lib/check.ml                      | 54 +++++++++++++++++++++++++++++--
 lib/load.ml                       | 31 ++++++++++++++++++
 test/programs/shadow-prelude.flan | 13 ++++++++
 test/test_acceptance.ml           |  6 ++++
 test/test_flan.ml                 | 18 +++++++++++
 6 files changed, 121 insertions(+), 3 deletions(-)
 create mode 100644 test/programs/shadow-prelude.flan

diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el
index f5a45fac..64800b1c 100644
--- a/emacs/flan-mode.el
+++ b/emacs/flan-mode.el
@@ -129,7 +129,7 @@
 (defconst flan--special
   '("quote" "do" "let" "if" "when" "cond" "and" "or"
     "while" "until" "break" "continue" "return" "set"
-    "array" "array-fill" "array-gen" "match" "fn" "dotimes" "loop" "recur"
+    "array" "array-fill" "array-gen" "the" "match" "fn" "dotimes" "loop" "recur"
     "defer" "some" "try" "signal" "error"
     "handler-bind" "handler-case" "restart-case" "invoke-restart")
   "The heads `Parse.form' dispatches on — the forms with a meaning of their own.
diff --git a/lib/check.ml b/lib/check.ml
index f78661da..fb5aa531 100644
--- a/lib/check.ml
+++ b/lib/check.ml
@@ -12436,9 +12436,59 @@ let escape_check (fn : Tast.fn) =
      deny "a return" [ last ]
    | _ -> ())
 
+(* A program's function named as a prelude function takes the name over, the
+   way a definition of a builtin's name does: every call written in the file
+   that defines it reaches the program's, and every call anywhere else — the
+   prelude's own among them, which were written against the prelude's
+   signature — keeps reaching the prelude's. The prelude's is renamed out of
+   the way, under a qualifier no source can spell, rather than dropped.
+   Functions only: a type or a global of the prelude's name is still defined
+   twice. *)
+let prelude_alias = "prelude~"
+
+let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) =
+  let fn_name (d : Ast.decl) =
+    match d.Ast.d with
+    | Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> Some fn.Ast.name
+    | _ -> None
+  in
+  let theirs = List.filter_map fn_name prelude in
+  let taken =
+    List.filter_map
+      (fun (d : Ast.decl) ->
+         match fn_name d with
+         | Some n when List.mem n theirs -> Some (n, d.Ast.dloc)
+         | _ -> None)
+      decls
+  in
+  let warnings =
+    List.map
+      (fun (n, at) ->
+         Loc.diag ~kind:"check/shadows-prelude" at
+           (Printf.sprintf
+              "%s shadows the prelude's %s — every call in this file now \
+               reaches your definition"
+              n n))
+      taken
+  in
+  let prelude, decls =
+    List.fold_left
+      (fun (prelude, decls) (n, (at : Loc.t)) ->
+         ( List.map (Load.rename_refs [ n ] prelude_alias) prelude,
+           List.map
+             (fun (d : Ast.decl) ->
+                if String.equal d.Ast.dloc.Loc.file at.Loc.file then d
+                else Load.rename_refs [ n ] prelude_alias d)
+             decls ))
+      (prelude, decls) taken
+  in
+  (prelude @ decls, warnings)
+
 let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env =
   let env = new_env () in
-  let decls = Parse.program (Prelude.forms ()) @ decls in
+  let decls, prelude_warnings =
+    shadow_prelude (Parse.program (Prelude.forms ())) decls
+  in
   (* Before anything is collected: every (declare-c ...) becomes an ordinary
      flattened [declare] with a Flan [defn] over it, and the C that does the
      flattening comes back to be compiled into the build. Nothing below this
@@ -12461,7 +12511,7 @@ let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env =
     (fun (d : Loc.diag) ->
        prerr_endline
          (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
-    (shadowed_builtins decls);
+    (shadowed_builtins decls @ prelude_warnings);
   (* Pass one, and it stops at the first thing it refuses. That is not
      laziness: every name, type and signature in the file comes from here, so a
      declaration this pass could not make sense of leaves a hole that pass two
diff --git a/lib/load.ml b/lib/load.ml
index 0c575dde..10f20bd3 100644
--- a/lib/load.ml
+++ b/lib/load.ml
@@ -555,6 +555,37 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
   in
   { d with Ast.d = k }
 
+(* [qualify_decl]'s rename of every use of an [owned] name, without the rename
+   of the declaration's own name unless that name is one of them. How a
+   program's definition of a name the prelude also defines takes the name
+   over: the prelude's declaration and its uses outside the program's file
+   move to the qualified name, and the program's file keeps the bare one. *)
+let rename_refs owned alias (d : Ast.decl) : Ast.decl =
+  match Ast.declared_name d, d.Ast.d with
+  | _, (Ast.Package _ | Ast.Import _) -> d
+  | Some n, _ when List.mem n owned -> qualify_decl owned alias d
+  | _ ->
+    let q = qualify_decl owned alias d in
+    let named (fn : Ast.fn) (o : Ast.fn) = { fn with Ast.name = o.Ast.name } in
+    let k =
+      match q.Ast.d, d.Ast.d with
+      | Ast.Declare (fn, c), Ast.Declare (o, _) -> Ast.Declare (named fn o, c)
+      | Ast.DeclareC (fn, c), Ast.DeclareC (o, _) -> Ast.DeclareC (named fn o, c)
+      | Ast.Defn fn, Ast.Defn o -> Ast.Defn (named fn o)
+      | Ast.Defgeneric fn, Ast.Defgeneric o -> Ast.Defgeneric (named fn o)
+      | Ast.Defmulti fn, Ast.Defmulti o -> Ast.Defmulti (named fn o)
+      | Ast.Defenum (_, ms), Ast.Defenum (n, _) -> Ast.Defenum (n, ms)
+      | Ast.Defalias (_, t), Ast.Defalias (n, _) -> Ast.Defalias (n, t)
+      | Ast.Defconst (_, t, v), Ast.Defconst (n, _, _) -> Ast.Defconst (n, t, v)
+      | Ast.Defstruct (_, fs), Ast.Defstruct (n, _) -> Ast.Defstruct (n, fs)
+      | Ast.Defunion (_, fs), Ast.Defunion (n, _) -> Ast.Defunion (n, fs)
+      | Ast.Defdata (_, vs), Ast.Defdata (n, _) -> Ast.Defdata (n, vs)
+      | Ast.Defvar (_, t, i, r), Ast.Defvar (n, _, _, _) -> Ast.Defvar (n, t, i, r)
+      | Ast.Defclass (_, ss), Ast.Defclass (n, _) -> Ast.Defclass (n, ss)
+      | k, _ -> k
+    in
+    { q with Ast.d = k }
+
 (* ── Qualifying a package's macros ──────────────────────────────────
    The rename above works over the Ast and a macro cannot go that way. By the
    time [Parse] is finished with a [defmacro] its quasiquote has been desugared
diff --git a/test/programs/shadow-prelude.flan b/test/programs/shadow-prelude.flan
new file mode 100644
index 00000000..a9d628ae
--- /dev/null
+++ b/test/programs/shadow-prelude.flan
@@ -0,0 +1,13 @@
+;;;; A program's function named as a prelude function takes the name over for
+;;;; the calls in its own file, and the prelude's own calls keep the prelude's:
+;;;; ceil-f32 is written over the prelude's floor-f32, and still answers 3.
+(defn abs-f32 [v f32] f32 (if (< v 0.0) (- v) (+ v (f32 100.0))))
+(defn floor-f32 [x f32] f32 (f32 999.0))
+(defn abs [x i32] i32 (* x 10))
+(defn main [] i32
+  (println (abs-f32 (f32 -2.5)))
+  (println (abs-f32 (f32 2.5)))
+  (println (floor-f32 (f32 2.3)))
+  (println (ceil-f32 (f32 2.3)))
+  (println (abs -3))
+  0)
diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml
index deb4807a..c6660228 100644
--- a/test/test_acceptance.ml
+++ b/test/test_acceptance.ml
@@ -567,6 +567,12 @@ let () =
     outputs "mixed array literals and the" "programs/array-mixed.flan" mixed_out;
     outputs ~x86:true "mixed array literals and the, x86"
       "programs/array-mixed.flan" mixed_out;
+    (* A program's function named as a prelude function takes the name over
+       for its own file; the prelude's own calls keep the prelude's. *)
+    let sp_out = "2.5\n102.5\n999\n3\n-30\n" in
+    outputs "a prelude function shadowed" "programs/shadow-prelude.flan" sp_out;
+    outputs ~x86:true "a prelude function shadowed, x86"
+      "programs/shadow-prelude.flan" sp_out;
     (* (- x) negates, on every numeric type, a type variable and a dyn. *)
     let neg_out =
       "-3\n7\n-2.5\n-inf\n-1.5\n255\n-4\n-2.5\n-inf\n-9000000000\n\
diff --git a/test/test_flan.ml b/test/test_flan.ml
index 74e694ba..636c1f36 100644
--- a/test/test_flan.ml
+++ b/test/test_flan.ml
@@ -5277,6 +5277,24 @@ let () =
      | exception Loc.Error _ -> false);
   check "a program that shadows nothing is warned at not at all"
     (Check.shadowed_builtins (program "(defn f [] i32 1)") = []);
+  (* A prelude function's name is taken over the same way, for the calls in
+     the defining file. *)
+  let prelude_src = "(defn abs-f32 [v f32] f32 v)" in
+  (match
+     snd (Check.shadow_prelude (Parse.program (Prelude.forms ()))
+            (program prelude_src))
+   with
+   | [ d ] ->
+     check "a defn of a prelude function's name warns once"
+       (d.Loc.kind = "check/shadows-prelude"
+        && d.Loc.dmsg
+           = "abs-f32 shadows the prelude's abs-f32 — every call in this file \
+              now reaches your definition")
+   | _ -> check "a defn of a prelude function's name warns exactly once" false);
+  accepts "a defn of a prelude function's name is not defined twice"
+    prelude_src;
+  rejects_check "a struct of a prelude type's name is still defined twice"
+    "(defstruct Form [x i32])" ~needle:"Form is defined twice";
   (* An operator is a builtin like any other and shadows like any other.
      Pinned in both halves because it is the case most likely to be thought
      of as special and quietly excepted later: the warning is the same

From e0af3c9b1d652429ef7adcf8f0a86eadb2811084 Mon Sep 17 00:00:00 2001
From: Joseph Ferano 
Date: Fri, 25 Sep 2026 11:55:40 +0700
Subject: [PATCH 08/16] A method of update-instance-for-redefined-class runs on
 each instance as it migrates, and one that signals offers migrate-by-name

---
 TODO.org                    |  42 +++-------
 lib/classes.ml              |  60 ++++++++++++++
 lib/emit.ml                 |   1 +
 lib/session.ml              |  20 ++++-
 runtime/flan_dyn.c          | 148 +++++++++++++++++++++++++++++++++-
 runtime/flan_dyn.h          |   9 ++-
 runtime/flan_rt.c           |  20 +++++
 test/programs/dev-hook.flan |  21 +++++
 test/test_dev.ml            | 156 ++++++++++++++++++++++++++++++++++++
 test/test_session.ml        |  19 +++++
 vendor/agent/flan_agent.c   |  44 ++++++++++
 web/index.html              |   9 ++-
 12 files changed, 513 insertions(+), 36 deletions(-)
 create mode 100644 test/programs/dev-hook.flan

diff --git a/TODO.org b/TODO.org
index 081c65c5..61cc6ec3 100644
--- a/TODO.org
+++ b/TODO.org
@@ -549,13 +549,10 @@ dispatch values. With single dispatch on literal values there is no specificity
 question, and inheritance or multiple dispatch would create one. Unknown-slot
 checking needs class-typed tracking the dyn side deliberately does not have.
 
-** NEXT update-instance-for-redefined-class, the user hook
-Decided 2026-09-25: build it after typed class slots land, shaped for the REPL — written and installed from a live session as a one-time "here is how to migrate this", without restarting. It receives the instance with the added and discarded slots and their old values, and runs at each instance's lazy migration. A hook that signals parks in the break buffer with a restart that falls back to name-matching migration.
-Left out of v1 because name matching is the half that makes redefinition usable
-and the hook is what makes it expressive. The obvious spelling is a generic riding
-the dispatch that exists, and the migration already computes both the added and
-the discarded lists. Rolling a failed migration back becomes a real question the
-day this lands.
+** DONE update-instance-for-redefined-class, the user hook
+CLOSED: [2026-09-25]
+Taking =migrate-by-name= keeps the name-matched instance, not SBCL's obsolete one,
+and retries nothing; a transfer from the method to a restart below it traps.
 
 ** DONE The module system stays directory-as-package
 Several files in one directory are one module; a loose file is a module of one,
@@ -1367,7 +1364,7 @@ sibling".
 
 ** DONE A redefined defclass migrates its instances lazily
 CLOSED: [2026-09-20]
-CLHS 4.3.6 minus the user hook. Nothing is enumerated and no heap is walked — the
+CLHS 4.3.6. Nothing is enumerated and no heap is walked — the
 redefinition is constant time and each instance pays once, at its next touch.
 Neither printer migrates, so a stale instance shows its old slots to the editor
 until something touches it. The registry is advisory: a key the class never
@@ -1976,18 +1973,10 @@ specification's own branch — the flag is the command and the printed shape is
 error pattern, so anyone who wants one has the four lines, and the manual carries
 them.
 
-** NEXT defclass slots take types, checked on write
-Decided 2026-09-25: slots are name/type pairs checked on write; an untyped slot stays legal and holds any =dyn=. A migration keeps a stored value that no longer fits the new type, warns once, and the next write is checked. One lane with the =set= entry below.
-=(defclass State [pause bool step bool])= reads as four untyped slots and
-reports a duplicate =bool=. Wanted: the slot list is name/type pairs, as CLOS
-does it. The type is a declaration about the values and not a layout — an
-instance stays a map, so redefinition and lazy migration are unchanged. SBCL
-checks it on write (=src/pcl/slots.lisp:160=, the typecheck before the store),
-which is where the bad value is, so =put= is the site here.
-
-Open: what migration does with a stored value that no longer fits a changed
-slot type, and whether an untyped slot stays legal (it should — =dyn= is a type
-and writing nothing should mean it).
+** DONE defclass slots take types, checked on write
+CLOSED: [2026-09-25]
+The constructor's parameters stay dyn and every store checks at run time; no int
+converts into a float slot, nil does not fit a typed slot, and a class is no slot type.
 
 ** NEXT println takes up to a second to appear
 Decided 2026-09-25: the daemon pushes program output on the editor's connection as it is written. Rules out a faster poll.
@@ -1997,15 +1986,10 @@ composed, so anything the program prints after that waits for the next tick.
 Polling faster costs a request a second for nothing most of the time; the
 daemon pushing on its own connection is the other shape. Decide which.
 
-** NEXT set writes a class slot; put is for maps
-Decided 2026-09-25: as written; one lane with typed slots.
-=put= exists because an absent map key has no location to store into, which is
-why =(get m k)= is refused as a place (=lib/parse.ml:1159=). A class instance is
-not in that situation: its slots are fixed by the =defclass=, so a declared slot
-always exists and =(set (get state :pause) true)= is a field store like
-=(set (.velocity g) 0.0)=. Make =set= take it, and leave =put= to maps, where
-insertion is real. Writing an undeclared slot through =set= is then a refusal
-naming the class.
+** DONE set writes a class slot; put is for maps
+CLOSED: [2026-09-25]
+=put= on an instance still checks a declared slot's type and still inserts an
+undeclared key; only =set= refuses one, since a slot it writes has to exist.
 
 ** NEXT update: change a place by applying a function to it
 Decided 2026-09-25: every place evaluates each of its subexpressions once, C's compound-assignment rule, which also fixes =++= and =--=; =update= is built on that. Rules out refusing side effects in a place.
diff --git a/lib/classes.ml b/lib/classes.ml
index 15b9440a..8a109288 100644
--- a/lib/classes.ml
+++ b/lib/classes.ml
@@ -49,6 +49,45 @@ let dispatch_slot = "~dispatch"
    the prelude; this is the only place that builds one. *)
 let no_method = "NoMethod"
 
+(* CLHS's update-instance-for-redefined-class: what a redefined class does to
+   each of its instances, run once per instance at the first [get], [put] or
+   [set] that reaches it after the redefinition. By then the instance already
+   holds the new slots, each kept one with its old value and each gained one
+   nil; [added] is a vec of the gained slots' keywords and [discarded] a map
+   from each lost slot's keyword to the value it held. A method is written for
+   a class, from a live session, and is how a migration does more than match
+   slots by name:
+
+     (defmethod update-instance-for-redefined-class point [p added discarded]
+       (set (get p :radius) (get discarded :r))
+       nil)
+
+   A method that signals stops in the break loop with [migrate-by-name] on
+   offer, which keeps the instance as name-matching left it.
+
+   The generic and its :else method, which does nothing, are written here
+   rather than in the prelude, and only into a program that has a class or a
+   method of the generic: a program with neither would otherwise carry a dyn
+   function and pay for the collector it never uses. [Session] registers the
+   dispatcher's body with the runtime whenever a reload could have changed
+   it. *)
+let migrate_generic = "update-instance-for-redefined-class"
+
+let migrate_decls loc : Ast.decl list =
+  let p n = { Ast.fname = n; fty = dyn_at loc; floc = loc } in
+  let fn body =
+    { Ast.name = migrate_generic;
+      params = [ p "instance"; p "added"; p "discarded" ]; praw = None;
+      ret = Some (dyn_at loc); fwhere = []; fbody = body; nloc = loc;
+      fprivate = Ast.Exported }
+  in
+  [ { Ast.d = Ast.Defgeneric (fn []); dloc = loc };
+    { Ast.d =
+        Ast.Defmethod
+          { Ast.mgen = migrate_generic; mkey = Ast.Delse;
+            mfn = fn [ ex loc (Ast.Var "nil") ]; mkloc = loc };
+      dloc = loc } ]
+
 (* ── Collecting ────────────────────────────────────────────────────── *)
 
 type generic = {
@@ -348,6 +387,27 @@ let expand (decls : Ast.decl list) : Ast.decl list =
   in
   if not has then decls
   else begin
+    let decls =
+      let wants =
+        List.find_opt
+          (fun (d : Ast.decl) ->
+             match d.Ast.d with
+             | Ast.Defclass _ -> true
+             | Ast.Defmethod m -> String.equal m.Ast.mgen migrate_generic
+             | _ -> false)
+          decls
+      and declared =
+        List.exists
+          (fun (d : Ast.decl) ->
+             match d.Ast.d with
+             | Ast.Defgeneric f -> String.equal f.Ast.name migrate_generic
+             | _ -> false)
+          decls
+      in
+      match wants with
+      | Some d when not declared -> decls @ migrate_decls d.Ast.dloc
+      | _ -> decls
+    in
     let _classes, generics = collect decls in
     List.filter_map
       (fun (d : Ast.decl) ->
diff --git a/lib/emit.ml b/lib/emit.ml
index 13dc14fc..b7eb36a8 100644
--- a/lib/emit.ml
+++ b/lib/emit.ml
@@ -4376,6 +4376,7 @@ declare void @flan_dyn_slot_init(i64, i64, i64)
 declare void @flan_dyn_map_put(i64, i64, i64, ptr, i64)
 declare i64 @flan_dyn_class_of(i64)
 declare void @flan_dyn_class_def(i64, ptr, i64)
+declare void @flan_dyn_class_hook(ptr)
 declare i64 @flan_dyn_kw(ptr, i64)
 declare i64 @flan_dyn_map_get(i64, i64)
 declare void @flan_dyn_map_set(i64, i64, i64)
diff --git a/lib/session.ml b/lib/session.ml
index c682fad7..c5681ead 100644
--- a/lib/session.ml
+++ b/lib/session.ml
@@ -965,7 +965,25 @@ let eval ?(origin = "") ?pause t src : change =
      definition the registry has never seen has to arrive somehow. *)
   let class_body =
     let str s : Tast.expr = { Tast.e = Tast.Str s; ty = Types.String; loc } in
-    List.map
+    (* And the hook a migration calls, re-registered by every module that
+       could have changed what it should be: one carrying a class, since
+       that is what makes migrations happen, and one carrying a method of
+       the generic, since that is what changes the body. The address is the
+       cell's contents at the time the thunk runs — after this module's
+       bodies are published — so it is the body just installed. *)
+    let hook =
+      let n = Classes.migrate_generic in
+      if incoming_classes <> [] || List.mem n names then
+        let ty =
+          Types.CFn ([ Types.Dyn; Types.Dyn; Types.Dyn ], Types.Dyn)
+        in
+        [ { Tast.e =
+              Tast.Prim (Tast.Rt "flan_dyn_class_hook",
+                         [ { Tast.e = Tast.FnAddr (Tast.Fnval n); ty; loc } ]);
+            ty = Types.Unit; loc } ]
+      else []
+    in
+    hook @ List.map
       (fun (n, slots) : Tast.expr ->
          let kw : Tast.expr =
            { Tast.e = Tast.Prim (Tast.Rt "flan_dyn_kw", [ str n ]);
diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c
index d2849afe..99472218 100644
--- a/runtime/flan_dyn.c
+++ b/runtime/flan_dyn.c
@@ -1153,8 +1153,8 @@ flan_dyn flan_dyn_map_new(void) {
  *
  * The registry a redefined (defclass ...) updates, and the lazy migration
  * that makes the instances built against the old definition answer the new
- * one. This is CLHS 4.3.6 — [update-instance-for-redefined-class] — with the
- * user hook left out; docs/SBCL-REDEFINITION-NOTES.md is where the protocol
+ * one. This is CLHS 4.3.6, [update-instance-for-redefined-class] included —
+ * see [class_hook]; docs/SBCL-REDEFINITION-NOTES.md is where the protocol
  * was read off and candidate C is this.
  *
  * **Why a registry at all, when a class instance is already just a map.**
@@ -1427,6 +1427,101 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) {
   class_add(k, list, types, count);
 }
 
+/* update-instance-for-redefined-class's dispatcher, as the last reload that
+ * installed a class or one of its methods left it; NULL until then. Set by a
+ * thunk and not found by name, because the name is a Flan symbol this file
+ * cannot spell and the body behind it moves with every method added. */
+static void *migrate_fn;
+
+void flan_dyn_class_hook(void *fn) { migrate_fn = fn; }
+
+extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance,
+                                    uint64_t added, uint64_t discarded);
+
+/* Allocation and the map operations are further down, under their own
+ * headings; the hook's arguments are built with them. */
+flan_dyn flan_dyn_vec_new(void);
+flan_dyn flan_dyn_map_new(void);
+void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen);
+void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v);
+
+/* The user hook, run on an instance the name-matching has just brought up to
+ * date. [inst], [added] and [gone] are rooted by the caller.
+ *
+ * Two things are kept for the length of the call, because the call is
+ * arbitrary Flan and may allocate as much as it likes:
+ *
+ * - the name-matched entries, rooted, so that taking the restart puts the
+ *   instance back exactly as name-matching left it, whatever the method did
+ *   to it before it signalled. That is the restart's whole meaning, and it
+ *   is SBCL's choice of what a failed update leaves (std-class.lisp, the
+ *   nlx-protect around the call) moved one step: SBCL restores the obsolete
+ *   instance and retries at the next access, where here the name-matched
+ *   one is kept and nothing is retried.
+ * - the temporaries ring, saved and put back. A migration starts inside
+ *   [get] or [put], whose caller may be holding an object only the ring
+ *   keeps alive — the result of the call beside it in the same expression.
+ *   A method that allocates more than the ring holds would push it out and
+ *   let the next collection free it, so the ring is rooted for the call and
+ *   restored after it, and the caller sees the ring it left. */
+static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added,
+                       flan_dyn gone, int64_t n) {
+  flan_dyn *snap = NULL;
+  flan_obj *ring_was[RING];
+  flan_dyn  ring_rooted[RING];
+  unsigned  ring_at_was = ring_at, k;
+  int64_t   j, roots_at = roots_n;
+  int       r;
+  if (n > 0) {
+    snap = (flan_dyn *)malloc((size_t)n * 2 * sizeof *snap);
+    if (snap == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *snap);
+    memcpy(snap, o->u.v.items, (size_t)n * 2 * sizeof *snap);
+    for (j = 0; j < n; j++) root_add(&snap[j * 2 + 1], NULL);
+  }
+  memcpy(ring_was, ring, sizeof ring);
+  for (k = 0; k < RING; k++) {
+    ring_rooted[k] = ring[k] == NULL
+      ? dyn_make(BOX_NIL, 0)
+      : dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)ring[k]);
+    root_add(&ring_rooted[k], NULL);
+  }
+  r = flan_dyn_migrate_hook(migrate_fn, inst, added, gone);
+  memcpy(ring, ring_was, sizeof ring);
+  ring_at = ring_at_was;
+  /* Nothing below allocates on the collector's heap, so the roots into
+     [snap] and this frame can go before either does. */
+  roots_n = roots_at;
+  if (r == 1) {
+    /* The restart: the entries name-matching left, in a block of their own,
+     * whatever the method grew or shrank the instance to. */
+    flan_dyn *back = NULL;
+    if (n > 0) {
+      back = (flan_dyn *)malloc((size_t)n * 2 * sizeof *back);
+      if (back == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *back);
+      memcpy(back, snap, (size_t)n * 2 * sizeof *back);
+    }
+    gc_bytes += (n - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn);
+    free(o->u.v.items);
+    o->u.v.items = back;
+    o->u.v.cap = n;
+    o->len = n;
+  }
+  free(snap);
+  if (r == 2) {
+    kw_entry *c = o->u.v.klass;
+    fflush(stdout);
+    fprintf(stderr,
+            "dyn migrate: update-instance-for-redefined-class, migrating an "
+            "instance of %.*s, was left for a restart established outside "
+            "it. A migration runs inside get, put or set, and cannot be "
+            "left for one of their callers; the instance is kept as its "
+            "slots matched by name. Take migrate-by-name, or handle the "
+            "condition inside the method\n",
+            (int)c->len, (const char *)(c + 1));
+    flan_trap((const uint8_t *)"DynMigrate", 10);
+  }
+}
+
 /* The migration. [o] is left holding exactly the class's current slots, in
  * the class's order, with the values it already had for the ones it still
  * has and nil for the ones it has just gained — which is precisely the
@@ -1440,8 +1535,10 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) {
  * and count in insertion order and would have. One malloc per instance per
  * redefinition is the price, and a migration happens once.
  *
- * Nothing here allocates on the collector's heap, so no collection can run
- * part-way through and see an object whose [len] and [items] disagree.
+ * The name-matching allocates nothing on the collector's heap, so no
+ * collection can run part-way through it and see an object whose [len] and
+ * [items] disagree. The hook's arguments are built before it starts, while
+ * [o] still holds its old entries whole, and the hook runs after it ends.
  *
  * Nor can it free a block something above it is walking. The block it frees
  * is [o]'s, and every caller syncs [o] before it starts walking [o] — so a
@@ -1453,9 +1550,48 @@ static void class_sync(flan_obj *o) {
   class_entry *e;
   flan_dyn *fresh = NULL;
   int64_t i, j;
+  /* The hook's three arguments, rooted by address for as long as the hook
+   * may run: each is a collector object held nowhere else. */
+  flan_dyn inst, added, gone;
+  int64_t roots_at = roots_n;
+  int hook;
   if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return;
   e = class_find(o->u.v.klass);
   if (e == NULL || e->gen == o->gen) return;
+  /* CLHS 4.3.6: the method runs on every instance a redefinition reaches,
+   * whether or not the slot names moved — a changed type is a change a
+   * method may want to convert for. */
+  hook = migrate_fn != NULL && flan_dyn_migrate_hook != NULL;
+  inst = dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
+  added = gone = dyn_make(BOX_NIL, 0);
+  if (hook) {
+    root_add(&inst, NULL);
+    added = flan_dyn_vec_new();
+    root_add(&added, NULL);
+    gone = flan_dyn_map_new();
+    root_add(&gone, NULL);
+    for (j = 0; j < e->nslots; j++) {
+      for (i = 0; i < o->len; i++) {
+        flan_dyn key = o->u.v.items[i * 2];
+        if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD
+            && dyn_kw(key) == e->slots[j]) break;
+      }
+      if (i == o->len)
+        flan_dyn_push(added,
+                      dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]),
+                      NULL, 0);
+    }
+    /* Every key the class no longer declares, a raw [put]'s included:
+     * CLHS's discarded slots and their property list, as one map. */
+    for (i = 0; i < o->len; i++) {
+      flan_dyn key = o->u.v.items[i * 2];
+      int kept = 0;
+      if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD)
+        for (j = 0; j < e->nslots; j++)
+          if (dyn_kw(key) == e->slots[j]) { kept = 1; break; }
+      if (!kept) flan_dyn_map_set(gone, key, o->u.v.items[i * 2 + 1]);
+    }
+  }
   if (e->nslots > 0) {
     fresh = (flan_dyn *)malloc((size_t)e->nslots * 2 * sizeof *fresh);
     if (fresh == NULL) trap_oom(NULL, 0, e->nslots * 2 * (int64_t)sizeof *fresh);
@@ -1506,7 +1642,11 @@ static void class_sync(flan_obj *o) {
   o->u.v.items = fresh;
   o->u.v.cap = e->nslots;
   o->len = e->nslots;
+  /* Current before the hook runs, so a method that reads or writes the
+   * instance finds it migrated and does not start a second migration. */
   o->gen = e->gen;
+  if (hook) class_hook(o, inst, added, gone, e->nslots);
+  roots_n = roots_at;
 }
 
 /* The same map with a shape tag on it: what a (defclass ...) constructor
diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h
index 8b73adf6..df8020e5 100644
--- a/runtime/flan_dyn.h
+++ b/runtime/flan_dyn.h
@@ -120,7 +120,7 @@ flan_dyn flan_dyn_class_of(flan_dyn v);
  * [len] or equality comparison: slots the class still has keep their values
  * matched by name, slots it has gained appear as nil, and keys it no longer
  * declares are dropped. The instance's identity is preserved throughout;
- * this is CLHS 4.3.6 without the user hook.
+ * this is CLHS 4.3.6, and [flan_dyn_class_hook] is its user hook.
  *
  * The drop is unconditional, which is the honest cost of a class instance
  * being an open map: a key written by a raw [put] that the class never
@@ -128,6 +128,13 @@ flan_dyn flan_dyn_class_of(flan_dyn v);
  * class's intention and does not enforce it. */
 void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n);
 
+/* The body update-instance-for-redefined-class dispatches through, as a
+ * reload last saw it. Each migration after this calls it, through
+ * flan_rt.c's [flan_dyn_migrate_hook], with the instance already matched by
+ * name. A reload that installs a class or a method of that generic calls
+ * this again, so the body is never older than the last one installed. */
+void flan_dyn_class_hook(void *fn);
+
 /* [sizeof(flan_obj)], for the one test that asserts it. The generation a
  * class instance carries was fitted into the padding between [mark] and
  * [len] precisely so that this number did not move; a field that pushed it
diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c
index 51639a60..6edc6eb8 100644
--- a/runtime/flan_rt.c
+++ b/runtime/flan_rt.c
@@ -620,6 +620,26 @@ void (*flan_break_hook)(const uint8_t *name, int64_t namelen, void *condition,
  * site printed just above carries the detail. */
 void (*flan_trap_hook)(const uint8_t *name, int64_t namelen);
 
+/* The call a class migration makes to update-instance-for-redefined-class:
+ * [fn] is the method dispatcher's current body, and the three words are the
+ * instance, the vec of slots it gained and the map of the slots it lost to
+ * the values they held — dyn words, as [uint64_t] here because this file
+ * does not include flan_dyn.h.
+ *
+ * Here and not in flan_dyn.c because it is set by the agent, and the agent
+ * must link against a program with no collector in it; and not called from
+ * here because what makes it a hook is the restart it runs under, which is
+ * the agent's business — the floor a break inside it reads is the agent's.
+ * NULL, and no hook runs, outside a dev session: a class is redefined only
+ * by a reload, and a reload only arrives through the agent.
+ *
+ * The answer is 0 when the method returned, 1 when the restart the call
+ * established was taken, and 2 when some other transfer came back through
+ * it — one aimed at a restart below the call, which a C frame cannot carry
+ * on. */
+int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, uint64_t added,
+                             uint64_t discarded);
+
 static _Noreturn void rt_trap(const uint8_t *name, int64_t namelen) {
   if (flan_trap_hook != NULL) flan_trap_hook(name, namelen);
   rt_die();
diff --git a/test/programs/dev-hook.flan b/test/programs/dev-hook.flan
new file mode 100644
index 00000000..d553b3fa
--- /dev/null
+++ b/test/programs/dev-hook.flan
@@ -0,0 +1,21 @@
+;;;; A class redefined under its instances, with update-instance-for-
+;;;; redefined-class written from the session to carry a lost slot's value
+;;;; into a gained one. dev-classes.flan is the name-matching half; this is
+;;;; the half a method adds, and the method that signals.
+;;;;
+;;;; The instances are pushed by the editor for dev-classes.flan's reason: a
+;;;; compiled caller of the constructor would pin its slot count.
+(import agent "vendor:agent")
+
+(defclass point [x y])
+
+(defstruct Refused [why i32])
+
+(defonce instances dyn)
+
+(defn main [] i32
+  (agent/start "/tmp/flan-dev-hook-fallback.sock")
+  (set instances (vec-new dyn))
+  (dotimes [i 4000]
+    (agent/wait 5))
+  0)
diff --git a/test/test_dev.ml b/test/test_dev.ml
index 169a2eee..401bdc88 100644
--- a/test/test_dev.ml
+++ b/test/test_dev.ml
@@ -7481,6 +7481,162 @@ let () =
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ lsock2; lout2 ];
 
+    (* ── update-instance-for-redefined-class, written from the session ──
+       The method is written and installed while the program runs, then the
+       class is redefined, and each instance runs the method at its first
+       touch after that. On both backends, because the method is Flan code
+       the C runtime calls from inside [get], and that call is the one piece
+       of this each backend's calling convention has to agree with.
+
+       Three claims, in order: a method carries a lost slot's value into a
+       gained one; a method that signals stops the program with
+       [migrate-by-name] on offer, and taking it leaves the instance as
+       name-matching made it, the method's own write included; and a kept
+       value that no longer fits its slot's new type stays, with a warning.
+       stdout and stderr go to one file, which is where the warning is read
+       from. *)
+    let hook_block ~llvm =
+      let what = if llvm then "llvm: " else "" in
+      let hsock = tmp (if llvm then "hook-llvm.sock" else "hook.sock")
+      and hout = tmp (if llvm then "hook-llvm.out" else "hook.out") in
+      (try Sys.remove hsock with Sys_error _ -> ());
+      let hfd =
+        Unix.openfile hout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
+      in
+      let argv =
+        Array.append
+          [| flan; "dev"; "programs/dev-hook.flan"; "-s"; hsock |]
+          (if llvm then [| "--llvm" |] else [||])
+      in
+      let hpid = Unix.create_process flan argv Unix.stdin hfd hfd in
+      Unix.close hfd;
+      let output () = In_channel.with_open_bin hout In_channel.input_all in
+      if not (listening ~pid:hpid hsock) then begin
+        fail "%sthe hook daemon %s (%S)" what !listen_why (output ());
+        (try Unix.kill hpid Sys.sigkill with Unix.Unix_error _ -> ())
+      end
+      else begin
+        let c = connect hsock in
+        let said r = Option.value ~default:"" (Wire.string_field r "message") in
+        let value r = Option.value ~default:"" (Wire.string_field r "value") in
+        let file = " :file \"programs/dev-hook.flan\")" in
+        let ask code =
+          request c (Printf.sprintf "(:op \"eval-expr\" :code %S%s" code file)
+        in
+        let redefine code =
+          request c (Printf.sprintf "(:op \"eval\" :code %S%s" code file)
+        in
+        let holds claim code =
+          let r = ask code in
+          if status r <> "ok" then fail "%s%s: %s" what claim (said r)
+          else if value r <> "1" then
+            fail "%s%s answered %S (%s)" what claim (value r) code
+        in
+        let defined claim code =
+          let r = redefine code in
+          if status r <> "ok" then (fail "%s%s: %s" what claim (said r); false)
+          else true
+        in
+        let stopped r =
+          match Wire.field r "stopped" with
+          | Some { Form.v = Form.Sym "t"; _ } -> true
+          | _ -> false
+        in
+        let started () =
+          status (ask "(do (push instances (point 3 4)) 1)") = "ok"
+        in
+        if not (await started) then
+          fail "%sthe hook daemon never reached a frame boundary" what
+        else begin
+          holds "a second instance" "(do (push instances (point 5 6)) 1)";
+          (* ── A method that carries a value across ── *)
+          if defined "a method of the migration generic, from the session"
+               "(defmethod update-instance-for-redefined-class point \
+                [p added discarded] \
+                (set (get p :radius) (get discarded :y)) nil)"
+          && defined "a class redefined under a method"
+               "(defclass point [x radius])"
+          then begin
+            holds "the method moved the lost slot's value into the new one"
+              "(if (= (get (at instances 0) :radius) 4) 1 0)";
+            holds "a kept slot is untouched by the method"
+              "(if (= (get (at instances 0) :x) 3) 1 0)";
+            holds "the lost slot is gone"
+              "(if (= (length (at instances 0)) 2) 1 0)";
+            holds "each instance runs the method at its own first touch"
+              "(if (= (get (at instances 1) :radius) 6) 1 0)"
+          end;
+          (* ── A method that signals ── *)
+          if defined "a method that signals"
+               "(defmethod update-instance-for-redefined-class point \
+                [p added discarded] \
+                (set (get p :x) 99) (error (Refused {.why 1})) nil)"
+          && defined "a class redefined under a method that signals"
+               "(defclass point [x radius z])"
+          then begin
+            let r = ask "(get (at instances 0) :x)" in
+            if status r <> "error" then
+              fail "%sa migration whose method signals answered %s" what
+                (status r);
+            let r = request c "(:op \"break\")" in
+            let names =
+              match Wire.field r "restarts" with
+              | Some { Form.v = Form.List l; _ } ->
+                List.filter_map
+                  (fun (n : Form.t) ->
+                     match n.Form.v with Form.Str x -> Some x | _ -> None)
+                  l
+              | _ -> []
+            in
+            (match names with
+             | "migrate-by-name" :: _ -> ()
+             | _ ->
+               fail "%sthe restarts at a signalling method: %s" what
+                 (String.concat ", " names));
+            let r = request c "(:op \"restart\" :name \"migrate-by-name\")" in
+            if status r <> "ok" then
+              fail "%smigrate-by-name was refused: %s" what (said r);
+            if not
+                 (await (fun () -> not (stopped (request c "(:op \"describe\")"))))
+            then fail "%sthe program did not run again after migrate-by-name" what
+            else begin
+              holds "migrate-by-name undoes the method's write"
+                "(if (= (get (at instances 0) :x) 3) 1 0)";
+              holds "and keeps what name-matching kept"
+                "(if (= (get (at instances 0) :radius) 4) 1 0)";
+              holds "and has the new definition's slots"
+                "(if (= (length (at instances 0)) 3) 1 0)"
+            end
+          end;
+          (* ── A type that no longer fits ── *)
+          if defined "a method that does nothing"
+               "(defmethod update-instance-for-redefined-class point \
+                [p added discarded] nil)"
+          && defined "a slot's type changed to one its value does not fit"
+               "(defclass point [x string radius z])"
+          then begin
+            holds "a value that no longer fits is kept"
+              "(if (= (get (at instances 0) :x) 3) 1 0)";
+            let warned () =
+              contains_sub (output ())
+                "warning: point was redefined, and its slot :x is now \
+                 declared string"
+            in
+            if not (await warned) then
+              fail "%sno warning for a kept value that does not fit: %S" what
+                (output ())
+          end
+        end;
+        (try Unix.close c with Unix.Unix_error _ -> ());
+        (try Unix.kill hpid Sys.sigkill with Unix.Unix_error _ -> ());
+        (try ignore (Unix.waitpid [] hpid) with Unix.Unix_error _ -> ())
+      end;
+      List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
+        [ hsock; hout ]
+    in
+    hook_block ~llvm:false;
+    hook_block ~llvm:true;
+
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ sock; out; bsock; bout ];
     Test_support.report ~label:"dev" ()
diff --git a/test/test_session.ml b/test/test_session.ml
index 758cb23f..3a44b8e2 100644
--- a/test/test_session.ml
+++ b/test/test_session.ml
@@ -1384,6 +1384,25 @@ let () =
          (String.concat " " c.Session.fns)
    | exception Loc.Error { Loc.dmsg = m; _ } ->
      fail "a class and its caller evaluated together: %s" m);
+  (* A method of update-instance-for-redefined-class, from the session. The
+     generic is written by [Classes.expand], not by the program, so this is
+     the case where the declaration being extended is nowhere in the
+     session's own list — and the method still has to install the generic's
+     dispatch, and the module has to hand the runtime the body it just
+     installed, or migrations go on calling the old one. *)
+  (let t, _ = Session.create ~file:"programs/dev-class.flan" () in
+   match
+     Session.eval t
+       "(defmethod update-instance-for-redefined-class point \
+        [p added discarded] nil)"
+   with
+   | c ->
+     if not (List.mem Classes.migrate_generic c.Session.fns) then
+       fail "a migration method installed %s" (String.concat " " c.Session.fns);
+     if not (has c.Session.ir "call void @flan_dyn_class_hook") then
+       fail "a migration method did not re-register the hook"
+   | exception Loc.Error { Loc.dmsg = m; _ } ->
+     fail "a migration method was refused: %s" m);
   (* A slot's type changed and nothing else. Every constructor parameter is
      dyn whatever the slot says, so the signature is the one it was and a
      compiled caller is no reason to refuse — the type is checked where a
diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c
index 2ca2aadb..4ab2090b 100644
--- a/vendor/agent/flan_agent.c
+++ b/vendor/agent/flan_agent.c
@@ -336,6 +336,8 @@ extern int64_t        flan_break_site_len;
  * shadow-stack frame's shape does: the struct is declared in one file. */
 extern void *flan_restart_push_c(const uint8_t *name, int64_t namelen);
 extern void  flan_restart_pop_c(void *frame);
+extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance,
+                                    uint64_t added, uint64_t discarded);
 
 /* -- How far down a transfer can actually land ----------------------- */
 
@@ -402,6 +404,44 @@ static int32_t frame_floor = -1;
 static void *eval_boundary;
 static const uint8_t abandon_name[] = "abandon-evaluation";
 
+/* -- update-instance-for-redefined-class ------------------------------ */
+
+/* A class migration calls the method from inside [get], [put] or [set] —
+ * a C frame with no transfer channel of its own — so the call is made the
+ * way a thunk's is: behind a floor, with a channel of its own and a restart
+ * of its own above the floor. A break inside the method then offers
+ * [migrate-by-name] and nothing below the call, which it could not reach.
+ * Taking it leaves the instance as name-matching made it; flan_dyn.c's
+ * [class_hook] puts that back.
+ *
+ * [eval_boundary] is cleared for the call: an evaluation in progress
+ * underneath is below this floor, and offering to abandon it would be a
+ * choice nothing can carry out. Everything saved is restored, so a
+ * migration inside a thunk inside a break nests like the rest. */
+static const uint8_t migrate_name[] = "migrate-by-name";
+
+typedef uint64_t (*migrate_fn_t)(uint64_t, uint64_t, uint64_t, void *);
+
+static int migrate_call(void *fn, uint64_t instance, uint64_t added,
+                        uint64_t discarded) {
+  int32_t outer = restart_floor;
+  int32_t oframe = frame_floor;
+  void   *obound = eval_boundary;
+  void   *xfer = NULL;
+  void   *mine;
+  restart_floor = flan_restart_count();
+  frame_floor = flan_dev_frame_count();
+  eval_boundary = NULL;
+  mine = flan_restart_push_c(migrate_name, sizeof migrate_name - 1);
+  ((migrate_fn_t)fn)(instance, added, discarded, &xfer);
+  flan_restart_pop_c(mine);
+  eval_boundary = obound;
+  restart_floor = outer;
+  frame_floor = oframe;
+  if (xfer == NULL) return 0;
+  return (mine != NULL && xfer == mine) ? 1 : 2;
+}
+
 /* The three of them, dropped between two runs of [main]. The counterpart of
  * flan_rt.c's [flan_condition_stacks_reset] and flan_dev.c's
  * [flan_dev_frames_reset], called from the same one place and for the same
@@ -864,6 +904,9 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
               !s->resumable   ? "   (cannot be taken from this trap)"
               : i == s->boundary
                 ? "   (stop running the expression; the program carries on)"
+              : strcmp(s->names + s->off[i], (const char *)migrate_name) == 0
+                  && s->reachable[i]
+                ? "   (keep the instance as its slots matched by name)"
               : s->reachable[i] ? ""
                                 : "   (below this break; cannot be taken)");
     if (s->total > s->n)
@@ -2114,6 +2157,7 @@ static int32_t start_on(const char *path) {
    * to do, and stopping forever is worse than the abort it replaces. */
   flan_break_hook = break_loop;
   flan_trap_hook  = trap_stop;
+  flan_dyn_migrate_hook = migrate_call;
   return 0;
 
 failed:
diff --git a/web/index.html b/web/index.html
index 0805ca50..d40a211a 100644
--- a/web/index.html
+++ b/web/index.html
@@ -2220,7 +2220,14 @@ bumps a generation counter, which is O(1) and walks no heap; every live instance
 migrates at its next touch. Slots matched by name keep their values, a gained slot
 appears as nil, a dropped one goes, the object is the same object, and
 class-of still answers the same tag, so every method still reaches it.
-That is CLHS 4.3.6's protocol without the user hook, which is not built.

+That is CLHS 4.3.6's protocol. Its user hook is +update-instance-for-redefined-class: a method of it written for a +class, from the running session, runs on each instance as it migrates, with a +vec of the slots it gained and a map from each slot it lost to the value that slot +held. A method that signals stops the program with migrate-by-name +on offer, which keeps the instance as matching by name left it. A kept value that +no longer fits its slot's new type is kept, with a warning, and the next write to +the slot is checked.

C-c C-x rebuilds, relaunches and reconnects, and is the way out while the above is true. It costs the program's state, which is why it is a key you press rather than From 5c0698d749ed7f924e00585881643d860dad7f75 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 12:00:42 +0700 Subject: [PATCH 09/16] (max-of T) and (min-of T) are a numeric type's limits, at a concrete type or a type variable the bound admits, and given a slice they are still the prelude's reductions --- lib/check.ml | 54 +++++++++++++++++++++++++++++++++++++++ lib/prelude.ml | 2 ++ test/programs/max-of.flan | 54 +++++++++++++++++++++++++++++++++++++++ test/test_acceptance.ml | 8 ++++++ test/test_flan.ml | 13 ++++++++++ 5 files changed, 131 insertions(+) create mode 100644 test/programs/max-of.flan diff --git a/lib/check.ml b/lib/check.ml index fb5aa531..7a1199d7 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -7371,6 +7371,60 @@ and named_call ?(qualified = false) ctx ~want loc name args = expect ctx loc ~want (List.fold_left (fun acc arg -> pick acc (check ctx ~want:ty arg)) (pick a b) rest) + (* (max-of T) and (min-of T): the type-limit constants, by type, so a + generic body can name its own type's. Odin's max(T) and min(T), and the + same answer for a float: the largest finite value and its negation, not + the smallest positive one. Given a value rather than a type, the name is + the prelude's reduction of a slice, and the call is an ordinary one — + the same split [vec-new] makes between a type and an allocator. *) + | ("max-of" | "min-of") + when (match args with + | [ a ] -> + type_of_expr a <> None + || (match a.Ast.e with + | Ast.Var n -> + lookup ctx n = None + && (not (Hashtbl.mem ctx.env.globals n)) + && type_named ctx n + | _ -> false) + | _ -> false) -> + let a = List.hd args in + let ty = + match type_of_expr a, a.Ast.e with + | Some t, _ -> resolve ctx.env t + | _, Ast.Var n -> resolve_name ctx.env ~seen:[] a.Ast.loc n + | _ -> fail a.Ast.loc "internal: max-of's type argument is not a type" + in + let max = String.equal name "max-of" in + let v = + match ty with + | Types.Int k -> + let b = Types.bits k in + let n = + if Types.signed k then + let top = Int64.shift_left 1L (b - 1) in + if max then Int64.sub top 1L else Int64.neg top + else if not max then 0L + else if b = 64 then -1L + else Int64.sub (Int64.shift_left 1L b) 1L + in + mk loc ty (Tast.Int (n, k)) + | Types.Float k -> + let m = + match k with + | Types.F32 -> Int32.float_of_bits 0x7f7fffffl + | Types.F64 -> Float.max_float + in + mk loc ty (Tast.Float ((if max then m else -.m), k)) + | Types.Var _ -> + unconstrained ctx.env loc name ~needs:"numeric?" ty; + int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L + | _ -> + fail a.Ast.loc + "%s takes a numeric? type, and %s is not one — as in (%s i32)" name + (Types.to_string ty) name + in + expect ctx loc ~want v (* (zeroed) is the all-bytes-zero value of whatever it is being stored into, so it only means anything where a type is expected of it. *) | "zeroed" -> diff --git a/lib/prelude.ml b/lib/prelude.ml index ff520d4b..4cab01aa 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -406,6 +406,8 @@ let source = {flan| ;; or more numbers, and a defn cannot shadow a builtin: nothing shadows [+] ;; either. These reduce a slice, which is a different operation with a ;; different arity, so the different name is honest rather than a workaround. +;; Given a type instead of a slice, (min-of i8) and (max-of $t) are the type's +;; limits, and the checker answers those itself. (defn min-of [s [$t]] (Option $t) {:where (ordered? $t)} (if (= (length s) 0) diff --git a/test/programs/max-of.flan b/test/programs/max-of.flan new file mode 100644 index 00000000..2b5f5e76 --- /dev/null +++ b/test/programs/max-of.flan @@ -0,0 +1,54 @@ +;;;; (max-of T) and (min-of T): a numeric type's limits, named by the type, at +;;;; a concrete type and inside a generic whose bound admits numbers. + +;; A selection sort, descending, whose running best starts at the least value +;; of the element type, so any element beats it. +(defn sort-desc [s [$t]] () + {:where (numeric? $t)} + (dotimes [i (length s)] + (let [best (min-of $t) + at-best i] + (dotimes [j (- (length s) i)] + (let [k (+ i j)] + (when (> (at s k) best) + (set best (at s k)) + (set at-best k)))) + (swap s i at-best)))) + +(defn largest [s [$t]] $t + {:where (numeric? $t)} + (let [best (min-of t)] + (dotimes [i (length s)] + (when (> (at s i) best) (set best (at s i)))) + best)) + +(defn show-i32 [s [i32]] () + (dotimes [i (length s)] (print (at s i)) (print " ")) + (println "")) + +(defn show-f64 [s [f64]] () + (dotimes [i (length s)] (print (at s i)) (print " ")) + (println "")) + +(defn main [] i32 + (println (max-of u8)) + (println (min-of u8)) + (println (max-of i8)) + (println (min-of i8)) + (println (max-of i32)) + (println (min-of i64)) + (println (max-of u64)) + (println (= (max-of f32) f32-max)) + (println (= (min-of f64) (- f64-max))) + (println (= (max-of i16) i16-max)) + (let [a [(i32 3) -7 12 0 -2147483648 5] + b [2.5 -1.0 1e300 -1e308] + c [(u8 4) 0 200 9]] + (sort-desc (slice a)) + (show-i32 (slice a)) + (sort-desc (slice b)) + (show-f64 (slice b)) + (println (largest (slice c))) + (println (let [d [(i64 -5) -9]] (largest (slice d)))) + (println (let [e [(f32 -1.0) -3.0]] (= (largest (slice e)) (f32 -1.0))))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index c6660228..2dd063da 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -573,6 +573,14 @@ let () = outputs "a prelude function shadowed" "programs/shadow-prelude.flan" sp_out; outputs ~x86:true "a prelude function shadowed, x86" "programs/shadow-prelude.flan" sp_out; + (* (max-of T) and (min-of T), concrete and inside a generic. *) + let maxof_out = + "255\n0\n127\n-128\n2147483647\n-9223372036854775808\n\ + 18446744073709551615\ntrue\ntrue\ntrue\n\ + 12 5 3 0 -7 -2147483648 \n1e+300 2.5 -1 -1e+308 \n200\n-5\ntrue\n" in + outputs "max-of and min-of" "programs/max-of.flan" maxof_out; + outputs ~opt:"-O0" "max-of and min-of, -O0" "programs/max-of.flan" maxof_out; + outputs ~x86:true "max-of and min-of, x86" "programs/max-of.flan" maxof_out; (* (- x) negates, on every numeric type, a type variable and a dyn. *) let neg_out = "-3\n7\n-2.5\n-inf\n-1.5\n255\n-4\n-2.5\n-inf\n-9000000000\n\ diff --git a/test/test_flan.ml b/test/test_flan.ml index 636c1f36..759b7bbd 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6399,6 +6399,19 @@ let () = "(defn main [] i32 (let [a [None None]] 0))" ~needle:"what None is an Option of"; + (* ── (max-of T) and (min-of T) ──────────────────────────────────── *) + infers "max-of carries its type" "(max-of u16)" "u16"; + infers "min-of at a float" "(min-of f32)" "f32"; + rejects_check "max-of at an unbounded type variable names the bound" + "(defn f [x $t] $t (max-of $t))" ~needle:"{:where (numeric? $t)}"; + accepts "max-of at a type variable the bound admits" + "(defn f [x $t] $t {:where (integer? $t)} (max-of t))"; + rejects_check "max-of at a type that is not a number names the bound" + "(defn f [] string (max-of string))" + ~needle:"max-of takes a numeric? type, and string is not one"; + accepts "max-of of a slice is still the prelude's reduction" + "(defn f [xs [i32]] (Option i32) (max-of xs))"; + (* ── (the T e) ─────────────────────────────────────────────────── *) infers "the gives a literal its type" "(the u8 200)" "u8"; infers "the widens as an annotation does" "(the i64 (the i32 1))" "i64"; From bf0a939093b58b4c8fcebfd485b7d6c5c3296503 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 12:07:32 +0700 Subject: [PATCH 10/16] A dyn negation of a non-number is refused by name, and a prelude function shadowed in a live session is a recorded gap --- TODO.org | 5 +++++ test/dyn_ops.c | 2 ++ test/test_dyn.ml | 1 + 3 files changed, 8 insertions(+) diff --git a/TODO.org b/TODO.org index 77327b25..6302f1c7 100644 --- a/TODO.org +++ b/TODO.org @@ -1514,6 +1514,11 @@ are a dyn vector. Rules out the first element typing the rest. * Dev loop +** TODO A prelude function shadowed live is reached by the prelude's own calls +A defn of a prelude function's name sent to a running =flan dev= installs into the +host's cell for that name, so the prelude's calls compiled into the host follow it; +a rebuild gives them the prelude's again, as =Check.shadow_prelude= intends. + ** DONE The dev loop, step 1: the reload primitive A list of top-level forms is recompiled and installed into a running process, and call sites compiled before those forms existed follow them through an indirection diff --git a/test/dyn_ops.c b/test/dyn_ops.c index dd9eb728..bc58eb0e 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -985,6 +985,8 @@ static void refuse(const char *what) { if (strcmp(what, "add") == 0) (void)FDYN_add(flan_dyn_from_i64(3), t); else if (strcmp(what, "sub") == 0) (void)FDYN_sub(flan_dyn_nil(), flan_dyn_from_i64(1)); + else if (strcmp(what, "neg") == 0) + (void)flan_dyn_neg(t, NULL, 0); else if (strcmp(what, "mul") == 0) (void)FDYN_mul(flan_dyn_from_bool(1), flan_dyn_from_i64(2)); else if (strcmp(what, "div") == 0) diff --git a/test/test_dyn.ml b/test/test_dyn.ml index 8152b9cf..4969e4d9 100644 --- a/test/test_dyn.ml +++ b/test/test_dyn.ml @@ -205,6 +205,7 @@ let () = let refusals = [ ("add", "dyn +: int and text"); ("sub", "dyn -: nil and int"); + ("neg", "dyn -: text, and it takes a number"); ("mul", "dyn *: bool and int"); ("div", "dyn /: vec and int"); ("rem", "dyn %: int and nil"); From 35f455acb3d5dc79fbc100bb8ca247b76780e89c Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 12:49:02 +0700 Subject: [PATCH 11/16] The's refusal of a dyn says what the boundary does at that type, elements that cannot become a dyn are refused against each other, two literal arms meet at the wider type, and the renamed prelude function and a second startup warning stay out of sight --- bin/main.ml | 1 + lib/check.ml | 139 +++++++++++++++++++++++++++++++++++++--- lib/dev.ml | 11 +++- lib/session.ml | 4 ++ test/test_acceptance.ml | 10 +++ test/test_flan.ml | 38 +++++++++-- 6 files changed, 189 insertions(+), 14 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index f15d5066..0f1db3e2 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -362,6 +362,7 @@ let () = p.globals; List.iter (fun (f : Flan.Tast.fn) -> + if not (Flan.Check.internal_name f.name) then Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name (String.concat " " (List.map Flan.Types.to_string f.params)) diff --git a/lib/check.ml b/lib/check.ml index 7cfa725a..076080ec 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -5338,6 +5338,17 @@ and check_if ctx ?(tail = false) ?want loc c t e = no value on the missing side. `when` desugars to this. *) let t = branch ctx (fun () -> in_tail (fun () -> check ctx t)) in expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc))) + (* Two literal arms meet at the wider of their own types, as two literal + elements of an array do: [(if c 1 2.5)] is an f64. *) + | Some e + when want = None && lone_literal t && lone_literal e + && (match literal_join ctx t e with + | Some j -> not (Types.equal j (Types.Int Types.I32)) + | None -> false) -> + let want = literal_join ctx t e in + let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in + let e = branch ctx (fun () -> in_tail (fun () -> check ctx ?want e)) in + mk loc t.Tast.ty (Tast.If (c, t, e)) | Some e when want = None && lone_literal t && not (lone_literal e) && not (and_sentinel e) -> (* A literal has no type of its own until something asks, so with no @@ -5392,6 +5403,18 @@ and check_if ctx ?(tail = false) ?want loc c t e = in mk loc ty (Tast.If (c, t, e)) +(* The type two literals meet at, each at its own type — a wide integer at + u64, which is the only type that holds one. *) +and literal_join ctx (a : Ast.expr) (b : Ast.expr) = + let own (x : Ast.expr) = + match x.Ast.e with + | Ast.UInt _ -> Some (Types.Int Types.U64) + | _ -> probe ctx x.Ast.loc (fun () -> (check ctx x).Tast.ty) + in + match own a, own b with + | Some x, Some y -> Types.join x y + | _ -> None + (* Whether a name would reach a callee if it were called — a global function, a generic, or a local holding a function value. The three sources [named_call] itself consults, in its own order; builtins are deliberately not among them, @@ -5725,8 +5748,12 @@ and check_arr ctx ~want loc items = expect ctx loc ~want (check_arr ctx ~want:(Some (Types.Array (n, t))) loc items) | None -> - expect ctx loc ~want - (dyn_vec ctx loc (map_lr (fun i -> check ctx ~want:Types.Dyn i) items))) + (match + trial ctx (fun () -> + dyn_vec ctx loc (map_lr (fun i -> check ctx ~want:Types.Dyn i) items)) + with + | Ok v -> expect ctx loc ~want v + | Error d -> mixed_refusal ctx items d)) | _ -> let items = map_lr (fun i -> check ctx ?want:elem_want i) items in let n = Int64.of_int (List.length items) in @@ -5831,6 +5858,44 @@ and arr_elem_type ctx (items : Ast.expr list) : Types.t option = (fun found c -> match found with Some _ -> found | None -> settle c) None candidates +(* Elements that do not agree and cannot all become a dyn either: a struct + beside a number, a type variable beside a literal. The dyn vector's refusal + would be about dyn, which the program never mentioned, so the elements are + refused against each other instead — the first one's type is what the rest + are checked at, and the refusal points back at it. [d] is the answer if + that finds nothing. *) +and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = + fun ctx items d -> + match items with + | [] -> raise (Loc.Error d) + | first :: rest -> + let first = check ctx first in + let want = match first.Tast.ty with Types.Never -> None | t -> Some t in + List.iter + (fun (i : Ast.expr) -> + match check ctx ?want i with + | v -> + (match want with + | Some t when not (Types.fits ~expected:t ~actual:v.Tast.ty) -> + fail i.Ast.loc "this array's elements are %s, but this one is %s" + (Types.to_string t) (Types.to_string v.Tast.ty) + | _ -> ()) + | exception Loc.Error e when e.Loc.dloc = i.Ast.loc && want <> None -> + raise + (Loc.Error + { e with + Loc.notes = + e.Loc.notes + @ [ Loc.note first.Tast.loc + (Printf.sprintf + "this array's first element is %s, so every \ + element is" + (match first.Tast.ty with + | Types.Var v -> "$" ^ v + | t -> Types.to_string t)) ] })) + rest; + raise (Loc.Error d) + (* A dyn vector built where it stands from elements already checked at dyn: the runtime's own vec, pushed to in order. *) and dyn_vec ctx loc (items : Tast.expr list) = @@ -5986,10 +6051,29 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = | "" -> Printf.sprintf "convert it with the %s cast instead" tn | s -> Printf.sprintf "write (%s %s) to convert it" tn s) else - fail v.Ast.loc - "the checks a value as %s and does not convert one, and this is a dyn \ - — a dyn becomes a %s where a %s is passed, returned or stored" - tn tn tn + (* What a dyn does at this type is the boundary's own answer, asked of + it rather than restated: some types take one where a value is passed, + returned or stored, and the rest do not take one at all. *) + let crosses = + probe ctx loc (fun () -> + ignore (expect ctx v.Ast.loc ~want:(Some ty) (check ctx v))) + in + match crosses with + | Some () -> + fail v.Ast.loc + "the checks a value as %s and does not convert one, and this is a \ + dyn — a dyn becomes a %s where a %s is passed, returned or stored" + tn tn tn + | None -> + (match check ctx ~want:ty v with + | _ -> + fail v.Ast.loc + "the checks a value as %s and does not convert one, and this is \ + a dyn" tn + | exception Loc.Error d -> + fail v.Ast.loc + "the checks a value as %s and does not convert one, and this is \ + a dyn — %s" tn d.Loc.dmsg) end; let r = match ty, v.Ast.e with @@ -6230,6 +6314,26 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = let literal_arm ((a : Ast.arm), _, _) = match List.rev a.Ast.body with last :: _ -> lone_literal last | [] -> false in + (* Every arm a literal: they meet at the wider of their own types, as an + [if]'s two do. *) + (if !want = None && resolved <> [] && List.for_all literal_arm resolved then + let lasts = + List.map (fun ((a : Ast.arm), _, _) -> List.hd (List.rev a.Ast.body)) + resolved + in + match lasts with + | first :: rest -> + let j = + List.fold_left + (fun acc x -> + Option.bind acc (fun a -> + Option.bind (literal_join ctx first x) (Types.join a))) + (literal_join ctx first first) rest + in + (match j with + | Some t when not (Types.equal t (Types.Int Types.I32)) -> want := Some t + | _ -> ()) + | [] -> ()); let order = let idx = List.mapi (fun i r -> (i, r)) resolved in if !want <> None then idx @@ -7724,8 +7828,12 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Types.F64 -> Float.max_float in mk loc ty (Tast.Float ((if max then m else -.m), k)) - | Types.Var _ -> - unconstrained ctx.env loc name ~needs:"numeric?" ty; + | Types.Var v -> + if not (declares ctx.env.tvpreds v "numeric?") then + Loc.failk "check/unconstrained-type-variable" a.Ast.loc + "%s is a limit of a numeric type, and nothing declares $%s \ + numeric — write {:where (numeric? $%s)} at the head of the body" + name v v; int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L | _ -> fail a.Ast.loc @@ -12820,6 +12928,20 @@ let escape_check (fn : Tast.fn) = twice. *) let prelude_alias = "prelude~" +(* Off for a check whose warnings were already printed for the same source: + the dev program re-creating the session its launcher built and warned for. *) +let print_warnings = ref true + +(* A name the renaming above made, which nobody wrote: left out of every + listing a person reads, and shown as whose it is where a frame has to be. *) +let internal_name n = String.starts_with ~prefix:(prelude_alias ^ "/") n + +let shown_name n = + if internal_name n then + let p = String.length prelude_alias + 1 in + "the prelude's " ^ String.sub n p (String.length n - p) + else n + let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) = let fn_name (d : Ast.decl) = match d.Ast.d with @@ -12935,6 +13057,7 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : reload, which is where a defn is most likely to be written. Printed in the shape [Loc] gives an error, so a checker in an editor parses it the same way. *) + if !print_warnings then List.iter (fun (d : Loc.diag) -> prerr_endline diff --git a/lib/dev.ml b/lib/dev.ml index a4b4e12b..05d74af0 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1448,7 +1448,10 @@ let describe t = ok [ ":fns " ^ Wire.strings - (List.map (fun (f : Tast.fn) -> f.Tast.name) + (List.filter_map + (fun (f : Tast.fn) -> + if Check.internal_name f.Tast.name then None + else Some f.Tast.name) t.session.Session.program.Tast.fns); ":globals " ^ Wire.strings @@ -1560,6 +1563,7 @@ let defs t = Hashtbl.replace macro_locs f.Tast.name (Loc.to_string f.Tast.floc); None | None when List.mem f.Tast.name class_names -> None + | None when Check.internal_name f.Tast.name -> None | None -> Some (entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f) @@ -2007,7 +2011,7 @@ let backtrace_op t = (List.map (fun (name, loc, mine, nslots, _sig, _rsig) -> Wire.list - [ Wire.quote name; Wire.quote loc; + [ Wire.quote (Check.shown_name name); Wire.quote loc; Wire.quote (if mine then "program" else "eval"); string_of_int nslots ]) frames); @@ -5811,7 +5815,10 @@ let merged_setup () = marshalling a [Session.t] through a file, which buys nothing: the source cannot have changed between the two, because the build that produced this binary is the one that exec'd it. *) + (* Its warnings were printed by the launcher over the same source. *) + Check.print_warnings := false; let session, _ = Session.create ~debug ~x86 ~file () in + Check.print_warnings := true; (* The program's output has to reach an editor exactly as it did when the daemon held the other end of a pipe. Same pipe, one process: fd 1 is replaced before the program starts, and the accept loop drains it — diff --git a/lib/session.ml b/lib/session.ml index f62654f3..e7beef86 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -186,6 +186,10 @@ let stale_sites ?(live = SM.empty) ?(running = false) built (p : Tast.program) : m acc in from ~kept:true live (from ~kept:false built []) + (* A caller or callee the prelude-shadowing rename made is not the + program's, and there is nothing in the program to recompile for it. *) + |> List.filter (fun s -> + not (Check.internal_name s.caller || Check.internal_name s.target)) |> List.sort (fun a b -> match String.compare a.at.Loc.file b.at.Loc.file with | 0 -> Loc.before a.at b.at diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 2861eca1..f333b5b2 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -6637,6 +6637,16 @@ level "1" cli_case "--debug and an explicit -O are refused together" "build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2 ~says:[ "--debug"; "-O2"; "Drop one of the two" ]; + (* The name a shadowed prelude function is moved to is nobody's to read. *) + (let code, text = cli "check programs/shadow-prelude.flan" in + if code <> 0 || contains text "prelude~" + || not (contains text "defn floor-f32") + then begin + incr failures; + Printf.printf + "FAIL check's listing leaves out the renamed prelude function\n\ + \ got: %S (exit %d)\n" text code + end); (* A file with no main is refused by name before the link, which would otherwise report an undefined reference from crt1.o. *) let nomain = Filename.concat scratch "no-main.flan" in diff --git a/test/test_flan.ml b/test/test_flan.ml index b3d686ef..68272cb4 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6528,6 +6528,24 @@ let () = infers "the names the element type of a mixed literal" "(the [dyn] [1 2.5])" "[2 dyn]"; infers "the with a slice type gives the literal's array type" "(the [f32] [1 2.5])" "[2 f32]"; + (match checked "(defstruct P [x i32]) (defn main [] i32 (let [a [(P 1) 2]] 0))" with + | _ -> check "a struct beside a number is refused" false + | exception Loc.Error d -> + check "elements that cannot become a dyn are refused against the first" + (contains d.Loc.dmsg "expected P, found the integer literal 2" + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "this array's first element is P") + d.Loc.notes)); + (match checked "(defn g [x $t] i32 (let [a [x 1]] 0))" with + | _ -> check "a type variable beside a literal is refused" false + | exception Loc.Error d -> + check "a type variable beside a literal names the bound and spells $t" + (contains d.Loc.dmsg "{:where (numeric? $t)}" + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "this array's first element is $t") + d.Loc.notes)); rejects_check "every element needing a type names the first's refusal" "(defn main [] i32 (let [a [None None]] 0))" ~needle:"what None is an Option of"; @@ -6535,8 +6553,16 @@ let () = (* ── (max-of T) and (min-of T) ──────────────────────────────────── *) infers "max-of carries its type" "(max-of u16)" "u16"; infers "min-of at a float" "(min-of f32)" "f32"; - rejects_check "max-of at an unbounded type variable names the bound" - "(defn f [x $t] $t (max-of $t))" ~needle:"{:where (numeric? $t)}"; + (match checked "(defn f [x $t] $t (max-of $t))" with + | _ -> check "max-of at an unbounded type variable is refused" false + | exception Loc.Error d -> + check "max-of at an unbounded type variable names the bound and only it" + (contains d.Loc.dmsg "write {:where (numeric? $t)}" + && not (contains d.Loc.dmsg "Fn"))); + infers "two literal if arms meet at the wider" "(if true 1 2.5)" "f64"; + infers "two integer if arms stay i32" "(if true 1 2)" "i32"; + infers "two literal match arms meet at the wider" + "(match (Some 1) (Some v) 1 None 2.5)" "f64"; accepts "max-of at a type variable the bound admits" "(defn f [x $t] $t {:where (integer? $t)} (max-of t))"; rejects_check "max-of at a type that is not a number names the bound" @@ -6553,9 +6579,13 @@ let () = rejects_check "the refuses a dyn and names the cast" "(defn f [x dyn] i32 (the i32 x))" ~needle:"write (i32 x) to convert it"; accepts "the cast that refusal names compiles" "(defn f [x dyn] i32 (i32 x))"; - rejects_check "the refuses a dyn at a type that has no cast" + rejects_check "the refuses a dyn at a type a dyn does not become" "(defn f [x dyn] string (the string x))" - ~needle:"a dyn becomes a string where a string is passed"; + ~needle:"dyn — string does not cross into a written type yet"; + rejects_check "the refuses a dyn at bool, which a dyn becomes where passed" + "(defn f [x dyn] bool (the bool x))" + ~needle:"a dyn becomes a bool where a bool is passed"; + accepts "the bool a dyn becomes where it is returned" "(defn f [x dyn] bool x)"; accepts "the at an Option takes nil" "(defn f [] (Option i32) (the (Option i32) nil))"; parse_rejects "the takes a type and a value" "(defn f [] i32 (the i32))" ~needle:"the is (the TYPE value)"; From 16427f8d079507a8721315c5d3829450f1a9dbde Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 12:55:25 +0700 Subject: [PATCH 12/16] A class slot may be a class or an Option, an int widens into a float slot when exact, a gained typed slot starts at its zero, and a migration never re-enters itself --- TODO.org | 4 +- lib/check.ml | 158 ++++++++--- lib/dev.ml | 4 +- lib/emit.ml | 2 +- lib/load.ml | 22 +- runtime/flan_dyn.c | 421 ++++++++++++++++++++--------- runtime/flan_dyn.h | 3 +- test/dyn_ops.c | 87 ++++++ test/programs/dyn-class-slots.flan | 14 +- test/programs/dyn-slot-trap.flan | 5 +- test/test_acceptance.ml | 27 +- test/test_dev.ml | 8 +- test/test_dyn.ml | 8 + test/test_flan.ml | 9 +- test/test_sanitize.ml | 2 +- web/index.html | 3 +- 16 files changed, 581 insertions(+), 196 deletions(-) diff --git a/TODO.org b/TODO.org index d507a35a..ceb797c9 100644 --- a/TODO.org +++ b/TODO.org @@ -2034,8 +2034,8 @@ them. ** DONE defclass slots take types, checked on write CLOSED: [2026-09-25] -The constructor's parameters stay dyn and every store checks at run time; no int -converts into a float slot, nil does not fit a typed slot, and a class is no slot type. +The constructor's parameters stay dyn and every store checks at run time; an int +widens into a float slot only when exact, and nil fits only an (Option T) slot. ** DONE println takes up to a second to appear CLOSED: [2026-09-25] diff --git a/lib/check.ml b/lib/check.ml index 95d2b863..de1745ea 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -63,6 +63,22 @@ type binding = { bwhat : string option; } +(* A class slot's type: what a value stored into it is checked against. A + dyn value's tag is all a store can ask of it, so the scalar types a tag + answers for, an instance of a class, and (Option T) of either, which + admits nil as well. *) +type slot_ty = + | Sany (* no type written: any dyn value *) + | Sval of Types.t (* bool, an integer type, f32, f64, string *) + | Sclass of string (* an instance of this class *) + | Sopt of slot_ty (* nil, or a value of the inner type *) + +let rec slot_text = function + | Sany -> "dyn" + | Sval t -> Types.to_string t + | Sclass c -> c + | Sopt s -> "(Option " ^ slot_text s ^ ")" + type env = { structs : (string, Tast.structure) Hashtbl.t; datas : (string, Tast.data) Hashtbl.t; @@ -187,7 +203,7 @@ type env = { first readable. The type is a declaration about the values and not a layout: an instance is a dyn map whatever this says, and what reads it is [class_spec], which is what the runtime checks a store against. *) - classes : (string, (string * Types.t) list) Hashtbl.t; + classes : (string, (string * slot_ty) list) Hashtbl.t; (* The bindings a dev build counts at every call: [Shim.resources], read off the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan name a program calls. *) @@ -1568,7 +1584,9 @@ let dyn_param_or_typo env n loc = parameters are lowercase" n -let pair_params env (items : Ast.pitem list) : Ast.field list = +let pair_params ?(also = fun _ -> false) env (items : Ast.pitem list) + : Ast.field list = + let is_type_name env n = is_type_name env n || also n in let dyn loc = { Ast.t = Ast.Tname "dyn"; tloc = loc } in let rec go = function | [] -> [] @@ -1597,44 +1615,117 @@ let pair_params env (items : Ast.pitem list) : Ast.field list = in go items -(* A class slot's type, resolved and held to the set a stored dyn value can - be checked against: its tag says bool, int, float or text and nothing - finer, so those are the types there are. A narrower integer is a range on - top of the int tag. Everything else a type can be — a struct, a Vec, a - pointer — does not cross into dyn at all, so a slot of one could never be - written. *) -let slot_type env cls (f : Ast.field) : Types.t = - let t = resolve env f.Ast.fty in - match t with - | Types.Dyn | Types.Bool | Types.Int _ | Types.Float _ | Types.String -> t - | other -> - Loc.failk "check/slot-type" f.Ast.fty.Ast.tloc +(* A class slot's type, held to the set a stored dyn value can be checked + against. A class's name is a type here, and only here: it is not a type + anywhere else in the language, since an instance is a dyn value. Every + other type a slot could name — a struct, a Vec, a pointer — does not cross + into dyn at all, so a slot of one could never be written. *) +(* A class named in [cls]'s slot vector: [n] as written, or [n] in [cls]'s own + package, since [Load] leaves a bare name in a slot vector unqualified. *) +let class_named ~classes cls n = + if List.mem n classes then Some n + else + match String.rindex_opt cls '/' with + | Some i -> + let q = String.sub cls 0 (i + 1) ^ n in + if List.mem q classes then Some q else None + | None -> None + +let rec slot_of env ~classes cls fname (t : Ast.texpr) : slot_ty = + let refuse what = + Loc.failk "check/slot-type" t.Ast.tloc "the slot %s of %s is declared %s, and a class slot holds a dyn value, \ - which can be checked as bool, an integer type, f32, f64 or string. \ - Write one of those, or leave the type out and the slot holds any dyn \ - value: [%s]" - f.Ast.fname cls (Types.to_string other) f.Ast.fname + which can be checked as bool, an integer type, f32, f64, string, a \ + class, or (Option T) of one of those. Write one of those, or leave the \ + type out and the slot holds any dyn value: [%s]" + fname cls what fname + in + match t.Ast.t with + | Ast.Tname n when class_named ~classes cls n <> None -> + Sclass (Option.get (class_named ~classes cls n)) + | Ast.Tapp ("Option", [ inner ]) -> + (match slot_of env ~classes cls fname inner with + | (Sval _ | Sclass _) as s -> Sopt s + | Sany -> refuse "(Option dyn)" + | Sopt _ as s -> refuse ("(Option " ^ slot_text s ^ ")")) + | _ -> + (match resolve env t with + | Types.Dyn -> Sany + | (Types.Bool | Types.Int _ | Types.Float _ | Types.String) as t -> Sval t + | other -> refuse (Types.to_string other)) + +(* The type's word in the string the runtime reads: the scalar type's name, + [#name] for a class, [?] in front for an Option. See [slot_type_of] in + runtime/flan_dyn.c, which is the reader. *) +let rec slot_word = function + | Sany -> "" + | Sval t -> Types.to_string t + | Sclass c -> "#" ^ c + | Sopt s -> "?" ^ slot_word s (* What the runtime is told a class is: one line per slot, in constructor - order, the slot's name and then its type's name after a space — no type + order, the slot's name and then its type's word after a space — no type for a dyn slot. The same string goes to [flan_dyn_map_new_class] from the constructor and to [flan_dyn_class_def] from a reload, so the two cannot describe one class differently. *) -let class_spec_of (slots : (string * Types.t) list) = +let class_spec_of (slots : (string * slot_ty) list) = String.concat "\n" (List.map - (fun (n, t) -> - match t with - | Types.Dyn -> n - | t -> n ^ " " ^ Types.to_string t) + (fun (n, t) -> match t with Sany -> n | t -> n ^ " " ^ slot_word t) slots) let class_slots env n = Hashtbl.find_opt env.classes n +(* A class's slot vector, paired by [pair_params]'s rule with the program's + class names counted as types — so [[owner point]] is one slot holding a + point. + + A lowercase name after a name that is neither a type nor a class is a + second untyped slot, which is the rule for a [defn]'s parameters and is + not changed here. In a vector that types none of its slots that is the + plain reading — [[x y]] is two slots and says nothing more. In one that + types some of them, two untyped names side by side are as likely a type + nobody has declared, so that is said, at the second name, and the slot + stays what the rule makes it. *) +let pair_slots env ~classes cls (items : Ast.pitem list) : Ast.field list = + let fields = + pair_params ~also:(fun n -> class_named ~classes cls n <> None) env items + in + let untyped (f : Ast.field) = + match f.Ast.fty.Ast.t with Ast.Tname "dyn" -> true | _ -> false + in + let written_dyn = + List.exists (function Ast.Pname ("dyn", _) -> true | _ -> false) items + in + if List.exists (fun f -> not (untyped f)) fields && not written_dyn then begin + let rec scan = function + | (a : Ast.field) :: ((b : Ast.field) :: _ as rest) -> + if untyped a && untyped b then + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " b.Ast.floc + (Printf.sprintf + "%s reads as a slot of %s with no type, because no type or \ + class is named %s. If it was meant as the type of %s, \ + declare it; if it is a slot, write its type or write \ + [%s dyn] to say it holds any value" + b.Ast.fname cls b.Ast.fname a.Ast.fname b.Ast.fname)); + scan rest + | _ -> () + in + scan fields + end; + fields + (* Every [defn] in the program, with its parameter vector paired. Run as a pass of its own, after the type names are registered and before any signature is resolved, so that nothing downstream ever sees an unpaired one. *) let pair_decls env (decls : Ast.decl list) : Ast.decl list = + let classes = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defclass (n, _) -> Some n | _ -> None) + decls + in let fn (f : Ast.fn) = match f.Ast.praw with | None -> f @@ -1648,11 +1739,11 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = pairs — [Classes.expand] left the declaration as it was for exactly this. *) | Ast.Defclass (n, items) -> - let slots = pair_params env items in + let slots = pair_slots env ~classes n items in Hashtbl.replace env.classes n (List.map (fun (f : Ast.field) -> - (f.Ast.fname, slot_type env n f)) + (f.Ast.fname, slot_of env ~classes n f.Ast.fname f.Ast.fty)) slots); Classes.constructor n slots d.Ast.dloc | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn f) } @@ -3741,13 +3832,16 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = (* A class's constructor stores through [flan_dyn_slot_init], which is the plain store plus the slot's type check, worded for the constructor rather than for a [put] nobody wrote. *) - let store = if tag = None then "flan_dyn_map_set" else "flan_dyn_slot_init" in let sets = List.map - (fun (k, v) -> - rt loc Types.Unit store - [ mval; check ctx ~want:Types.Dyn k; - check ctx ~want:Types.Dyn v ]) + (fun ((k : Ast.expr), v) -> + let args = + [ mval; check ctx ~want:Types.Dyn k; check ctx ~want:Types.Dyn v ] + in + (* The key's location is the slot's, in the defclass: the + constructor has no other place of its own to name. *) + if tag = None then rt loc Types.Unit "flan_dyn_map_set" args + else rt loc Types.Unit "flan_dyn_slot_init" (args @ [ here k.Ast.loc ])) kvs in (* A shape tag, if this is the literal a class's constructor was written @@ -3900,7 +3994,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = if target.Tast.ty <> Types.Dyn then fail loc "(get m k) is a place only on a class instance, and this is %s. A \ - map's entries are written with (put m k v)" + map's entries are written with put" (Types.to_string target.Tast.ty); let k = check ctx ~want:Types.Dyn k in let v = check ctx ~want:Types.Dyn v in diff --git a/lib/dev.ml b/lib/dev.ml index f620cbf3..172e3325 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1553,8 +1553,8 @@ let defs t = List.map (fun (s, ty) -> match ty with - | Types.Dyn -> s - | ty -> s ^ " " ^ Types.to_string ty) + | Check.Sany -> s + | ty -> s ^ " " ^ Check.slot_text ty) slots, d.Ast.dloc) | _ -> None) diff --git a/lib/emit.ml b/lib/emit.ml index aa363a19..cea599bc 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4475,7 +4475,7 @@ declare i64 @flan_dyn_vec_new() declare i64 @flan_dyn_map_new() declare i64 @flan_dyn_map_new_class(i64, ptr, i64) declare void @flan_dyn_slot_set(i64, i64, i64, ptr, i64) -declare void @flan_dyn_slot_init(i64, i64, i64) +declare void @flan_dyn_slot_init(i64, i64, i64, ptr, i64) declare void @flan_dyn_map_put(i64, i64, i64, ptr, i64) declare i64 @flan_dyn_class_of(i64) declare void @flan_dyn_class_def(i64, ptr, i64) diff --git a/lib/load.ml b/lib/load.ml index 069a8808..2bb554c3 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -504,15 +504,21 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = A class's slot names are not renamed. They are keywords in the map the constructor builds, and a keyword belongs to nobody — the same line the - [MapLit] arm above takes about a map literal's keys. A slot's *type* is - a type like any other, and the vector is unpaired, so it goes through - [rename_pitem] as a [defn]'s does: a bare symbol the package owns is a - type of this package, since no slot name is ever an owned name that - matters. The *class's* name is qualified, so [pkg/point] is what an - instance's shape tag reads and two packages' [point] classes are two - classes. *) + [MapLit] arm above takes about a map literal's keys. The vector is + unpaired, so a bare symbol in it may be a slot's name, and none is + touched; a type written as a form is renamed as any type is. A bare + class name in a type position is found by [Check.pair_slots] against + the class's own package instead. The *class's* name is qualified, so + [pkg/point] is what an instance's shape tag reads and two packages' + [point] classes are two classes. *) | Ast.Defclass (n, slots) -> - Ast.Defclass (qualify alias n, List.map (rename_pitem owned alias) slots) + Ast.Defclass + (qualify alias n, + List.map + (function + | Ast.Pname _ as p -> p + | Ast.Ptype t -> Ast.Ptype (rename_texpr owned alias t)) + slots) (* A generic's parameters are dyn and were written out by the parser, so there is no unpaired vector here and [bound] is exactly the parameter names. *) diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 99472218..190b616e 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1179,9 +1179,10 @@ flan_dyn flan_dyn_map_new(void) { * reason", defers unknown-slot checking — so a key nobody declared can be * written to one, and the migration below will *drop* it at the next * redefinition, because its rule is that an instance's keys are the class's - * slots. [set] does refuse one, because a slot it writes has to exist. That is real data loss and it is written down as such in TODO.org, + * slots. That is real data loss and it is written down as such in TODO.org, * "A redefined defclass migrates its instances lazily", rather than dressed - * up as enforcement. + * up as enforcement. [set] does refuse an undeclared key, because a slot it + * writes has to exist. * * **Where a migration happens.** [want_map], so every [get], [put] and * [has-key?]; [flan_dyn_len]'s map arm; and [dyn_equal]'s, so two instances @@ -1222,15 +1223,20 @@ flan_dyn flan_dyn_map_new(void) { flan_dyn flan_dyn_kw(const uint8_t *p, int64_t n); /* What a slot may hold. A dyn value's tag is the whole of what can be asked - * of it, so these are the tags, plus a range on top of the int tag for a - * slot declared with a narrower integer type. [word] is the type as the - * defclass wrote it, for the sentence a refusal prints. */ -enum { ST_ANY, ST_BOOL, ST_INT, ST_FLOAT, ST_TEXT }; + * of it, so these are the tags — plus a range on top of the int tag for a + * narrower integer type, the significand a float slot holds exactly, a + * class for a slot declared with one, and whether nil is admitted, which is + * what (Option T) says. [word] is a scalar type's name, for the sentence a + * refusal prints. */ +enum { ST_ANY, ST_BOOL, ST_INT, ST_FLOAT, ST_TEXT, ST_CLASS }; typedef struct slot_type { uint8_t kind; + uint8_t opt; /* nil admitted: (Option T) */ + uint8_t fbits; /* ST_FLOAT: 53 for f64, 24 for f32 */ int64_t lo, hi; /* ST_INT only */ - const char *word; /* static; NULL for ST_ANY */ + kw_entry *cls; /* ST_CLASS only */ + const char *word; /* static; NULL for ST_ANY and ST_CLASS */ } slot_type; typedef struct class_entry { @@ -1243,6 +1249,9 @@ typedef struct class_entry { uint32_t *warned; int64_t nslots; uint32_t gen; + /* Whether any slot has a type. A class with none pays nothing at a store + * beyond reading this. */ + int typed; } class_entry; static class_entry *classes; @@ -1264,26 +1273,41 @@ static uint32_t class_gen(kw_entry *name) { return e == NULL ? 0u : e->gen; } +/* One slot's type, as [Check.class_spec_of] writes it: a scalar type's name, + * [#name] for a class, and a leading [?] for an (Option T). */ static slot_type slot_type_of(const uint8_t *w, int64_t n) { - static const struct { const char *w; uint8_t kind; int64_t lo, hi; } known[] = { - { "bool", ST_BOOL, 0, 0 }, - { "string", ST_TEXT, 0, 0 }, - { "f32", ST_FLOAT, 0, 0 }, - { "f64", ST_FLOAT, 0, 0 }, - { "i8", ST_INT, INT8_MIN, INT8_MAX }, - { "i16", ST_INT, INT16_MIN, INT16_MAX }, - { "i32", ST_INT, INT32_MIN, INT32_MAX }, - { "i64", ST_INT, INT64_MIN, INT64_MAX }, - { "u8", ST_INT, 0, UINT8_MAX }, - { "u16", ST_INT, 0, UINT16_MAX }, - { "u32", ST_INT, 0, UINT32_MAX }, - { "u64", ST_INT, 0, INT64_MAX }, + static const struct { + const char *w; uint8_t kind, fbits; int64_t lo, hi; + } known[] = { + { "bool", ST_BOOL, 0, 0, 0 }, + { "string", ST_TEXT, 0, 0, 0 }, + { "f32", ST_FLOAT, 24, 0, 0 }, + { "f64", ST_FLOAT, 53, 0, 0 }, + { "i8", ST_INT, 0, INT8_MIN, INT8_MAX }, + { "i16", ST_INT, 0, INT16_MIN, INT16_MAX }, + { "i32", ST_INT, 0, INT32_MIN, INT32_MAX }, + { "i64", ST_INT, 0, INT64_MIN, INT64_MAX }, + { "u8", ST_INT, 0, 0, UINT8_MAX }, + { "u16", ST_INT, 0, 0, UINT16_MAX }, + { "u32", ST_INT, 0, 0, UINT32_MAX }, + { "u64", ST_INT, 0, 0, INT64_MAX }, }; - slot_type t = { ST_ANY, 0, 0, NULL }; + slot_type t = { ST_ANY, 0, 0, 0, 0, NULL, NULL }; size_t i; + if (n > 0 && w[0] == '?') { + t = slot_type_of(w + 1, n - 1); + if (t.kind != ST_ANY) t.opt = 1; + return t; + } + if (n > 1 && w[0] == '#') { + t.kind = ST_CLASS; + t.cls = dyn_kw(flan_dyn_kw(w + 1, n - 1)); + return t; + } for (i = 0; i < sizeof known / sizeof known[0]; i++) if ((int64_t)strlen(known[i].w) == n && memcmp(known[i].w, w, (size_t)n) == 0) { t.kind = known[i].kind; + t.fbits = known[i].fbits; t.lo = known[i].lo; t.hi = known[i].hi; t.word = known[i].w; @@ -1294,12 +1318,52 @@ static slot_type slot_type_of(const uint8_t *w, int64_t n) { return t; } -static int slot_fits(const slot_type *t, flan_dyn v) { +static int slot_type_eq(const slot_type *a, const slot_type *b) { + return a->kind == b->kind && a->opt == b->opt && a->fbits == b->fbits + && a->lo == b->lo && a->hi == b->hi && a->cls == b->cls; +} + +/* The type as it was written, for a sentence. */ +static void slot_type_text(const slot_type *t, char *buf, size_t cap) { + char base[96]; + if (t->kind == ST_CLASS) + snprintf(base, sizeof base, "%.*s", (int)t->cls->len, + (const char *)(t->cls + 1)); + else + snprintf(base, sizeof base, "%s", t->word != NULL ? t->word : "dyn"); + if (t->opt) snprintf(buf, cap, "(Option %s)", base); + else snprintf(buf, cap, "%s", base); +} + +/* Whether [v] may be stored in a slot of type [t], and what is stored: [v] + * itself, or — for an int into a float slot — the float it widens to. The + * widening is the typed side's rule read off the value rather than off a + * static type: an integer the float's significand holds exactly is admitted + * as that float, and one it does not is refused, as (f64 x) would be for the + * type that could hold it. A float into an f32 slot has to be one an f32 + * holds, which is the typed side refusing f64 into f32. */ +static int slot_admit(const slot_type *t, flan_dyn v, flan_dyn *out) { int tag = flan_dyn_tag(v); + *out = v; + if (t->kind == ST_ANY) return 1; + if (tag == FLAN_DYN_TAG_NIL) return t->opt; switch (t->kind) { case ST_BOOL: return tag == FLAN_DYN_TAG_BOOL; case ST_TEXT: return tag == FLAN_DYN_TAG_TEXT; - case ST_FLOAT: return tag == FLAN_DYN_TAG_FLOAT; + case ST_CLASS: + return tag == FLAN_DYN_TAG_MAP && dyn_obj(v)->u.v.klass == t->cls; + case ST_FLOAT: + if (tag == FLAN_DYN_TAG_FLOAT) { + double d = dyn_num_value(v); + return t->fbits == 53 || d != d || (double)(float)d == d; + } + if (tag == FLAN_DYN_TAG_INT) { + int64_t x = dyn_int_value(v), lim = (int64_t)1 << t->fbits; + if (x < -lim || x > lim) return 0; + *out = flan_dyn_from_f64((double)x); + return 1; + } + return 0; case ST_INT: { int64_t x; if (tag != FLAN_DYN_TAG_INT) return 0; @@ -1310,6 +1374,11 @@ static int slot_fits(const slot_type *t, flan_dyn v) { } } +static int slot_fits(const slot_type *t, flan_dyn v) { + flan_dyn ignored; + return slot_admit(t, v, &ignored); +} + /* A class's slots as the compiler hands them over: one line per slot, the * slot's name and then, after a space, its type's name — nothing for a slot * written with no type. The same string comes from a constructor and from a @@ -1365,6 +1434,12 @@ static void class_add(kw_entry *k, kw_entry **list, slot_type *types, if (count > 0 && classes[classes_n].warned == NULL) trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); classes[classes_n].nslots = count; + classes[classes_n].typed = 0; + { + int64_t j; + for (j = 0; j < count; j++) + if (types[j].kind != ST_ANY) classes[classes_n].typed = 1; + } /* One, never zero: an instance built before this registration carries zero * and has to be seen as stale, because the definition it was built from is * exactly the one nobody recorded. */ @@ -1401,8 +1476,7 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { int same = e->nslots == count; if (same) for (i = 0; i < count; i++) - if (e->slots[i] != list[i] || e->types[i].kind != types[i].kind - || e->types[i].lo != types[i].lo || e->types[i].hi != types[i].hi) { + if (e->slots[i] != list[i] || !slot_type_eq(&e->types[i], &types[i])) { same = 0; break; } @@ -1417,6 +1491,9 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { if (count > 0 && e->warned == NULL) trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); e->nslots = count; + e->typed = 0; + for (i = 0; i < count; i++) + if (types[i].kind != ST_ANY) e->typed = 1; /* Wrapping is not a correctness question — what matters is that the new * generation differs from the one the live instances carry — but zero is * reserved for "no definition registered", so it is stepped over. */ @@ -1522,11 +1599,49 @@ static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added, } } +/* An entry at the end of a map, with no lookup first: for a map whose keys + * are known to be distinct already. A lookup compares keys with [dyn_equal], + * which migrates any stale instance it meets and runs that instance's hook — + * and a migration building its own hook's arguments must not start another + * one, or the instance it is migrating is migrated again inside itself. */ +static void map_append(flan_obj *m, flan_dyn k, flan_dyn v) { + if (m->len == m->u.v.cap) { + int64_t cap = m->u.v.cap ? m->u.v.cap * 2 : 8; + flan_dyn *items = + (flan_dyn *)realloc(m->u.v.items, (size_t)cap * 2 * sizeof *items); + if (items == NULL) trap_oom(NULL, 0, cap * 2 * (int64_t)sizeof *items); + gc_bytes += (cap - m->u.v.cap) * 2 * (int64_t)sizeof *items; + m->u.v.items = items; + m->u.v.cap = cap; + } + m->u.v.items[m->len * 2] = k; + m->u.v.items[m->len * 2 + 1] = v; + m->len++; +} + +/* Which of [o]'s entries is the slot [s], or -1. The interned identity + * compare, never [dyn_equal]: see [map_append]. [flan_dyn_tag] and not a + * bare [dyn_box]: a float is not boxed at all, so its payload bits can read + * as any box tag, and reading a non-keyword's payload as a [kw_entry *] is a + * wild pointer. A raw [put] can have left a float — or anything else — as a + * key. */ +static int64_t entry_of(flan_obj *o, kw_entry *s) { + int64_t i; + for (i = 0; i < o->len; i++) { + flan_dyn key = o->u.v.items[i * 2]; + if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD && dyn_kw(key) == s) + return i; + } + return -1; +} + /* The migration. [o] is left holding exactly the class's current slots, in * the class's order, with the values it already had for the ones it still - * has and nil for the ones it has just gained — which is precisely the - * property CLHS 4.3.6 guarantees, matched by name, with the instance's - * identity preserved because none of this allocates a new object. + * has — which is the property CLHS 4.3.6 guarantees, matched by name, with + * the instance's identity preserved because none of this allocates a new + * object. A slot it has just gained holds its type's zero value, Flan's + * zero-is-initialisation — false, 0, 0.0, the empty string — or nil where + * the type admits nil or has no zero: a dyn slot, an (Option T), a class. * * Rebuilt into a fresh block rather than compacted in place, and the order is * the class's rather than the instance's, so that a migrated instance is @@ -1535,120 +1650,145 @@ static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added, * and count in insertion order and would have. One malloc per instance per * redefinition is the price, and a migration happens once. * - * The name-matching allocates nothing on the collector's heap, so no - * collection can run part-way through it and see an object whose [len] and - * [items] disagree. The hook's arguments are built before it starts, while - * [o] still holds its old entries whole, and the hook runs after it ends. + * In three steps, and the order is what keeps it sound. * - * Nor can it free a block something above it is walking. The block it frees - * is [o]'s, and every caller syncs [o] before it starts walking [o] — so a - * re-entry through a nested [dyn_equal], including a map used as a key of - * itself, finds [o] already current and returns at the generation compare. - * The key scan here uses the interned identity compare and calls - * [dyn_equal] not at all, so it cannot re-enter from inside. */ -static void class_sync(flan_obj *o) { - class_entry *e; + * First, everything that allocates on the collector's heap: the hook's + * arguments, and an empty string for a gained string slot. A collection may + * run here, while [o] still holds its old entries whole. Nothing in this + * step compares a key with [dyn_equal] — see [map_append] — so nothing in it + * can migrate another instance and run a hook inside this migration. + * + * Second, the name-matching, which allocates nothing on the collector's + * heap, calls nothing that can migrate, and finishes by stamping [o] + * current. [e] is read only up to here: a hook may build an instance of a + * class the registry has not seen, and adding it moves [classes]. + * + * Third, the hook, on an instance that is already current, so a method that + * reads or writes it finds it migrated and does not start a second + * migration. A method may touch anything, including a map something above + * this frame is walking; the migration of [o] itself is finished before it + * runs. */ +/* Kept out of line: inlined into [class_sync], its frame and saved + * registers were paid on every [get] and [put] of every map, current or not + * — measured at about a tenth of an untyped [put]'s instructions. */ +__attribute__((noinline)) +static void class_migrate(flan_obj *o, class_entry *e) { flan_dyn *fresh = NULL; - int64_t i, j; - /* The hook's three arguments, rooted by address for as long as the hook - * may run: each is a collector object held nowhere else. */ - flan_dyn inst, added, gone; + int64_t i, j, n; + /* Rooted by address for as long as they may be needed: each is a + * collector object held nowhere else. */ + flan_dyn inst, added, gone, empty; int64_t roots_at = roots_n; - int hook; - if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return; - e = class_find(o->u.v.klass); - if (e == NULL || e->gen == o->gen) return; + int hook, need_empty = 0; + n = e->nslots; /* CLHS 4.3.6: the method runs on every instance a redefinition reaches, * whether or not the slot names moved — a changed type is a change a * method may want to convert for. */ hook = migrate_fn != NULL && flan_dyn_migrate_hook != NULL; + for (j = 0; j < n; j++) + if (e->types[j].kind == ST_TEXT && !e->types[j].opt + && entry_of(o, e->slots[j]) < 0) + need_empty = 1; inst = dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); - added = gone = dyn_make(BOX_NIL, 0); + added = gone = empty = dyn_make(BOX_NIL, 0); + if (hook || need_empty) root_add(&inst, NULL); + if (need_empty) { + empty = flan_dyn_from_bytes((const uint8_t *)"", 0); + root_add(&empty, NULL); + } if (hook) { - root_add(&inst, NULL); added = flan_dyn_vec_new(); root_add(&added, NULL); gone = flan_dyn_map_new(); root_add(&gone, NULL); - for (j = 0; j < e->nslots; j++) { - for (i = 0; i < o->len; i++) { - flan_dyn key = o->u.v.items[i * 2]; - if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD - && dyn_kw(key) == e->slots[j]) break; - } - if (i == o->len) + for (j = 0; j < n; j++) + if (entry_of(o, e->slots[j]) < 0) flan_dyn_push(added, dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]), NULL, 0); - } /* Every key the class no longer declares, a raw [put]'s included: - * CLHS's discarded slots and their property list, as one map. */ + * CLHS's discarded slots and their property list, as one map. [o]'s + * keys are distinct, so these are, and they are appended as they are. */ for (i = 0; i < o->len; i++) { flan_dyn key = o->u.v.items[i * 2]; int kept = 0; if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD) - for (j = 0; j < e->nslots; j++) + for (j = 0; j < n; j++) if (dyn_kw(key) == e->slots[j]) { kept = 1; break; } - if (!kept) flan_dyn_map_set(gone, key, o->u.v.items[i * 2 + 1]); + if (!kept) map_append(dyn_obj(gone), key, o->u.v.items[i * 2 + 1]); } } - if (e->nslots > 0) { - fresh = (flan_dyn *)malloc((size_t)e->nslots * 2 * sizeof *fresh); - if (fresh == NULL) trap_oom(NULL, 0, e->nslots * 2 * (int64_t)sizeof *fresh); + if (n > 0) { + fresh = (flan_dyn *)malloc((size_t)n * 2 * sizeof *fresh); + if (fresh == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *fresh); } - for (j = 0; j < e->nslots; j++) { - flan_dyn v = dyn_make(BOX_NIL, 0); - for (i = 0; i < o->len; i++) { - flan_dyn key = o->u.v.items[i * 2]; - /* [flan_dyn_tag] and not a bare [dyn_box]: a float is not boxed at - all, so its payload bits can read as any box tag, and reading a - non-keyword's payload as a [kw_entry *] is a wild pointer. A raw - [put] can have left a float — or anything else — in here. */ - if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD - && dyn_kw(key) == e->slots[j]) { - v = o->u.v.items[i * 2 + 1]; - /* A kept value that the slot's new type does not admit is kept - anyway: throwing it away would be the data loss a redefinition - exists to avoid, and there is nothing to convert it to. What it - gets is a warning, once per slot per redefinition, and the next - write to the slot is checked like any other. A slot the class - has only just gained holds nil without a word: it holds nothing, - rather than something of the wrong type. */ - if (!slot_fits(&e->types[j], v) && e->warned[j] != e->gen) { - char sv[SAY_MAX]; - kw_entry *c = o->u.v.klass, *sl = e->slots[j]; - e->warned[j] = e->gen; - say(sv, SAY_MAX, v); - fflush(stdout); - fprintf(stderr, - "warning: %.*s was redefined, and its slot :%.*s is now " - "declared %s. An instance holds %s there, which is %s; it " - "keeps that value, and the next write to :%.*s is checked\n", - (int)c->len, (const char *)(c + 1), - (int)sl->len, (const char *)(sl + 1), e->types[j].word, sv, - tag_of(v), (int)sl->len, (const char *)(sl + 1)); - } - break; + for (j = 0; j < n; j++) { + const slot_type *t = &e->types[j]; + flan_dyn v; + i = entry_of(o, e->slots[j]); + if (i >= 0) { + v = o->u.v.items[i * 2 + 1]; + /* A kept value that the slot's new type does not admit is kept + anyway: throwing it away would be the data loss a redefinition + exists to avoid, and there is nothing to convert it to. What it + gets is a warning, once per slot per redefinition, and the next + write to the slot is checked like any other. */ + if (!slot_fits(t, v) && e->warned[j] != e->gen) { + char sv[SAY_MAX], st[128]; + kw_entry *c = o->u.v.klass, *sl = e->slots[j]; + e->warned[j] = e->gen; + say(sv, SAY_MAX, v); + slot_type_text(t, st, sizeof st); + fflush(stdout); + fprintf(stderr, + "warning: %.*s was redefined, and its slot :%.*s is now " + "declared %s. An instance holds %s there, which is %s; it " + "keeps that value, and the next write to :%.*s is checked\n", + (int)c->len, (const char *)(c + 1), + (int)sl->len, (const char *)(sl + 1), st, sv, + tag_of(v), (int)sl->len, (const char *)(sl + 1)); } } + else if (t->opt) v = dyn_make(BOX_NIL, 0); + else + switch (t->kind) { + case ST_BOOL: v = flan_dyn_from_bool(0); break; + case ST_INT: v = flan_dyn_from_i64(0); break; + case ST_FLOAT: v = flan_dyn_from_f64(0.0); break; + case ST_TEXT: v = empty; break; + default: v = dyn_make(BOX_NIL, 0); break; + } fresh[j * 2] = dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]); fresh[j * 2 + 1] = v; } /* Charged the way [map_set]'s growth is, in both directions: a class that * lost slots gives the bytes back, or the trigger drifts up by whatever * every migration in the program ever released. */ - gc_bytes += (e->nslots - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn); + gc_bytes += (n - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn); free(o->u.v.items); o->u.v.items = fresh; - o->u.v.cap = e->nslots; - o->len = e->nslots; - /* Current before the hook runs, so a method that reads or writes the - * instance finds it migrated and does not start a second migration. */ + o->u.v.cap = n; + o->len = n; o->gen = e->gen; - if (hook) class_hook(o, inst, added, gone, e->nslots); + e = NULL; + if (hook) class_hook(o, inst, added, gone, n); roots_n = roots_at; } +/* Every read or write of an instance comes through here first: the class's + * entry, with [o] migrated to it if it was stale, or NULL for a map with no + * class. The common case — current — is a lookup and a compare, and the + * migration is a call of its own so that it stays out of the way. The entry + * is looked up again after one, because a hook may have moved the table. */ +static class_entry *class_sync(flan_obj *o) { + class_entry *e; + if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return NULL; + e = class_find(o->u.v.klass); + if (e == NULL || e->gen == o->gen) return e; + class_migrate(o, e); + return class_find(o->u.v.klass); +} + /* The same map with a shape tag on it: what a (defclass ...) constructor * calls. [k] is a keyword and anything else traps by name — the compiler * hands it the class's own name and nothing else can reach this. @@ -2563,20 +2703,27 @@ enum { BY_PUT, BY_SET, BY_NEW }; static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, int by, flan_obj *o, class_entry *e, int64_t j, flan_dyn m, flan_dyn v) { - char sm[SAY_MAX], sv[SAY_MAX]; + char sm[SAY_MAX], sv[SAY_MAX], st[128]; + const slot_type *t = &e->types[j]; kw_entry *sl = e->slots[j], *c = o->u.v.klass; int sn = (int)sl->len, cn = (int)c->len; const char *ss = (const char *)(sl + 1), *cs = (const char *)(c + 1); say(sm, SAY_MAX, m); say(sv, SAY_MAX, v); + slot_type_text(t, st, sizeof st); fflush(stdout); trap_where(loc, loclen); fprintf(stderr, "dyn %s: the slot :%.*s of %.*s is declared %s, and ", by == BY_PUT ? "put" : by == BY_SET ? "set" : "construct", sn, ss, - cn, cs, e->types[j].word); - /* An int of the wrong size is the right tag, so the tag is not the news. */ - if (e->types[j].kind == ST_INT && flan_dyn_tag(v) == FLAN_DYN_TAG_INT) - fprintf(stderr, "%s is outside its range — ", sv); + cn, cs, st); + /* A number of the right kind that does not fit is not news about its tag. */ + if ((t->kind == ST_INT && flan_dyn_tag(v) == FLAN_DYN_TAG_INT) + || (t->kind == ST_FLOAT + && (flan_dyn_tag(v) == FLAN_DYN_TAG_INT + || flan_dyn_tag(v) == FLAN_DYN_TAG_FLOAT))) + fprintf(stderr, "%s is not a value it holds exactly — ", sv); + else if (t->kind == ST_CLASS && flan_dyn_tag(v) == FLAN_DYN_TAG_MAP) + fprintf(stderr, "this is not an instance of it — "); else fprintf(stderr, "this is %s — ", tag_of(v)); if (by == BY_PUT) @@ -2588,26 +2735,32 @@ static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, flan_trap((const uint8_t *)"DynType", 7); } -static void check_slot(const uint8_t *loc, int64_t loclen, int by, - flan_obj *o, flan_dyn m, flan_dyn k, flan_dyn v) { - class_entry *e; +/* The value a store into [o] under [k] actually stores: [v], or the float an + * int widens to in a float slot. A class with no typed slot answers at its + * flag, and a map with no class before that. */ +static flan_dyn check_slot(const uint8_t *loc, int64_t loclen, int by, + flan_obj *o, class_entry *e, flan_dyn m, + flan_dyn k, flan_dyn v) { int64_t j; - if (o->u.v.klass == NULL) return; - e = class_find(o->u.v.klass); + flan_dyn out; + if (e == NULL || !e->typed) return v; j = class_slot(e, k); - if (j >= 0 && !slot_fits(&e->types[j], v)) + if (j < 0) return v; + if (!slot_admit(&e->types[j], v, &out)) trap_slot_type(loc, loclen, by, o, e, j, m, v); + return out; } -static void map_store(flan_obj *o, flan_dyn k, flan_dyn v); +static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v); /* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for * the constructor call it happened inside rather than for a [put] nobody - * wrote. */ -void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v) { + * wrote, and placed at the slot's declaration. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen) { flan_obj *o = want_map("construct", m, k); - check_slot(NULL, 0, BY_NEW, o, m, k, v); - map_store(o, k, v); + class_entry *e = o->u.v.klass == NULL ? NULL : class_find(o->u.v.klass); + map_store(o, k, check_slot(loc, loclen, BY_NEW, o, e, m, k, v)); } /* (set (get inst :slot) v). Three refusals, each its own sentence, because @@ -2621,6 +2774,7 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, flan_obj *o; class_entry *e; int64_t j; + flan_dyn out; if (!is_map(m) || dyn_obj(m)->u.v.klass == NULL) { char sm[SAY_MAX]; say(sm, SAY_MAX, m); @@ -2628,15 +2782,13 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, trap_where(loc, loclen); fprintf(stderr, "dyn set: (get m k) is a place only on a class instance, and " - "this is %s%s — %s. A map's entries are written with " - "(put m k v)\n", + "this is %s%s — %s. A map's entries are written with put\n", is_map(m) ? "a map with no class" : "a ", is_map(m) ? "" : tag_of(m), sm); flan_trap((const uint8_t *)"DynType", 7); } o = dyn_obj(m); - class_sync(o); - e = class_find(o->u.v.klass); + e = class_sync(o); j = class_slot(e, k); if (j < 0) { char sk[SAY_MAX]; @@ -2652,23 +2804,24 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, for (i = 0; i < e->nslots; i++) fprintf(stderr, " :%.*s", (int)e->slots[i]->len, (const char *)(e->slots[i] + 1)); - fprintf(stderr, "; a key the class does not declare is written with " - "(put inst k v)\n"); + fprintf(stderr, "; a key the class does not declare is added with put, " + "not set\n"); flan_trap((const uint8_t *)"DynType", 7); } - if (!slot_fits(&e->types[j], v)) + if (!slot_admit(&e->types[j], v, &out)) trap_slot_type(loc, loclen, BY_SET, o, e, j, m, v); - map_store(o, k, v); + map_store(o, k, out); } -/* [put]: a key the class declares is checked against its type, and the - * refusal names [loc]. A key it does not declare is let through: an - * instance is an open map to [put], and the next redefinition drops such a - * key — see "Classes" above. */ void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, int64_t loclen) { - flan_obj *o = want_map("put", m, k); - check_slot(loc, loclen, BY_PUT, o, m, k, v); + flan_obj *o; + class_entry *e; + if (!is_map(m)) trap2(NULL, 0, TYPE_TRAP, "put", "only a map answers it", m, k); + o = dyn_obj(m); + e = class_sync(o); + /* A map with no class, and a class with no typed slot, stop at the test. */ + if (e != NULL && e->typed) v = check_slot(loc, loclen, BY_PUT, o, e, m, k, v); map_store(o, k, v); } @@ -2678,7 +2831,7 @@ void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) { } /* The store under all three, with the instance already brought up to date. */ -static void map_store(flan_obj *o, flan_dyn k, flan_dyn v) { +static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v) { int64_t i = map_find(o, k); if (i >= 0) { o->u.v.items[i * 2 + 1] = v; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index df8020e5..077107a1 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -92,7 +92,8 @@ flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n); /* A constructor's store into a slot, checked against the slot's declared * type — [flan_dyn_map_set] with a refusal worded for the constructor. */ -void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v); +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); /* (set (get inst :slot) v): [m] must be a class instance and [k] a slot its * class declares, and [v] must fit the slot's type; each is a trap with its diff --git a/test/dyn_ops.c b/test/dyn_ops.c index c4f4d292..70f05f61 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -1238,6 +1238,89 @@ static void classes(void) { printf(failures == 0 ? "classes ok\n" : "classes failed\n"); } +/* ── update-instance-for-redefined-class, re-entered ───────────────── + * + * The hook is Flan in a program; here it is C, installed where the agent + * installs its caller, which is the same call from flan_dyn.c's side. Three + * stale instances, the first holding the other two as keys of raw [put]s, so + * building the first one's discarded map is where a lookup would compare + * them — and migrate them, and run their hooks, inside the first one's + * migration. The hook itself touches the first instance and builds + * instances of classes the registry has not seen, which grows it and moves + * it under any migration still holding an entry. Each instance's hook runs + * once, and the discarded map holds both instance keys. Clean under + * memcheck is the other half of the claim, and is what @valgrind's run of + * this mode says. */ +extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, uint64_t added, + uint64_t discarded); +void flan_dyn_class_hook(void *fn); + +static flan_dyn hk_p, hk_q, hk_r; +static int hk_runs_p, hk_runs_q, hk_runs_r, hk_fresh; +static int64_t hk_gone_len = -1; + +static int hk_call(void *fn, uint64_t instance, uint64_t added, + uint64_t discarded) { + char name[16]; + int i; + (void)fn; + (void)added; + if (instance == hk_p) { + hk_runs_p++; + hk_gone_len = flan_dyn_need_i64(flan_dyn_len(discarded)); + } + if (instance == hk_q) hk_runs_q++; + if (instance == hk_r) hk_runs_r++; + (void)slot(hk_p, "x"); + for (i = 0; i < 20; i++) { + snprintf(name, sizeof name, "fresh%d", hk_fresh++); + (void)flan_dyn_map_new_class( + flan_dyn_kw((const uint8_t *)name, (int64_t)strlen(name)), + (const uint8_t *)"a", 1); + } + return 0; +} + +static void hook_reentry(void) { + flan_dyn_root_push(&hk_p); + flan_dyn_root_push(&hk_q); + flan_dyn_root_push(&hk_r); + define("pt", "x\ny"); + hk_p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + hk_q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + hk_r = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + flan_dyn_map_set(hk_p, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(1)); + /* Distinct, or they are one key: instances compare by their slots. */ + flan_dyn_map_set(hk_q, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(2)); + flan_dyn_map_set(hk_r, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(3)); + flan_dyn_map_set(hk_p, hk_q, flan_dyn_from_i64(2)); + flan_dyn_map_set(hk_p, hk_r, flan_dyn_from_i64(3)); + flan_dyn_migrate_hook = hk_call; + flan_dyn_class_hook((void *)hk_call); + define("pt", "x\ny\nz"); + check(flan_dyn_need_i64(slot(hk_p, "x")) == 1, "a kept slot after a re-entered hook"); + check(hk_runs_p == 1, "the first instance's hook ran once"); + check(hk_runs_q == 0 && hk_runs_r == 0, + "building the first instance's arguments migrated no other instance"); + check(hk_gone_len == 2, "the discarded map holds both instance keys"); + (void)slot(hk_q, "x"); + (void)slot(hk_r, "x"); + (void)slot(hk_q, "x"); + check(hk_runs_q == 1 && hk_runs_r == 1, + "each other instance runs its hook once, at its own first touch"); + check(hk_runs_p == 1, "and the first instance's did not run again"); + flan_dyn_migrate_hook = NULL; + flan_dyn_class_hook(NULL); + flan_dyn_root_pop(3); + printf(failures == 0 ? "hook ok\n" : "hook failed\n"); +} + int main(int argc, char **argv) { flan_rt_init(argc, argv); if (argc < 2) { @@ -1255,6 +1338,10 @@ int main(int argc, char **argv) { if (strcmp(argv[1], "unrooted") == 0) { unrooted(); return 0; } if (strcmp(argv[1], "park") == 0) { park(); return 0; } if (strcmp(argv[1], "desc") == 0) { desc(); return 0; } + if (strcmp(argv[1], "hook") == 0) { + hook_reentry(); + return failures == 0 ? 0 : 1; + } if (strcmp(argv[1], "classes") == 0) { classes(); return failures == 0 ? 0 : 1; diff --git a/test/programs/dyn-class-slots.flan b/test/programs/dyn-class-slots.flan index ea38ef7e..04c875d9 100644 --- a/test/programs/dyn-class-slots.flan +++ b/test/programs/dyn-class-slots.flan @@ -12,6 +12,9 @@ (defclass state [pause bool step i32 speed f64 name string tag]) +;; A class is a slot type, and (Option T) admits nil beside a T. +(defclass node [owner state next (Option node) weight (Option f32)]) + (defn twelve [] i64 12) (defn main [] i32 @@ -34,5 +37,14 @@ (println (length s)) ;; A typed caller boxes into the dyn parameter as any call does. (set (get s :step) (twelve)) - (println (get s :step))) + (println (get s :step)) + ;; An int into a float slot widens, as it does into a typed f64 + ;; parameter, when the float holds it exactly. + (put s :speed 3) + (println (+ (get s :speed) 0.5)) + (let [n (node s nil nil)] + (set (get n :next) (node s nil 2)) + (println (get (get n :next) :weight)) + (set (get n :weight) nil) + (println (class-of (get n :owner))))) 0) diff --git a/test/programs/dyn-slot-trap.flan b/test/programs/dyn-slot-trap.flan index 15a025ca..890489bc 100644 --- a/test/programs/dyn-slot-trap.flan +++ b/test/programs/dyn-slot-trap.flan @@ -2,6 +2,7 @@ ;;;; process. The argument chooses which. The line numbers are asserted by ;;;; the test, so an edit above them moves them. (defclass state [pause bool step i32 tag]) +(defclass node [owner state]) (defn as-dyn [d dyn] dyn d) @@ -14,5 +15,7 @@ (= which 1) (put s :pause 1) (= which 2) (set (get s :step) 5000000000) (= which 3) (set (get s :paws) true) - :else (set (get (as-dyn {:pause 1}) :pause) true))) + (= which 4) (set (get (as-dyn {:pause 1}) :pause) true) + (= which 5) (println (node (node s))) + :else (println (state nil 1 2)))) 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index d9853976..c913eff1 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5069,7 +5069,7 @@ level "1" whose arguments the two emit separately. *) let slots_out = "#state{ :pause false :step 3 :speed 1.5 :name \"sand\" :tag :x}\n\ - true\n-7\n[ 1 2]\n2.5\n9\n6\n12\n" + true\n-7\n[ 1 2]\n2.5\n9\n6\n12\n3.5\n2\n:state\n" in outputs "dyn: typed class slots" "programs/dyn-class-slots.flan" slots_out; outputs ~x86:true "dyn: typed class slots, --x86" @@ -5087,16 +5087,23 @@ level "1" (match x86 with Some true -> ", --x86" | _ -> "") text code want end) - [ ("0", "dyn construct: the slot :pause of state is declared bool, \ - and this is int — (state ...) with :pause 1"); - ("1", "dyn-slot-trap.flan:14:19: dyn put: the slot :pause of state \ + [ ("0", "dyn-slot-trap.flan:4:18: dyn construct: the slot :pause of \ + state is declared bool, and this is int — (state ...) with \ + :pause 1"); + ("1", "dyn-slot-trap.flan:15:19: dyn put: the slot :pause of state \ is declared bool, and this is int"); - ("2", "dyn-slot-trap.flan:15:19: dyn set: the slot :step of state \ - is declared i32, and 5000000000 is outside its range"); - ("3", "dyn-slot-trap.flan:16:19: dyn set: state has no slot :paws. \ - Its slots are :pause :step :tag"); - ("4", "dyn-slot-trap.flan:17:13: dyn set: (get m k) is a place only \ - on a class instance, and this is a map with no class") ]; + ("2", "dyn-slot-trap.flan:16:19: dyn set: the slot :step of state \ + is declared i32, and 5000000000 is not a value it holds \ + exactly"); + ("3", "dyn-slot-trap.flan:17:19: dyn set: state has no slot :paws. \ + Its slots are :pause :step :tag; a key the class does not \ + declare is added with put, not set"); + ("4", "dyn-slot-trap.flan:18:19: dyn set: (get m k) is a place only \ + on a class instance, and this is a map with no class"); + ("5", "dyn-slot-trap.flan:5:17: dyn construct: the slot :owner of \ + node is declared state, and this is not an instance of it"); + ("6", "dyn-slot-trap.flan:4:18: dyn construct: the slot :pause of \ + state is declared bool, and this is nil") ]; (try Sys.remove exe with Sys_error _ -> ()) in slot_trap (); diff --git a/test/test_dev.ml b/test/test_dev.ml index fedb3196..4af6b6f5 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -8062,10 +8062,16 @@ let () = "(defmethod update-instance-for-redefined-class point \ [p added discarded] nil)" && defined "a slot's type changed to one its value does not fit" - "(defclass point [x string radius z])" + "(defclass point [x string radius z n i32 note string])" then begin holds "a value that no longer fits is kept" "(if (= (get (at instances 0) :x) 3) 1 0)"; + (* A typed slot gained by the redefinition starts at its type's + zero value, as a typed binding does, and not at nil. *) + holds "a gained i32 slot is 0" + "(if (= (get (at instances 0) :n) 0) 1 0)"; + holds "a gained string slot is empty" + "(if (= (get (at instances 0) :note) \"\") 1 0)"; let warned () = contains_sub (output ()) "warning: point was redefined, and its slot :x is now \ diff --git a/test/test_dyn.ml b/test/test_dyn.ml index 8152b9cf..f2a01e8d 100644 --- a/test/test_dyn.ml +++ b/test/test_dyn.ml @@ -154,6 +154,14 @@ let () = if code <> 0 || out <> "classes ok\n" then fail "redefining a class\n got: %S (exit %d, err %S)" out code err; + (* A migration's hook re-entered from the building of its own + arguments, and a hook that grows the class registry under it — see + dyn_ops.c's [hook_reentry]. *) + let code, out, err = run "hook" in + if code <> 0 || out <> "hook ok\n" then + fail "a re-entered migration hook\n got: %S (exit %d, err %S)" + out code err; + let code, out, _ = run "nested" in if code <> 0 || out <> "chain of 64 intact: yes\n" then fail "a chain of nested vecs\n got: %S (exit %d)" out code; diff --git a/test/test_flan.ml b/test/test_flan.ml index 3c5f016e..7a918afc 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -2718,6 +2718,13 @@ let () = accepts "typed slots, and untyped ones beside them" "(defclass state [pause bool step bool n i32 tag])\n\ (defn main [] i32 (let [s (state false true 3 :x)] (if (= (get s :n) 3) 0 1)))"; + accepts "a class and an Option as slot types" + "(defclass point [x f64])\n\ + (defclass node [at point next (Option node) w (Option i32)])\n\ + (defn main [] i32 (let [n (node (point 1) nil nil)] 0))"; + rejects_check "an Option of dyn is not a slot type" + "(defclass point [x (Option dyn)])\n(defn main [] i32 0)" + ~needle:"the slot x of point is declared (Option dyn)"; rejects_check "a slot's type is one a dyn value can be checked as" "(defclass point [x (Ptr i64)])\n(defn main [] i32 0)" ~needle:"the slot x of point is declared (Ptr i64)"; @@ -3828,7 +3835,7 @@ let () = than as a milestone that will never arrive. *) rejects_check "a map entry as a place" "(defn f [m (Map i64 i64)] () (set (get m 1) 2))" - ~needle:"entries are written with (put m k v)"; + ~needle:"entries are written with put"; rejects_check "get with three arguments is not a place" "(defn f [m dyn] () (set (get m 1 2) 2))" ~needle:"a map is written with (put m k v)"; diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index cc0b2626..a4b13462 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -343,7 +343,7 @@ let dyn_sweep () = the old block, or a [len] that outlived the block it described, is a use-after-free here and nothing anywhere else. *) [ "ops"; "gc"; "unrooted"; "desc"; "nested"; "sharing"; "park"; - "classes" ]; + "classes"; "hook" ]; (try Sys.remove exe with Sys_error _ -> ()) (* A third sweep, over a handful of the same programs built [--dev]. diff --git a/web/index.html b/web/index.html index de3a897e..d033e7da 100644 --- a/web/index.html +++ b/web/index.html @@ -714,7 +714,8 @@ slots, and a slot may be followed by a type, the way a parameter is: [x y] is two slots that hold any value, and [pause bool] is one that holds only a bool. The type is checked whenever a value is stored, and a slot may be bool, an integer type, f32, -f64 or string. The constructor is the class's own name +f64, string, a class, or (Option T) of one of +those, which also admits nil. The constructor is the class's own name and is positional, and class-of answers the tag, or nil for anything that is not an instance. The slots are map keys: get reads one, and set writes one, as in From 325c3662a83c332ef64956547c788c0b7e8e82e3 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 12:56:02 +0700 Subject: [PATCH 13/16] A numeric type's limits are (max-value T) and (min-value T), and an array literal of numbers with no common type is refused with the conversion named --- TODO.org | 8 +- lib/check.ml | 106 ++++++++++++++---- lib/prelude.ml | 3 +- test/programs/{max-of.flan => max-value.flan} | 26 ++--- test/test_acceptance.ml | 8 +- test/test_flan.ml | 38 +++++-- 6 files changed, 131 insertions(+), 58 deletions(-) rename test/programs/{max-of.flan => max-value.flan} (72%) diff --git a/TODO.org b/TODO.org index c7900070..3e632ba1 100644 --- a/TODO.org +++ b/TODO.org @@ -1079,11 +1079,6 @@ An unknown call whose near miss is a value — =(context-allocator)= against =context/allocator=, or a global — says the name is a value written without parentheses, and names no call at all when the call had arguments. -** NEXT (max-value T) and (min-value T) -Decided 2026-09-25: the type-limit constants as a form taking a type, Odin's -max(T), valid at any numeric type or a numeric?-bounded variable. For a float, -min-of is the most negative finite value. - ** NEXT (Ptr const T), the pointer beside [const T] Decided 2026-09-25: addr through a read-only slice gives a (Ptr const T), which nothing writes through; (Ptr T) widens to it and never back; a C parameter @@ -1565,7 +1560,8 @@ static tracking of destroy, which is move semantics. ** DONE A mixed array literal with no want is a dyn vector CLOSED: [2026-09-25] Elements that agree, numbers meeting at the wider, are typed; elements that mix -are a dyn vector. Rules out the first element typing the rest. +are a dyn vector, except numbers with no common type, which are refused. Rules +out the first element typing the rest. * Dev loop diff --git a/lib/check.ml b/lib/check.ml index 076080ec..df9ca55a 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -5792,7 +5792,8 @@ and check_arr ctx ~want loc items = being told what it is — [None], a bare struct — takes the same type. Elements that do not agree — [[10 "Hi"]], a dyn beside anything that is not one — are a dyn vector, which is what the same brackets are where a - dyn is expected. *) + dyn is expected. Numbers that do not agree are refused instead; see + [numbers_disagree]. *) and arr_elem_type ctx (items : Ast.expr list) : Types.t option = let natural (i : Ast.expr) = match i.Ast.e with @@ -5854,9 +5855,52 @@ and arr_elem_type ctx (items : Ast.expr list) : Types.t option = the one worth reading. *) | _, first :: _ -> ignore (check ctx first); None | [], [] -> None) - else List.fold_left - (fun found c -> match found with Some _ -> found | None -> settle c) - None candidates + else + match + List.fold_left + (fun found c -> match found with Some _ -> found | None -> settle c) + None candidates + with + | Some t -> Some t + | None -> + let numeric t = match t with Types.Int _ | Types.Float _ -> true | _ -> false in + if needs = [] && List.for_all numeric (tys @ lit_tys) then + numbers_disagree ctx + (List.filter_map + (fun i -> Option.map (fun t -> (i, t)) (natural i)) items) + else None + +(* Numbers with no type they all meet at — an i32 beside an f32, an i64 beside + a u64 — are refused rather than boxed into a dyn vector: the elements are + all numbers, and which one should move is the program's to say. The fix + named converts the second of the first disagreeing pair, into the float + when one of the two is a float and into the first's type otherwise. *) +and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a = + fun ctx elems -> + match elems with + | [] -> fail Loc.unknown "internal: an array of numbers with no elements" + | (first, t1) :: rest -> + let second, t2 = + match List.find_opt (fun (_, t) -> Types.join t1 t = None) rest with + | Some p -> p + | None -> List.nth elems (List.length elems - 1) + in + let target, moved, moved_ty, other = + match t1, t2 with + | Types.Int _, Types.Float _ -> t2, first, t1, second + | _ -> t1, second, t2, first + in + ignore ctx; + let tn = Types.to_string target in + Loc.failk "check/array-numbers-disagree" moved.Ast.loc + ~notes:[ Loc.note other.Ast.loc (Printf.sprintf "this element is %s" tn) ] + "this array's elements are %s and %s, and neither holds every value of \ + the other — %s" + (Types.to_string moved_ty) tn + (match spell_arg "" moved with + | "" -> + Printf.sprintf "convert the %s element with the %s cast" (Types.to_string moved_ty) tn + | x -> Printf.sprintf "convert one, as in (%s %s)" tn x) (* Elements that do not agree and cannot all become a dyn either: a struct beside a number, a type variable beside a literal. The dyn vector's refusal @@ -7263,6 +7307,16 @@ and file_guard ctx loc ~path_slot ~op mk_steps = missing annotation for a program that had written one. One list, read by both callers, so the next kind of type added cannot be added to one of them. *) +(* An argument written as a type: a type expression, or a bare name that is a + type and not a local or a global of the same spelling. *) +and type_arg ctx (a : Ast.expr) = + type_of_expr a <> None + || (match a.Ast.e with + | Ast.Var n -> + lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) + && type_named ctx n + | _ -> false) + and type_named ctx n = (* A type variable names a type here too, which is what lets [(vec-new t)] and [(vec-new $t)] be written in a generic body: inside an instantiation @@ -7783,31 +7837,34 @@ and named_call ?(qualified = false) ctx ~want loc name args = expect ctx loc ~want (List.fold_left (fun acc arg -> pick acc (check ctx ~want:ty arg)) (pick a b) rest) - (* (max-of T) and (min-of T): the type-limit constants, by type, so a + (* A type handed to the prelude's slice reductions: the reach for the + type-limit constants under the name of the reduction beside them. *) + | ("max-of" | "min-of") + when (not (shadows_builtin ctx loc name)) + && (match args with [ a ] -> type_arg ctx a | _ -> false) -> + let which = if String.equal name "max-of" then "max-value" else "min-value" in + fail loc + "%s reduces a slice to its %s element, and this is a type — the %s value \ + of a type is (%s %s)" + name (if which = "max-value" then "largest" else "least") + (if which = "max-value" then "largest" else "least") which + (spell_arg "i32" (List.hd args)) + (* (max-value T) and (min-value T): the type-limit constants, by type, so a generic body can name its own type's. Odin's max(T) and min(T), and the same answer for a float: the largest finite value and its negation, not - the smallest positive one. Given a value rather than a type, the name is - the prelude's reduction of a slice, and the call is an ordinary one — - the same split [vec-new] makes between a type and an allocator. *) - | ("max-of" | "min-of") - when (match args with - | [ a ] -> - type_of_expr a <> None - || (match a.Ast.e with - | Ast.Var n -> - lookup ctx n = None - && (not (Hashtbl.mem ctx.env.globals n)) - && type_named ctx n - | _ -> false) - | _ -> false) -> + the smallest positive one. *) + | "max-value" | "min-value" -> + arity ctx loc name 1 args; + if not (type_arg ctx (List.hd args)) then + fail (List.hd args).Ast.loc "%s takes a type, as in (%s i32)" name name; let a = List.hd args in let ty = match type_of_expr a, a.Ast.e with | Some t, _ -> resolve ctx.env t | _, Ast.Var n -> resolve_name ctx.env ~seen:[] a.Ast.loc n - | _ -> fail a.Ast.loc "internal: max-of's type argument is not a type" + | _ -> fail a.Ast.loc "internal: %s's type argument is not a type" name in - let max = String.equal name "max-of" in + let max = String.equal name "max-value" in let v = match ty with | Types.Int k -> @@ -10734,6 +10791,13 @@ let builtins : (string * string * string) list = i16-y) is an i16."); ("max", "max [ordered? ...] ordered?", "The largest of two or more operands, each evaluated exactly once."); + ("max-value", "max-value [type] T", + "The largest value of a numeric type: (max-value u8) is 255, and at a \ + float the largest finite value. Takes a type variable under \ + {:where (numeric? $t)}."); + ("min-value", "min-value [type] T", + "The least value of a numeric type: (min-value i8) is -128, 0 at an \ + unsigned type, and at a float the negation of the largest finite value."); ("zeroed", "zeroed [] T", "The all-bytes-zero value of whatever it is being stored into, so it \ only means anything where a type is expected of it."); diff --git a/lib/prelude.ml b/lib/prelude.ml index 959d1c96..9eb5ce04 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -427,8 +427,7 @@ let source = {flan| ;; or more numbers, and a defn cannot shadow a builtin: nothing shadows [+] ;; either. These reduce a slice, which is a different operation with a ;; different arity, so the different name is honest rather than a workaround. -;; Given a type instead of a slice, (min-of i8) and (max-of $t) are the type's -;; limits, and the checker answers those itself. +;; A type's own limits are (min-value T) and (max-value T). (defn min-of [s [$t]] (Option $t) {:where (ordered? $t)} (if (= (length s) 0) diff --git a/test/programs/max-of.flan b/test/programs/max-value.flan similarity index 72% rename from test/programs/max-of.flan rename to test/programs/max-value.flan index 2b5f5e76..70015390 100644 --- a/test/programs/max-of.flan +++ b/test/programs/max-value.flan @@ -1,4 +1,4 @@ -;;;; (max-of T) and (min-of T): a numeric type's limits, named by the type, at +;;;; (max-value T) and (min-value T): a numeric type's limits, named by the type, at ;;;; a concrete type and inside a generic whose bound admits numbers. ;; A selection sort, descending, whose running best starts at the least value @@ -6,7 +6,7 @@ (defn sort-desc [s [$t]] () {:where (numeric? $t)} (dotimes [i (length s)] - (let [best (min-of $t) + (let [best (min-value $t) at-best i] (dotimes [j (- (length s) i)] (let [k (+ i j)] @@ -17,7 +17,7 @@ (defn largest [s [$t]] $t {:where (numeric? $t)} - (let [best (min-of t)] + (let [best (min-value t)] (dotimes [i (length s)] (when (> (at s i) best) (set best (at s i)))) best)) @@ -31,16 +31,16 @@ (println "")) (defn main [] i32 - (println (max-of u8)) - (println (min-of u8)) - (println (max-of i8)) - (println (min-of i8)) - (println (max-of i32)) - (println (min-of i64)) - (println (max-of u64)) - (println (= (max-of f32) f32-max)) - (println (= (min-of f64) (- f64-max))) - (println (= (max-of i16) i16-max)) + (println (max-value u8)) + (println (min-value u8)) + (println (max-value i8)) + (println (min-value i8)) + (println (max-value i32)) + (println (min-value i64)) + (println (max-value u64)) + (println (= (max-value f32) f32-max)) + (println (= (min-value f64) (- f64-max))) + (println (= (max-value i16) i16-max)) (let [a [(i32 3) -7 12 0 -2147483648 5] b [2.5 -1.0 1e300 -1e308] c [(u8 4) 0 200 9]] diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index f333b5b2..ec512b55 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -585,14 +585,14 @@ let () = outputs "a prelude function shadowed" "programs/shadow-prelude.flan" sp_out; outputs ~x86:true "a prelude function shadowed, x86" "programs/shadow-prelude.flan" sp_out; - (* (max-of T) and (min-of T), concrete and inside a generic. *) + (* (max-value T) and (min-value T), concrete and inside a generic. *) let maxof_out = "255\n0\n127\n-128\n2147483647\n-9223372036854775808\n\ 18446744073709551615\ntrue\ntrue\ntrue\n\ 12 5 3 0 -7 -2147483648 \n1e+300 2.5 -1 -1e+308 \n200\n-5\ntrue\n" in - outputs "max-of and min-of" "programs/max-of.flan" maxof_out; - outputs ~opt:"-O0" "max-of and min-of, -O0" "programs/max-of.flan" maxof_out; - outputs ~x86:true "max-of and min-of, x86" "programs/max-of.flan" maxof_out; + outputs "max-value and min-value" "programs/max-value.flan" maxof_out; + outputs ~opt:"-O0" "max-value and min-value, -O0" "programs/max-value.flan" maxof_out; + outputs ~x86:true "max-value and min-value, x86" "programs/max-value.flan" maxof_out; (* (- x) negates, on every numeric type, a type variable and a dyn. *) let neg_out = "-3\n7\n-2.5\n-inf\n-1.5\n255\n-4\n-2.5\n-inf\n-9000000000\n\ diff --git a/test/test_flan.ml b/test/test_flan.ml index 68272cb4..54ce96ab 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6546,30 +6546,44 @@ let () = (fun (n : Loc.note) -> contains n.Loc.nmsg "this array's first element is $t") d.Loc.notes)); + rejects_check "numbers with no common type are refused and the fix named" + "(defn f [x i32 y f32] i32 (let [a [x y]] 0))" + ~needle:"elements are i32 and f32, and neither holds every value of the \ + other — convert one, as in (f32 x)"; + accepts "the conversion that refusal names compiles" + "(defn f [x i32 y f32] i32 (let [a [(f32 x) y]] 0))"; + rejects_check "two integer types with no common type are refused" + "(defn f [x i64 y u64] i32 (let [a [x y]] 0))" ~needle:"as in (i64 y)"; + accepts "the integer conversion that refusal names compiles" + "(defn f [x i64 y u64] i32 (let [a [x (i64 y)]] 0))"; rejects_check "every element needing a type names the first's refusal" "(defn main [] i32 (let [a [None None]] 0))" ~needle:"what None is an Option of"; - (* ── (max-of T) and (min-of T) ──────────────────────────────────── *) - infers "max-of carries its type" "(max-of u16)" "u16"; - infers "min-of at a float" "(min-of f32)" "f32"; - (match checked "(defn f [x $t] $t (max-of $t))" with - | _ -> check "max-of at an unbounded type variable is refused" false + (* ── (max-value T) and (min-value T) ──────────────────────────────── *) + infers "max-value carries its type" "(max-value u16)" "u16"; + infers "min-value at a float" "(min-value f32)" "f32"; + (match checked "(defn f [x $t] $t (max-value $t))" with + | _ -> check "max-value at an unbounded type variable is refused" false | exception Loc.Error d -> - check "max-of at an unbounded type variable names the bound and only it" + check "max-value at an unbounded type variable names the bound and only it" (contains d.Loc.dmsg "write {:where (numeric? $t)}" && not (contains d.Loc.dmsg "Fn"))); infers "two literal if arms meet at the wider" "(if true 1 2.5)" "f64"; infers "two integer if arms stay i32" "(if true 1 2)" "i32"; infers "two literal match arms meet at the wider" "(match (Some 1) (Some v) 1 None 2.5)" "f64"; - accepts "max-of at a type variable the bound admits" - "(defn f [x $t] $t {:where (integer? $t)} (max-of t))"; - rejects_check "max-of at a type that is not a number names the bound" - "(defn f [] string (max-of string))" - ~needle:"max-of takes a numeric? type, and string is not one"; - accepts "max-of of a slice is still the prelude's reduction" + accepts "max-value at a type variable the bound admits" + "(defn f [x $t] $t {:where (integer? $t)} (max-value t))"; + rejects_check "max-value at a type that is not a number names the bound" + "(defn f [] string (max-value string))" + ~needle:"max-value takes a numeric? type, and string is not one"; + rejects_check "max-value of a value says it takes a type" + "(defn f [x i32] i32 (max-value x))" ~needle:"max-value takes a type"; + accepts "max-of of a slice is the prelude's reduction" "(defn f [xs [i32]] (Option i32) (max-of xs))"; + rejects_check "max-of of a type names max-value" + "(defn f [] u8 (max-of u8))" ~needle:"the largest value of a type is (max-value u8)"; (* ── (the T e) ─────────────────────────────────────────────────── *) infers "the gives a literal its type" "(the u8 200)" "u8"; From 9394a26449887bd10b739582e1c723e4f95c1b46 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 13:02:50 +0700 Subject: [PATCH 14/16] A negative literal fits no unsigned type, u64 included, and the refusal names the cast that writes its bit pattern, which a constant now folds --- TODO.org | 11 ++++---- lib/check.ml | 65 +++++++++++++++++++++++++++++++++++++++++------ test/test_flan.ml | 32 +++++++++++++++++++++-- 3 files changed, 92 insertions(+), 16 deletions(-) diff --git a/TODO.org b/TODO.org index 3e632ba1..af0ea030 100644 --- a/TODO.org +++ b/TODO.org @@ -155,8 +155,8 @@ An integer written at or above 2^63 — a decimal up to 2^64 - 1, or hex with th top bit set — reads as =Form.UInt=, its pattern and its spelling. It is accepted where the type is =u64=, a =(u64 ...)= cast included, and refused everywhere else in the spelling it was written in. Hex with the top bit set was accepted as a -negative at any integer type before this; it is refused now too. A negative -decimal is still a =u64= bit pattern. A cast's integer literal that does not fit +negative at any integer type before this; it is refused now too. A cast's +integer literal that does not fit =i32= is checked at the cast's type; one that fits keeps the =i32= default, so =(u32 -1)= still means what it did. A wide literal passed to a macro as an argument comes back wide: it crosses as an =Int= with a token in the unused @@ -1014,10 +1014,9 @@ died in the backend as a redefinition of a symbol, a message with no source location. ** DONE A u64 literal is its 64-bit pattern -The cost of accepting the pattern is that a negative decimal literal is accepted -as a =u64=, because the reader records the value and not how it was written. -Narrower unsigned types keep the strict check, which is where a typo like =300= -for a =u8= shows up. +A negative literal fits no unsigned type, u64 included; =(u64 -1)= is how the +pattern is written, and a constant folds it. Rules out a negative decimal as a +u64's bit pattern. ** DONE A folded constant does not skip the range check The folding pass makes its own call to the range test, because a global's diff --git a/lib/check.ml b/lib/check.ml index df9ca55a..489903bd 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4086,24 +4086,34 @@ and wide_literal loc ~want n s = (* Arithmetic wraps, but a literal that does not fit its type is a typo, not a wrap — 300 is never what someone meant by a u8. *) -and in_range loc k n = +and in_range ?(pattern = false) loc k n = let bits = Types.bits k in let ok = if Types.signed k then bits = 64 || (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0 && Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0) - else if bits = 64 then - (* A literal at or above 2^63 is a [UInt] and never reaches here; see - [wide_literal]. A negative decimal is accepted as a u64's bit pattern, - which is a settled rule. Narrower unsigned types keep the strict - check, which is where a typo like 300 for a u8 actually shows up. *) - true + (* A literal at or above 2^63 is a [UInt] and never reaches here as a + literal; see [wide_literal]. [pattern] is the folded-constant path, + which holds a u64 as its 64-bit pattern and cannot tell 2^64 - 1 from + -1, so there every pattern is a u64. *) + else if bits = 64 then pattern || Int64.compare n 0L >= 0 else Int64.compare n 0L >= 0 && Int64.compare n (Int64.shift_left 1L bits) < 0 in if ok then n + else if Int64.compare n 0L < 0 && not (Types.signed k) then + (* A negative number at an unsigned type is never the value it reads as. + The cast is how to ask for the bit pattern, and names what it is. *) + let mask = + if bits = 64 then -1L else Int64.sub (Int64.shift_left 1L bits) 1L + in + let tn = Types.ikind_name k in + Loc.failk literal_at_want loc + "%Ld does not fit in %s, which holds no negative number — write (%s %Ld) \ + for the %s with the same bits, %Lu" + n tn tn n tn (Int64.logand n mask) else Loc.failk literal_at_want loc "%Ld does not fit in %s" n (Types.ikind_name k) @@ -5885,6 +5895,15 @@ and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a = | Some p -> p | None -> List.nth elems (List.length elems - 1) in + (* An integer literal beside an integer type it does not fit — -1 beside a + u64 — is that literal's own refusal, which names the cast. *) + let literal_refusal (lit : Ast.expr) t = + match lit.Ast.e, t with + | Ast.Int _, Types.Int _ -> ignore (check ctx ~want:t lit) + | _ -> () + in + literal_refusal second t1; + literal_refusal first t2; let target, moved, moved_ty, other = match t1, t2 with | Types.Int _, Types.Float _ -> t2, first, t1, second @@ -11110,6 +11129,22 @@ let rec const_int env (e : Ast.expr) : int64 option = | Ast.Int n -> Some n | Ast.Byte b -> Some (Int64.of_int b) | Ast.Var n -> Hashtbl.find_opt env.consts n + | Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ x ]) -> + Option.map Int64.neg (const_int env x) + (* A conversion to an integer type, which is how a negative number is + written as an unsigned constant's bit pattern: [(u64 -1)]. Truncated to + the type's width and extended by its sign, as the cast does at run time. *) + | Ast.Call ({ Ast.e = Ast.Var k; _ }, [ x ]) + when Types.ikind_of_name k <> None -> + let k = Option.get (Types.ikind_of_name k) in + let bits = Types.bits k in + Option.map + (fun n -> + if bits = 64 then n + else if Types.signed k then + Int64.shift_right (Int64.shift_left n (64 - bits)) (64 - bits) + else Int64.logand n (Int64.sub (Int64.shift_left 1L bits) 1L)) + (const_int env x) (* Left to right over any number of operands, because that is how the checker reads the same form: an array length that type-checks as a product of three literals and is then not a constant would be a @@ -12157,12 +12192,26 @@ let check_global env (d : Ast.decl) : Tast.global option = than the expression it came from: a global's initialiser has to be a compile-time constant, and [(/ screen-height cell-size)] is one — the folding pass is the only thing that knows it. *) + (* A folded conversion is still a value of the type it converts to. *) + (match v.Ast.e, ty with + | Ast.Call ({ Ast.e = Ast.Var c; _ }, [ _ ]), Types.Int kind + when (match Types.ikind_of_name c with + | Some k -> + k <> kind + && not (Types.widens_to ~from:(Types.Int k) ~into:(Types.Int kind)) + | None -> false) -> + fail v.Ast.loc "expected %s, found %s" (Types.ikind_name kind) c + | _ -> ()); let ginit = match Hashtbl.find_opt env.consts n, ty with | Some k, Types.Int kind -> (* Still range-checked: this path skips [check], and [in_range] is the only thing that rejects 300 as a u8. *) - { Tast.e = Tast.Int (in_range d.Ast.dloc kind k, kind); ty; + { Tast.e = + Tast.Int + (in_range + ~pattern:(match v.Ast.e with Ast.Int _ -> false | _ -> true) + v.Ast.loc kind k, kind); ty; loc = d.Ast.dloc } | _ -> check (ctx ()) ~want:ty v in diff --git a/test/test_flan.ml b/test/test_flan.ml index 54ce96ab..0b8d1381 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6227,8 +6227,36 @@ let () = "(defconst a u64 18446744073709551615) (defonce b u64 0xFFFFFFFFFFFFFFFF) \ (defn f [x u64] u64 (+ x 9223372036854775808)) \ (defn g [] f64 (f64 (u64 12345678901234567890)))"; - accepts "a negative decimal is still a u64 bit pattern" - "(defconst a u64 -1)"; + (* A negative literal fits no unsigned type, wherever the type comes from; + the cast the refusal names is how to write the bit pattern. *) + List.iter + (fun (what, src, needle) -> rejects_check what src ~needle) + [ ("a negative literal at a u64 constant", "(defconst a u64 -1)", + "-1 does not fit in u64, which holds no negative number — write \ + (u64 -1) for the u64 with the same bits, 18446744073709551615"); + ("a negative literal at a u32 global", "(defonce g u32 -5)", + "write (u32 -5) for the u32 with the same bits, 4294967291"); + ("a negative literal as a u64 return", "(defn f [] u64 -1)", + "-1 does not fit in u64"); + ("a negative literal as a u32 argument", + "(defn t [x u32] u32 x) (defn f [] u32 (t -2))", "-2 does not fit in u32"); + ("a negative literal in a u8 field", + "(defstruct S [a u8]) (defn f [] S (S -3))", "write (u8 -3)"); + ("a negative literal given a u64 by the", + "(defn f [] i32 (let [a (the u64 -1)] 0))", "-1 does not fit in u64"); + ("a negative literal beside a u64-only literal", + "(defn f [] i32 (let [a [-1 18446744073709551615]] 0))", + "write (u64 -1) for the u64"); + ("a negative literal beside a u64 element", + "(defn f [x u64] i32 (let [a [x -1]] 0))", "write (u64 -1) for the u64") ]; + accepts "the casts those refusals name compile" + "(defconst a u64 (u64 -1)) (defonce g u32 (u32 -5)) \ + (defstruct S [a u8]) (defn f [x u64] S \ + (let [a [(u64 -1) 18446744073709551615] b [x (u64 -1)] \ + c (the u64 (u64 -1))] \ + (S (u8 -3))))"; + rejects_check "a folded constant's conversion is still its type" + "(defconst a u8 (i32 5))" ~needle:"expected u8, found i32"; rejects_check "a wide decimal with nothing to say u64" ~needle:"18446744073709551615 does not fit in i32, the type an integer \ literal takes when nothing says otherwise — write (u64 \ From 53880eb685fe0df99bc160e4b289eb8b906b39f4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 13:29:30 +0700 Subject: [PATCH 15/16] A class slot's type names its own package's class first, an int widens into a float slot exactly when it round-trips, and a constructor's refusal names the call that was wrong --- TODO.org | 4 +-- lib/check.ml | 30 ++++++++++++++++++++-- lib/classes.ml | 3 ++- lib/emit.ml | 1 + runtime/flan_dyn.c | 41 +++++++++++++++++++++++++----- runtime/flan_dyn.h | 8 +++++- test/daemon-x86.out | 2 ++ test/dyn_ops.c | 26 +++++++++++++++++-- test/programs/dyn-class-pkg.flan | 8 ++++++ test/programs/dyn-class-slots.flan | 5 ++++ test/programs/pkgs/geo/geo.flan | 5 ++++ test/test_acceptance.ml | 13 ++++++---- web/index.html | 4 ++- 13 files changed, 130 insertions(+), 20 deletions(-) create mode 100644 test/daemon-x86.out create mode 100644 test/programs/dyn-class-pkg.flan create mode 100644 test/programs/pkgs/geo/geo.flan diff --git a/TODO.org b/TODO.org index cc99b747..0bdbe22f 100644 --- a/TODO.org +++ b/TODO.org @@ -2041,8 +2041,8 @@ them. ** DONE defclass slots take types, checked on write CLOSED: [2026-09-25] -The constructor's parameters stay dyn and every store checks at run time; an int -widens into a float slot only when exact, and nil fits only an (Option T) slot. +Constructor parameters stay dyn and each store checks at run time; an int widens +into a float slot only if it round-trips, and nil fits only an (Option T) slot. ** DONE println takes up to a second to appear CLOSED: [2026-09-25] diff --git a/lib/check.ml b/lib/check.ml index 8188fefb..bbe20d00 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -1608,13 +1608,18 @@ let pair_params ?(also = fun _ -> false) env (items : Ast.pitem list) (* A class named in [cls]'s slot vector: [n] as written, or [n] in [cls]'s own package, since [Load] leaves a bare name in a slot vector unqualified. *) let class_named ~classes cls n = - if List.mem n classes then Some n - else + (* The class's own package first: an importer may declare a class of the + same bare name, and a slot the package wrote means the package's. *) + let own = match String.rindex_opt cls '/' with | Some i -> let q = String.sub cls 0 (i + 1) ^ n in if List.mem q classes then Some q else None | None -> None + in + match own with + | Some _ -> own + | None -> if List.mem n classes then Some n else None let rec slot_of env ~classes cls fname (t : Ast.texpr) : slot_ty = let refuse what = @@ -9620,6 +9625,27 @@ and ordinary_call ctx ~want loc name args = in (match Hashtbl.find_opt ctx.env.tracks name with | Some tr -> expect ctx loc ~want (tracked_call loc ctx.env name tr ret args) + | None when Hashtbl.mem ctx.env.classes name -> + (* A class's constructor, told where it was called from so that a + slot it refuses names this call and not only the defclass. The + arguments go into temps first: one may itself construct, and + the site is set last, immediately before the call, so nothing + between the two can replace it. The constructor takes it as its + first act; one reached through a function value finds none. *) + let temps = + List.map (fun (a : Tast.expr) -> (fresh_slot ctx a.Tast.ty, a)) args + in + let uses = + List.map + (fun (s, (a : Tast.expr)) -> mk a.Tast.loc a.Tast.ty (Tast.Local s)) + temps + in + expect ctx loc ~want + (mk loc ret + (Tast.Let + (temps, + [ rt loc Types.Unit "flan_dyn_ctor_site" [ here loc ]; + mk loc ret (Tast.Call (name, uses)) ]))) | None -> expect ctx loc ~want (mk loc ret (Tast.Call (name, args)))) | None -> if Hashtbl.mem ctx.env.datas name then diff --git a/lib/classes.ml b/lib/classes.ml index 8a109288..cc006999 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -53,7 +53,8 @@ let no_method = "NoMethod" each of its instances, run once per instance at the first [get], [put] or [set] that reaches it after the redefinition. By then the instance already holds the new slots, each kept one with its old value and each gained one - nil; [added] is a vec of the gained slots' keywords and [discarded] a map + at its type's zero value, or nil for an untyped, Option or class slot; + [added] is a vec of the gained slots' keywords and [discarded] a map from each lost slot's keyword to the value it held. A method is written for a class, from a live session, and is how a migration does more than match slots by name: diff --git a/lib/emit.ml b/lib/emit.ml index 57c92886..76c9e776 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4780,6 +4780,7 @@ declare i64 @flan_dyn_map_new() declare i64 @flan_dyn_map_new_class(i64, ptr, i64) declare void @flan_dyn_slot_set(i64, i64, i64, ptr, i64) declare void @flan_dyn_slot_init(i64, i64, i64, ptr, i64) +declare void @flan_dyn_ctor_site(ptr, i64) declare void @flan_dyn_map_put(i64, i64, i64, ptr, i64) declare i64 @flan_dyn_class_of(i64) declare void @flan_dyn_class_def(i64, ptr, i64) diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index c54dfebf..623a15cd 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1655,8 +1655,8 @@ static void slot_type_text(const slot_type *t, char *buf, size_t cap) { /* Whether [v] may be stored in a slot of type [t], and what is stored: [v] * itself, or — for an int into a float slot — the float it widens to. The * widening is the typed side's rule read off the value rather than off a - * static type: an integer the float's significand holds exactly is admitted - * as that float, and one it does not is refused, as (f64 x) would be for the + * static type: an integer the float holds exactly is admitted as that float, + * and one it does not is refused, as (f64 x) would be for the * type that could hold it. A float into an f32 slot has to be one an f32 * holds, which is the typed side refusing f64 into f32. */ static int slot_admit(const slot_type *t, flan_dyn v, flan_dyn *out) { @@ -1675,9 +1675,15 @@ static int slot_admit(const slot_type *t, flan_dyn v, flan_dyn *out) { return t->fbits == 53 || d != d || (double)(float)d == d; } if (tag == FLAN_DYN_TAG_INT) { - int64_t x = dyn_int_value(v), lim = (int64_t)1 << t->fbits; - if (x < -lim || x > lim) return 0; - *out = flan_dyn_from_f64((double)x); + /* Exact is a round trip, not a range: 2^54 is an f64 exactly and + 2^53+1 is not. The range test before the cast back is what keeps + that cast defined, since INT64_MAX rounds up to 2^63. */ + int64_t x = dyn_int_value(v); + double d = t->fbits == 53 ? (double)x : (double)(float)x; + if (!(d >= -9223372036854775808.0 && d < 9223372036854775808.0) + || (int64_t)d != x) + return 0; + *out = flan_dyn_from_f64(d); return 1; } return 0; @@ -2117,8 +2123,25 @@ static class_entry *class_sync(flan_obj *o) { * what it has, and has to: a constructor compiled before a redefinition may * still be on some stack, and letting its definition win would put the * class back the way it was. Redefining is [flan_dyn_class_def]'s alone. */ +/* A constructor call's site: [pending] from the caller, moved to [building] + * by the constructor's first act, so a call through a function value — which + * sets nothing — finds none rather than an earlier call's. Nothing between + * the caller setting it and the constructor taking it can construct: the + * caller evaluated every argument first. */ +static const uint8_t *site_pending, *site_building; +static int64_t site_pending_len, site_building_len; + +void flan_dyn_ctor_site(const uint8_t *loc, int64_t loclen) { + site_pending = loc; + site_pending_len = loclen; +} + flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n) { flan_obj *o; + site_building = site_pending; + site_building_len = site_pending_len; + site_pending = NULL; + site_pending_len = 0; if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) trap1(NULL, 0, TYPE_TRAP, "class instance", "a class tag is a keyword", k); if (class_find(dyn_kw(k)) == NULL) { @@ -3029,7 +3052,10 @@ static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, say(sv, SAY_MAX, v); slot_type_text(t, st, sizeof st); fflush(stdout); - trap_where(loc, loclen); + /* A constructor's refusal is placed at the call that was wrong, when the + call said where it was, and names the slot's declaration after it. */ + trap_where(by == BY_NEW && site_building != NULL ? site_building : loc, + by == BY_NEW && site_building != NULL ? site_building_len : loclen); fprintf(stderr, "dyn %s: the slot :%.*s of %.*s is declared %s, and ", by == BY_PUT ? "put" : by == BY_SET ? "set" : "construct", sn, ss, cn, cs, st); @@ -3047,6 +3073,9 @@ static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, fprintf(stderr, "(put %s :%.*s %s)\n", sm, sn, ss, sv); else if (by == BY_SET) fprintf(stderr, "(set (get %s :%.*s) %s)\n", sm, sn, ss, sv); + else if (site_building != NULL && loc != NULL) + fprintf(stderr, "(%.*s ...) with :%.*s %s; the slot is declared at %.*s\n", + cn, cs, sn, ss, sv, (int)loclen, (const char *)loc); else fprintf(stderr, "(%.*s ...) with :%.*s %s\n", cn, cs, sn, ss, sv); flan_trap((const uint8_t *)"DynType", 7); diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 33ca96b2..bcd92bed 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -112,6 +112,11 @@ flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n); void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, int64_t loclen); +/* Where the constructor about to be called was called from. Set by the + * caller immediately before the call and taken by the constructor's + * [flan_dyn_map_new_class], so a refusal in its stores names the call. */ +void flan_dyn_ctor_site(const uint8_t *loc, int64_t loclen); + /* (set (get inst :slot) v): [m] must be a class instance and [k] a slot its * class declares, and [v] must fit the slot's type; each is a trap with its * own sentence, at [loc]. A declared slot always exists, so this stores and @@ -136,7 +141,8 @@ flan_dyn flan_dyn_class_of(flan_dyn v); * migrates nothing. When it does move, every instance built against an * earlier definition migrates lazily at its next [get], [put], [has-key?], * [len] or equality comparison: slots the class still has keep their values - * matched by name, slots it has gained appear as nil, and keys it no longer + * matched by name, a slot it has gained holds its type's zero value — nil + * for an untyped, an (Option T) or a class-typed slot — and keys it no longer * declares are dropped. The instance's identity is preserved throughout; * this is CLHS 4.3.6, and [flan_dyn_class_hook] is its user hook. * diff --git a/test/daemon-x86.out b/test/daemon-x86.out new file mode 100644 index 00000000..63826b3b --- /dev/null +++ b/test/daemon-x86.out @@ -0,0 +1,2 @@ +flan dev: built dev-hook.flan in 444ms +flan dev: /home/joe/Development/flan/.claude/worktrees/agent-a6ffe579d55d1892b/test/programs/dev-hook.flan ready on /tmp/claude-1000/rv-3672919.sock (17ms, one process) diff --git a/test/dyn_ops.c b/test/dyn_ops.c index 8fcbf923..c9335dd2 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -1256,7 +1256,7 @@ extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, uint64_t added, void flan_dyn_class_hook(void *fn); static flan_dyn hk_p, hk_q, hk_r; -static int hk_runs_p, hk_runs_q, hk_runs_r, hk_fresh; +static int hk_runs_p, hk_runs_q, hk_runs_r, hk_fresh, hk_per_call = 20; static int64_t hk_gone_len = -1; static int hk_call(void *fn, uint64_t instance, uint64_t added, @@ -1272,7 +1272,7 @@ static int hk_call(void *fn, uint64_t instance, uint64_t added, if (instance == hk_q) hk_runs_q++; if (instance == hk_r) hk_runs_r++; (void)slot(hk_p, "x"); - for (i = 0; i < 20; i++) { + for (i = 0; i < hk_per_call; i++) { snprintf(name, sizeof name, "fresh%d", hk_fresh++); (void)flan_dyn_map_new_class( flan_dyn_kw((const uint8_t *)name, (int64_t)strlen(name)), @@ -1315,6 +1315,28 @@ static void hook_reentry(void) { check(hk_runs_q == 1 && hk_runs_r == 1, "each other instance runs its hook once, at its own first touch"); check(hk_runs_p == 1, "and the first instance's did not run again"); + + /* A migration started by a store rather than a read, with a hook that + grows the registry past its capacity each time: the store goes on to + check the value against the class's entry, and it has to be the entry + the registry holds after the hook, not the one it held before. 200 and + then 300 new classes are each enough to move the table whatever its + capacity was. :x is an f64 slot now, so the int stored must arrive as a + float, which only the entry's types can say. */ + hk_per_call = 200; + define("pt", "x f64\ny\nz\nw"); + flan_dyn_map_put(hk_p, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(5), NULL, 0); + check(hk_runs_p == 2, "a put migrates and runs the hook"); + check(flan_dyn_tag(slot(hk_p, "x")) == FLAN_DYN_TAG_FLOAT, + "a put after a hook that moved the registry widens by the new entry"); + hk_per_call = 300; + define("pt", "x f64\ny\nz\nw\nv"); + flan_dyn_slot_set(hk_p, flan_dyn_kw((const uint8_t *)"w", 1), + flan_dyn_from_i64(7), NULL, 0); + check(hk_runs_p == 3, "a set migrates and runs the hook"); + check(flan_dyn_need_i64(slot(hk_p, "w")) == 7, + "a set after a hook that moved the registry finds its slot"); flan_dyn_migrate_hook = NULL; flan_dyn_class_hook(NULL); flan_dyn_root_pop(3); diff --git a/test/programs/dyn-class-pkg.flan b/test/programs/dyn-class-pkg.flan new file mode 100644 index 00000000..e237cb4e --- /dev/null +++ b/test/programs/dyn-class-pkg.flan @@ -0,0 +1,8 @@ +;;;; A slot type a package wrote names the package's own class, not an +;;;; importer's class of the same bare name. +(import g "pkgs/geo") +(defclass pt [z]) +(defn main [] i32 + (println (g/mk)) + (println (pt 1)) + 0) diff --git a/test/programs/dyn-class-slots.flan b/test/programs/dyn-class-slots.flan index 04c875d9..8d3181f1 100644 --- a/test/programs/dyn-class-slots.flan +++ b/test/programs/dyn-class-slots.flan @@ -42,9 +42,14 @@ ;; parameter, when the float holds it exactly. (put s :speed 3) (println (+ (get s :speed) 0.5)) + ;; Exact is a round trip, not a range: 2^54 is an f64 exactly. + (put s :speed 18014398509481984) + (println (= (get s :speed) 18014398509481984.0)) (let [n (node s nil nil)] (set (get n :next) (node s nil 2)) (println (get (get n :next) :weight)) (set (get n :weight) nil) + ;; 2^30 is an f32 exactly, though it is past f32's 24-bit significand. + (set (get n :weight) 1073741824) (println (class-of (get n :owner))))) 0) diff --git a/test/programs/pkgs/geo/geo.flan b/test/programs/pkgs/geo/geo.flan new file mode 100644 index 00000000..6d3700ef --- /dev/null +++ b/test/programs/pkgs/geo/geo.flan @@ -0,0 +1,5 @@ +;;;; A package whose slot types name its own classes, imported by +;;;; dyn-class-pkg.flan, which declares a class of the same bare name. +(defclass pt [x f64 y f64]) +(defclass seg [a pt b (Option pt) tag]) +(defn mk [] dyn (seg (pt 1 2) nil :t)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index c4133974..20fa9c3e 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5088,11 +5088,14 @@ level "1" whose arguments the two emit separately. *) let slots_out = "#state{ :pause false :step 3 :speed 1.5 :name \"sand\" :tag :x}\n\ - true\n-7\n[ 1 2]\n2.5\n9\n6\n12\n3.5\n2\n:state\n" + true\n-7\n[ 1 2]\n2.5\n9\n6\n12\n3.5\ntrue\n2\n:state\n" in outputs "dyn: typed class slots" "programs/dyn-class-slots.flan" slots_out; outputs ~x86:true "dyn: typed class slots, --x86" "programs/dyn-class-slots.flan" slots_out; + outputs "dyn: a package's slot type names its own class" + "programs/dyn-class-pkg.flan" + "#g/seg{ :a #g/pt{ :x 1 :y 2} :b nil :tag :t}\n#pt{ :z 1}\n"; let slot_trap ?x86 () = let exe = compile ?x86 "programs/dyn-slot-trap.flan" in List.iter @@ -5106,9 +5109,9 @@ level "1" (match x86 with Some true -> ", --x86" | _ -> "") text code want end) - [ ("0", "dyn-slot-trap.flan:4:18: dyn construct: the slot :pause of \ + [ ("0", "dyn-slot-trap.flan:14:28: dyn construct: the slot :pause of \ state is declared bool, and this is int — (state ...) with \ - :pause 1"); + :pause 1; the slot is declared at programs/dyn-slot-trap.flan:4:18"); ("1", "dyn-slot-trap.flan:15:19: dyn put: the slot :pause of state \ is declared bool, and this is int"); ("2", "dyn-slot-trap.flan:16:19: dyn set: the slot :step of state \ @@ -5119,9 +5122,9 @@ level "1" declare is added with put, not set"); ("4", "dyn-slot-trap.flan:18:19: dyn set: (get m k) is a place only \ on a class instance, and this is a map with no class"); - ("5", "dyn-slot-trap.flan:5:17: dyn construct: the slot :owner of \ + ("5", "dyn-slot-trap.flan:19:28: dyn construct: the slot :owner of \ node is declared state, and this is not an instance of it"); - ("6", "dyn-slot-trap.flan:4:18: dyn construct: the slot :pause of \ + ("6", "dyn-slot-trap.flan:20:22: dyn construct: the slot :pause of \ state is declared bool, and this is nil") ]; (try Sys.remove exe with Sys_error _ -> ()) in diff --git a/web/index.html b/web/index.html index d033e7da..1c311673 100644 --- a/web/index.html +++ b/web/index.html @@ -2221,7 +2221,9 @@ reason is the whole difference between the two: an instance carries a header nam its class and a flat struct does not. Redefining one re-registers the class and bumps a generation counter, which is O(1) and walks no heap; every live instance migrates at its next touch. Slots matched by name keep their values, a gained slot -appears as nil, a dropped one goes, the object is the same object, and +starts at its type's zero value — false, 0, +0.0 or "", and nil for a slot with no type, +an (Option T) or a class — a dropped one goes, the object is the same object, and class-of still answers the same tag, so every method still reaches it. That is CLHS 4.3.6's protocol. Its user hook is update-instance-for-redefined-class: a method of it written for a From 5066b8d288c3394bee14c80a0bc6fcabc1b062e6 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 13:29:42 +0700 Subject: [PATCH 16/16] The literal an array cannot hold is the element blamed, a negative literal in a generic body names a fix for every instantiation, and a doubly negated literal is positive --- lib/check.ml | 73 +++++++++++++++++++++++++++++++++++++---------- test/test_flan.ml | 25 ++++++++++++++++ 2 files changed, 83 insertions(+), 15 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index be99fe93..49013241 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3583,6 +3583,28 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = let tail = ctx.tail in ctx.tail <- false; match e.Ast.e with + (* A negative literal in a generic body, at an instantiation that made it + unsigned. The cast the ordinary refusal names would be wrong at every + other type the function is called at, so the fix is one that needs no + negative number at all, and the refusal says which call asked. *) + | Ast.Int n + when Int64.compare n 0L < 0 && ctx.env.chain <> [] + && (match want with + | Some (Types.Int k) -> not (Types.signed k) + | _ -> false) -> + let t = Option.get want in + let gname, _, at = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in + let var = + match List.find_opt (fun (_, u) -> Types.equal u t) ctx.env.subst with + | Some (v, _) -> Printf.sprintf "$%s = %s" v (Types.to_string t) + | None -> Types.to_string t + in + Loc.failk literal_at_want loc + ~notes:[ Loc.note at (Printf.sprintf "%s is instantiated at %s here" gname var) ] + "%Ld does not fit in %s, which holds no negative number, and %s is called \ + at %s — the body has to work at every type it is called at, so write \ + it with no negative literal, as in (- x %Ld) in place of (+ x %Ld)" + n (Types.to_string t) gname var (Int64.neg n) n | Ast.Int n -> int_literal loc ~want ~preds:ctx.env.tvpreds n | Ast.UInt (n, s) -> wide_literal loc ~want n s | Ast.Byte b -> @@ -5874,21 +5896,40 @@ and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a = fun ctx elems -> match elems with | [] -> fail Loc.unknown "internal: an array of numbers with no elements" - | (first, t1) :: rest -> + | _ :: _ -> + (* A literal is not one of the disagreeing types when it fits the others: + each is checked at the type the rest meet at — or, with every element a + literal, at the u64 a wide one needs — and the first that does not fit + is the refusal, its own. *) + let lit (e, _) = lone_literal e in + let others = List.filter (fun p -> not (lit p)) elems in + let meet = + match others with + | [] -> + if List.exists (fun (e, _) -> match e.Ast.e with Ast.UInt _ -> true | _ -> false) elems + then Some (Types.Int Types.U64) else None + | (_, t) :: ts -> + List.fold_left (fun acc (_, u) -> Option.bind acc (fun a -> Types.join a u)) + (Some t) ts + in + (match meet with + | Some (Types.Int _ as m) -> + List.iter + (fun (e, t) -> + if lone_literal e && (match t with Types.Int _ -> true | _ -> false) + then ignore (check ctx ~want:m e)) + elems + | _ -> ()); + let pool = if others = [] then elems else others in + let first, t1 = List.hd pool in let second, t2 = - match List.find_opt (fun (_, t) -> Types.join t1 t = None) rest with + match List.find_opt (fun (_, t) -> Types.join t1 t = None) (List.tl pool) with | Some p -> p - | None -> List.nth elems (List.length elems - 1) + | None -> + (match List.find_opt (fun (_, t) -> Types.join t1 t = None) elems with + | Some p -> p + | None -> List.nth elems (List.length elems - 1)) in - (* An integer literal beside an integer type it does not fit — -1 beside a - u64 — is that literal's own refusal, which names the cast. *) - let literal_refusal (lit : Ast.expr) t = - match lit.Ast.e, t with - | Ast.Int _, Types.Int _ -> ignore (check ctx ~want:t lit) - | _ -> () - in - literal_refusal second t1; - literal_refusal first t2; let target, moved, moved_ty, other = match t1, t2 with | Types.Int _, Types.Float _ -> t2, first, t1, second @@ -7597,10 +7638,12 @@ and named_call ?(qualified = false) ctx ~want loc name args = +0.0 — and an integer from 0, which wraps as (- 0 x) does. *) | "-" when List.length args = 1 -> let x = List.hd args in - (match x.Ast.e with - | Ast.Int n when n <> Int64.min_int -> + (match x.Ast.e, literal_arith x with + (* Integer arithmetic over literals alone negates to a literal, so + [(- (- 1))] is the literal 1 and fits a u8. *) + | _, Some n when n <> Int64.min_int -> check ctx ?want { Ast.e = Ast.Int (Int64.neg n); loc } - | Ast.Float v -> check ctx ?want { Ast.e = Ast.Float (-.v); loc } + | 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.Dyn then diff --git a/test/test_flan.ml b/test/test_flan.ml index 5e673062..33c0209f 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6255,6 +6255,31 @@ let () = (let [a [(u64 -1) 18446744073709551615] b [x (u64 -1)] \ c (the u64 (u64 -1))] \ (S (u8 -3))))"; + (* The literal that does not fit is the one blamed, not one that does. *) + rejects_check "a negative literal among u64 elements is the one blamed" + "(defn f [] () (println [(u64 2) 1 -1]))" ~needle:"-1 does not fit in u64"; + rejects_check "a negative literal after a u64 element is the one blamed" + "(defn f [] () (println [1 (u64 2) -1]))" ~needle:"-1 does not fit in u64"; + (* In a generic body the cast would break the other instantiations. *) + (match + checked + "(defn add1 [x $t] $t {:where (numeric? $t)} (+ x -1)) \ + (defn main [] i32 (add1 3) (add1 (u64 5)) 0)" + with + | _ -> check "a negative literal at a u64 instantiation is refused" false + | exception Loc.Error d -> + check "the generic's refusal names a fix for every type and the call" + (contains d.Loc.dmsg "as in (- x 1) in place of (+ x -1)" + && not (contains d.Loc.dmsg "(u64 -1)") + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "add1 is instantiated at $t = u64 here") + d.Loc.notes)); + accepts "the generic's fix compiles at both types" + "(defn add1 [x $t] $t {:where (numeric? $t)} (- x 1)) \ + (defn main [] i32 (add1 3) (add1 (u64 5)) 0)"; + accepts "a doubly negated literal is positive at an unsigned type" + "(defn f [] u8 (- (- 1)))"; rejects_check "a folded constant's conversion is still its type" "(defconst a u8 (i32 5))" ~needle:"expected u8, found i32"; rejects_check "a wide decimal with nothing to say u64"