From 0b9ae9318e2f1eca33d9908da4a92b9ed0fc1780 Mon Sep 17 00:00:00 2001
From: Joseph Ferano A class is a named dyn map with a shape tag. Classes and generic functions
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.[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"