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