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