diff --git a/lib/ast.ml b/lib/ast.ml index 41708a09..b40b1765 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -199,6 +199,11 @@ and place = | Pfield of expr * string (* (set (.hp e) v) *) | Pindex of expr * expr list (* (set (at grid r c) v) *) | Pderef of expr (* (set (deref p) v) *) + (* (set (get inst :slot) v) — a class instance's declared slot. A map has + no such place: an absent key has no location, and [put] is how one is + written. Which of the two a value is, is known only at run time, so + this is a runtime store that refuses a plain map. *) + | Pslot of expr * expr and arm = { pat : pattern; body : expr list; aloc : Loc.t } @@ -282,8 +287,10 @@ and decl_kind = | Defvar of string * texpr option * init * reinit | Defconst of string * texpr option * expr (* ── The dyn side's classes and generic functions ────────────────── - None of these four reaches [Check]. [Classes.expand] turns the whole set - into ordinary [Defn]s before pass one collects anything, the way [Shim] + None of these four reaches [Check]'s signature pass. [Classes.expand] + turns the generic forms into ordinary [Defn]s before pass one collects + anything, and [Check.pair_decls] turns a [Defclass] into its constructor + once its slot vector can be paired, the way [Shim] already turns a [DeclareC] into a [Declare] plus a [Defn]: a class is a constructor, and a generic function is one function whose body is a dispatch over the methods written for it. @@ -293,8 +300,11 @@ and decl_kind = anywhere in the file, or arrive at a reload long after the generic did, and a macro sees one form. *) - (* (defclass point [x y]) — the slot names, in constructor order. *) - | Defclass of string * (string * Loc.t) list + (* (defclass point [x y]) or (defclass state [pause bool step bool]) — the + slot vector, in constructor order, left unpaired for the reason a + [defn]'s is: [[x y]] is two slots or one slot [x] of type [y] depending + on whether [y] names a type. [Check.pair_decls] pairs it. *) + | Defclass of string * pitem list (* (defgeneric area [self] dyn) — CLOS's class dispatch: the dispatch value is the shape tag of the first argument. The parameter vector and the return slot are a [defn]'s, and there is no body. *) @@ -413,6 +423,7 @@ let map_children f (e : expr) : expr = | Pfield (x, n) -> Pfield (ex x, n) | Pindex (x, is) -> Pindex (ex x, List.map ex is) | Pderef x -> Pderef (ex x) + | Pslot (x, k) -> Pslot (ex x, ex k) in let kind = match e.e with diff --git a/lib/check.ml b/lib/check.ml index e5106991..279aa172 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -181,6 +181,13 @@ type env = { flag is what lets [resolve_name] say the honest thing in each place instead of a suggestion that cannot be followed. *) mutable in_field : bool; + (* Every [defclass], by name: its slots in constructor order, each with the + type a value stored in it must have — [Types.Dyn] for a slot written + with no type. Filled by [pair_decls], which is where a slot vector is + first readable. The type is a declaration about the values and not a + layout: an instance is a dyn map whatever this says, and what reads it + is [class_spec], which is what the runtime checks a store against. *) + classes : (string, (string * Types.t) list) Hashtbl.t; } let new_env () = { @@ -210,6 +217,7 @@ let new_env () = { tvpreds = []; chain = []; in_field = false; + classes = Hashtbl.create 8; } (* Where a named type was declared, and what it has, as a note. @@ -1491,6 +1499,40 @@ let pair_params env (items : Ast.pitem list) : Ast.field list = in go items +(* A class slot's type, resolved and held to the set a stored dyn value can + be checked against: its tag says bool, int, float or text and nothing + finer, so those are the types there are. A narrower integer is a range on + top of the int tag. Everything else a type can be — a struct, a Vec, a + pointer — does not cross into dyn at all, so a slot of one could never be + written. *) +let slot_type env cls (f : Ast.field) : Types.t = + let t = resolve env f.Ast.fty in + match t with + | Types.Dyn | Types.Bool | Types.Int _ | Types.Float _ | Types.String -> t + | other -> + Loc.failk "check/slot-type" f.Ast.fty.Ast.tloc + "the slot %s of %s is declared %s, and a class slot holds a dyn value, \ + which can be checked as bool, an integer type, f32, f64 or string. \ + Write one of those, or leave the type out and the slot holds any dyn \ + value: [%s]" + f.Ast.fname cls (Types.to_string other) f.Ast.fname + +(* What the runtime is told a class is: one line per slot, in constructor + order, the slot's name and then its type's name after a space — no type + for a dyn slot. The same string goes to [flan_dyn_map_new_class] from the + constructor and to [flan_dyn_class_def] from a reload, so the two cannot + describe one class differently. *) +let class_spec_of (slots : (string * Types.t) list) = + String.concat "\n" + (List.map + (fun (n, t) -> + match t with + | Types.Dyn -> n + | t -> n ^ " " ^ Types.to_string t) + slots) + +let class_slots env n = Hashtbl.find_opt env.classes n + (* Every [defn] in the program, with its parameter vector paired. Run as a pass of its own, after the type names are registered and before any signature is resolved, so that nothing downstream ever sees an unpaired one. *) @@ -1503,6 +1545,18 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = List.map (fun (d : Ast.decl) -> match d.Ast.d with + (* A class's slot vector is paired here and nowhere earlier, for the + reason a [defn]'s is, and its constructor is written from the + pairs — [Classes.expand] left the declaration as it was for exactly + this. *) + | Ast.Defclass (n, items) -> + let slots = pair_params env items in + Hashtbl.replace env.classes n + (List.map + (fun (f : Ast.field) -> + (f.Ast.fname, slot_type env n f)) + slots); + Classes.constructor n slots d.Ast.dloc | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn f) } | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn f, c) } | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn f, c) } @@ -3450,10 +3504,14 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.MapLit (tag, kvs) -> let m = fresh_slot ctx Types.Dyn in let mval = mk loc Types.Dyn (Tast.Local m) in + (* A class's constructor stores through [flan_dyn_slot_init], which is + the plain store plus the slot's type check, worded for the + constructor rather than for a [put] nobody wrote. *) + let store = if tag = None then "flan_dyn_map_set" else "flan_dyn_slot_init" in let sets = List.map (fun (k, v) -> - rt loc Types.Unit "flan_dyn_map_set" + rt loc Types.Unit store [ mval; check ctx ~want:Types.Dyn k; check ctx ~want:Types.Dyn v ]) kvs @@ -3466,8 +3524,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = match tag with | None -> rt loc Types.Dyn "flan_dyn_map_new" [] | Some cls -> + (* The class's slots and their types ride along, so the first + instance built registers the class with the runtime and every + store after it — this literal's own included — is checked. A + class registered already, by an earlier instance or by a reload, + keeps what it has: redefining one is a reload's business. *) + let spec = + match Hashtbl.find_opt ctx.env.classes cls with + | Some slots -> class_spec_of slots + | None -> "" + in rt loc Types.Dyn "flan_dyn_map_new_class" - [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ] ] + [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ]; + mk loc Types.String (Tast.Str spec) ] in expect ctx loc ~want (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) @@ -3586,6 +3655,23 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = let v = check ctx ~want:pty v in expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) end + (* (set (get inst :slot) x) — a class instance's declared slot. A call and + not a place for [flan_dyn_set_at]'s reason: the runtime has to look at + the value to know it is an instance, which of its slots the key names, + and whether [x] fits the type that slot was declared with, and it traps + on each with a sentence of its own. A typed map has no such place; its + entries are written with [put]. *) + | Ast.Set (Ast.Pslot (target, k), v) -> + let target = check ctx target in + if target.Tast.ty <> Types.Dyn then + fail loc + "(get m k) is a place only on a class instance, and this is %s. A \ + map's entries are written with (put m k v)" + (Types.to_string target.Tast.ty); + let k = check ctx ~want:Types.Dyn k in + let v = check ctx ~want:Types.Dyn v in + expect ctx loc ~want + (rt loc Types.Unit "flan_dyn_slot_set" [ target; k; v; here loc ]) | Ast.Set (p, v) -> let p, pty = check_place ctx loc p in let v = check ctx ~want:pty v in @@ -6187,6 +6273,13 @@ and check_place ctx loc (p : Ast.place) : Tast.place * Types.t = | Types.Ptr t -> Tast.Pderef target, t | other -> fail loc "deref takes a (Ptr T), found %s" (Types.to_string other)) + (* Only [set] writes a class slot, and it has its own arm above. A slot + lives in a map the collector may move entries of, so it has no address + to hand out. *) + | Ast.Pslot _ -> + fail loc + "a class slot (get inst :slot) is written with set and has no address. \ + Read it into a local with let" (* An index or a slice bound that is a literal is known now, so it is an error now rather than a trap later. Only literals: a [defconst] is a global in the @@ -7829,12 +7922,14 @@ and named_call ?(qualified = false) ctx ~want loc name args = let target = check ctx target in (* A put into a dyn map is a call and nothing else, the way a push into a dyn vec is: the runtime owns the storage, so there is no guard, no - restart and no region check. An equal key's value is replaced. *) + restart and no region check. An equal key's value is replaced. The + site rides along for the one refusal a put can meet, a class + instance's typed slot. *) if target.Tast.ty = Types.Dyn then expect ctx loc ~want - (rt loc Types.Unit "flan_dyn_map_set" + (rt loc Types.Unit "flan_dyn_map_put" [ target; check ctx ~want:Types.Dyn k; - check ctx ~want:Types.Dyn v ]) + check ctx ~want:Types.Dyn v; here loc ]) else begin let kt, vt = map_kv loc "put" target.Tast.ty in let k = check ctx ~want:kt k in @@ -10845,7 +10940,11 @@ let collect env (decls : Ast.decl list) = driver that assembled a declaration list and skipped that pass would otherwise get a missing name from wherever the constructor was called, with nothing pointing here. *) - | Ast.Defclass (n, _) | Ast.Defgeneric { Ast.name = n; _ } + | Ast.Defclass (n, _) -> + fail loc + "internal: the class %s reached the checker unpaired — \ + pair_decls writes its constructor, and did not run" n + | Ast.Defgeneric { Ast.name = n; _ } | Ast.Defmulti { Ast.name = n; _ } -> fail loc "internal: %s reached the checker unexpanded — Classes.expand did \ diff --git a/lib/classes.ml b/lib/classes.ml index a6b7325b..15b9440a 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -4,9 +4,11 @@ [(defclass point [x y])] is a constructor. [(defgeneric area [self] dyn)] and [(defmulti describe [x] dyn (get x :kind))] are each one function whose body is a dispatch, and [(defmethod area point [p] ...)] is a branch of - one. Nothing below this pass knows any of the four forms exists: what it - writes is [defn]s, and they are checked, emitted, rooted, redefined and - inspected as any other function is. + one. What it writes is [defn]s, and they are checked, emitted, rooted, + redefined and inspected as any other function is. The one exception is + [defclass], which passes through untouched: its slot vector reads like a + [defn]'s and cannot be paired until every type name is known, so + [Check.pair_decls] pairs it and calls [constructor] below. **Why a pass and not a macro.** A macro sees one form. This needs the whole declaration list, because a method may be written anywhere — above @@ -65,23 +67,7 @@ let collect (decls : Ast.decl list) = List.iter (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> - (* Two slots of one name would write one entry and read one value, - and the constructor would take two arguments for it. The duplicate - parameter that falls out of it is refused by the checker anyway; - this says which declaration it came from. *) - let seen = Hashtbl.create 8 in - List.iter - (fun (s, sloc) -> - if Hashtbl.mem seen s then - Loc.failk "check/duplicate-slot" sloc - "%s names the slot %s twice. A slot is a key in the \ - instance's map, so the second would replace the first and \ - the constructor would take an argument that goes nowhere" - n s; - Hashtbl.replace seen s ()) - slots; - Hashtbl.replace classes n d.Ast.dloc + | Ast.Defclass (n, _) -> Hashtbl.replace classes n d.Ast.dloc | Ast.Defgeneric fn -> Hashtbl.replace generics fn.Ast.name { gkind = `Class; gfn = fn; gloc = d.Ast.dloc; gms = [] } @@ -162,14 +148,37 @@ let collect (decls : Ast.decl list) = omitted slot meaning nil — is deferred, and so is refusing an unknown slot at [(get p :z)]. Both are recorded in TODO.org, "Class features deferred, each with its reason". *) -let constructor n slots loc : Ast.decl = +let constructor n (slots : Ast.field list) loc : Ast.decl = + (* Two slots of one name would write one entry and read one value, and the + constructor would take two arguments for it. The duplicate parameter + that falls out of it is refused by the checker anyway; this says which + declaration it came from. *) + let seen = Hashtbl.create 8 in + List.iter + (fun (f : Ast.field) -> + if Hashtbl.mem seen f.Ast.fname then + Loc.failk "check/duplicate-slot" f.Ast.floc + "%s names the slot %s twice. A slot is a key in the instance's \ + map, so the second would replace the first and the constructor \ + would take an argument that goes nowhere" + n f.Ast.fname; + Hashtbl.replace seen f.Ast.fname ()) + slots; + (* Every parameter is dyn whatever its slot's type. The type is checked + where the value is stored — the constructor's own stores included — so + a caller holding a dyn passes it as it is, and a caller holding an i32 + boxes it; neither has to convert to the slot's type first. *) let params = List.map - (fun (s, sloc) -> { Ast.fname = s; fty = dyn_at sloc; floc = sloc }) + (fun (f : Ast.field) -> + { Ast.fname = f.Ast.fname; fty = dyn_at f.Ast.floc; floc = f.Ast.floc }) slots in let pairs = - List.map (fun (s, sloc) -> (ex sloc (Ast.Kw s), ex sloc (Ast.Var s))) slots + List.map + (fun (f : Ast.field) -> + (ex f.Ast.floc (Ast.Kw f.Ast.fname), ex f.Ast.floc (Ast.Var f.Ast.fname))) + slots in { Ast.d = Ast.Defn @@ -343,7 +352,9 @@ let expand (decls : Ast.decl list) : Ast.decl list = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (constructor n slots d.Ast.dloc) + (* Kept: its slot vector cannot be paired until every type name is + known, so [Check.pair_decls] writes the constructor. *) + | Ast.Defclass _ -> Some d | Ast.Defgeneric fn | Ast.Defmulti fn -> Some (dispatcher (Hashtbl.find generics fn.Ast.name)) (* Gone: its body is inside its generic's dispatch. *) diff --git a/lib/dev.ml b/lib/dev.ml index d83191d7..a22901a7 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1422,17 +1422,29 @@ let defs t = [M-.] on a prelude macro from "the prelude is not a file on disk" into a shrug about the daemon having no location. *) let macro_locs = Hashtbl.create 16 in - (* The classes, off the session's declarations: [Classes.expand] turns a - [defclass] into its constructor [defn] before the checker runs, so the - class is not in [Tast.program] or the checker's environment, and the - declarations are the one place that still has it. Its constructor is - dropped from the [fn] rows for the macro rows' reason: one name, one row, - and [class] is what was written. *) + (* The classes: where each was written, off the session's declarations, + and its slots as the checker paired them, off its environment — the + slot vector is unreadable before pairing. The constructor the checker + wrote is dropped from the [fn] rows for the macro rows' reason: one name, + one row, and [class] is what was written. *) let classes = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (n, List.map fst slots, d.Ast.dloc) + | Ast.Defclass (n, _) -> + let slots = + Option.value ~default:[] + (Check.class_slots t.session.Session.env n) + in + Some + (n, + List.map + (fun (s, ty) -> + match ty with + | Types.Dyn -> s + | ty -> s ^ " " ^ Types.to_string ty) + slots, + d.Ast.dloc) | _ -> None) t.session.Session.decls in diff --git a/lib/emit.ml b/lib/emit.ml index 800e4a71..13dc14fc 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4370,7 +4370,10 @@ declare i64 @flan_dyn_from_bool(i32) declare i64 @flan_dyn_from_bytes(ptr, i64) declare i64 @flan_dyn_vec_new() declare i64 @flan_dyn_map_new() -declare i64 @flan_dyn_map_new_class(i64) +declare i64 @flan_dyn_map_new_class(i64, ptr, i64) +declare void @flan_dyn_slot_set(i64, i64, i64, ptr, i64) +declare void @flan_dyn_slot_init(i64, i64, i64) +declare void @flan_dyn_map_put(i64, i64, i64, ptr, i64) declare i64 @flan_dyn_class_of(i64) declare void @flan_dyn_class_def(i64, ptr, i64) declare i64 @flan_dyn_kw(ptr, i64) diff --git a/lib/load.ml b/lib/load.ml index a3f28a9b..97a5220d 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -390,6 +390,7 @@ and rename_place owned alias bound (p : Ast.place) : Ast.place = | Ast.Pfield (t, f) -> Ast.Pfield (go t, f) | Ast.Pindex (t, idx) -> Ast.Pindex (go t, List.map go idx) | Ast.Pderef t -> Ast.Pderef (go t) + | Ast.Pslot (t, k) -> Ast.Pslot (go t, go k) let rename_field owned alias (f : Ast.field) : Ast.field = { f with Ast.fty = rename_texpr owned alias f.Ast.fty } @@ -501,12 +502,17 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = and the rename is the ordinary one: the declared name, plus whatever inside them is a name of this package. - A class's slots are not renamed. They are keywords in the map the + A class's slot names are not renamed. They are keywords in the map the constructor builds, and a keyword belongs to nobody — the same line the - [MapLit] arm above takes about a map literal's keys. The *class's* name - is qualified, so [pkg/point] is what an instance's shape tag reads and - two packages' [point] classes are two classes. *) - | Ast.Defclass (n, slots) -> Ast.Defclass (qualify alias n, slots) + [MapLit] arm above takes about a map literal's keys. A slot's *type* is + a type like any other, and the vector is unpaired, so it goes through + [rename_pitem] as a [defn]'s does: a bare symbol the package owns is a + type of this package, since no slot name is ever an owned name that + matters. The *class's* name is qualified, so [pkg/point] is what an + instance's shape tag reads and two packages' [point] classes are two + classes. *) + | Ast.Defclass (n, slots) -> + Ast.Defclass (qualify alias n, List.map (rename_pitem owned alias) slots) (* A generic's parameters are dyn and were written out by the parser, so there is no unpaired vector here and [bound] is exactly the parameter names. *) @@ -832,6 +838,7 @@ and place_uses acc loc (p : Ast.place) = | Ast.Pfield (t, _) -> expr_uses acc t | Ast.Pindex (t, idx) -> expr_uses acc t; List.iter (expr_uses acc) idx | Ast.Pderef t -> expr_uses acc t + | Ast.Pslot (t, k) -> expr_uses acc t; expr_uses acc k let decl_uses acc (d : Ast.decl) = let field (f : Ast.field) = texpr_uses acc f.Ast.fty in @@ -873,9 +880,14 @@ let decl_uses acc (d : Ast.decl) = | Ast.Zeroed | Ast.Uninit -> ()) | Ast.Defconst (_, t, v) -> Option.iter (texpr_uses acc) t; expr_uses acc v - (* A class's slots are keywords and name nothing. Its constructor's body is - written by [Classes.expand], long after this, out of the slots alone. *) - | Ast.Defclass _ -> () + (* A class's slot names are keywords and name nothing; its slot types are + uses, recorded the way an unpaired [defn] vector's are. *) + | Ast.Defclass (_, slots) -> + List.iter + (function + | Ast.Pname (n, loc) -> acc := (n, loc) :: !acc + | Ast.Ptype t -> texpr_uses acc t) + slots | Ast.Defgeneric f | Ast.Defmulti f -> fn f (* The generic is a use — a method in one package extending another's has to pull that package in — and so is the class in the dispatch slot, for the diff --git a/lib/parse.ml b/lib/parse.ml index c380830b..2b596ab5 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1205,13 +1205,19 @@ and place (f : Form.t) : Ast.place = either inserts or replaces — so there is no store into a lookup, and an entry that is absent has no location to store into. Refused here rather than parsed into a place form the language does not have. *) + (* A class instance's slot: declared by its defclass, so it always exists + and is a place, where a map's absent key is not. Whether the value is an + instance or a map is a run-time fact, so the store is a run-time call + and a map there is refused by it. *) + | List [ { v = Sym "get"; _ }; target; key ] -> + Ast.Pslot (expr target, expr key) | List ({ v = Sym "get"; _ } :: _) -> fail f "(get m k) is not a place — a map is written with (put m k v)" | List [ { v = Sym "deref"; _ }; p ] -> Ast.Pderef (expr p) | _ -> fail f "%s is not assignable. set takes a name, (.field x), (at a i ...), \ - or (deref p)" + (deref p), or a class slot (get inst :slot)" (Form.to_string f) and arms f (items : Form.t list) : Ast.arm list = @@ -1484,20 +1490,15 @@ let rec decl (f : Form.t) : Ast.decl = only names can be read here. *) | List ({ v = Sym "defclass"; _ } :: args) -> (match args with + (* The slot vector is a [defn]'s parameter vector in every respect — + [[x y]] two dyn slots, [[pause bool step bool]] two typed ones — and + is carried undecided for the same reason. *) | [ n; { v = Vec slots; _ } ] -> - mk (Ast.Defclass - (dname n, - List.map - (fun (s : Form.t) -> - match s.v with - | Sym name -> no_sigil s; (name, s.loc) - | _ -> - fail s - "a class slot is a name — its value is dyn, so there \ - is no type to write. Read one with (get p :%s)" - (Form.to_string s)) - slots)) - | _ -> fail f "defclass is (defclass Name [slot ...])") + List.iter + (fun (s : Form.t) -> match s.v with Sym _ -> no_sigil s | _ -> ()) + slots; + mk (Ast.Defclass (dname n, pitems slots)) + | _ -> fail f "defclass is (defclass Name [slot Type ...])") | List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) -> let generic = String.equal which "defgeneric" in diff --git a/lib/session.ml b/lib/session.ml index 00a4c241..c682fad7 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -747,27 +747,27 @@ let eval ?(origin = "") ?pause t src : change = A class whose slot list did not change is not in here at all: its constructor has the same signature and goes through [compatible] untouched. *) - let class_slots (ds : Ast.decl list) n = - List.fold_left - (fun acc (d : Ast.decl) -> - match d.Ast.d with - | Ast.Defclass (m, slots) when String.equal m n -> - Some (List.map fst slots) - | _ -> acc) - None ds + (* The slots as the checker paired them, off each side's environment: the + vector is not readable before pairing, and [t.env] is the one the + running program was checked against. Only the names decide the + constructor's arity; the types are the registration's business below. *) + let slot_names env n = + Option.map (List.map fst) (Check.class_slots env n) in let incoming_classes = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (n, List.map fst slots) + | Ast.Defclass (n, _) -> + Some (n, Option.value ~default:[] (Check.class_slots env n)) | _ -> None) incoming in let relaxed = List.filter_map (fun (n, slots) -> - match class_slots t.decls n with + let slots = List.map fst slots in + match slot_names t.env n with | Some old when old <> slots -> (* Every function of the running program that calls the constructor or takes its address, minus the ones this @@ -971,15 +971,16 @@ let eval ?(origin = "") ?pause t src : change = { Tast.e = Tast.Prim (Tast.Rt "flan_dyn_kw", [ str n ]); ty = Types.Dyn; loc } in - (* The slot names in one string, newline between: the runtime - splits them. A dyn vector would have been the obvious shape - and is the wrong one — it is a collector object, so the - registry would hold something the marker has to reach, where - a packed string reaches interned keywords that are immortal - already. *) + (* The slots in one string, a line each with the slot's type + after its name: the runtime splits them. A dyn vector would + have been the obvious shape and is the wrong one — it is a + collector object, so the registry would hold something the + marker has to reach, where a packed string reaches interned + keywords that are immortal already. The constructor carries + the same string, from the same function. *) { Tast.e = Tast.Prim (Tast.Rt "flan_dyn_class_def", - [ kw; str (String.concat "\n" slots) ]); + [ kw; str (Check.class_spec_of slots) ]); ty = Types.Unit; loc }) incoming_classes in diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index c7a8c724..d2849afe 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1172,12 +1172,14 @@ flan_dyn flan_dyn_map_new(void) { * of dyn vectors would have needed both, and would have needed them to * survive a collection triggered from inside a migration. * - * **What the registry does not do.** It does not constrain [put]. A class + * **What the registry constrains.** A store into a slot the class declares + * — the constructor's, [put]'s, [set]'s — is checked against the slot's + * type. A key the class does not declare is not refused by [put]: a class * instance is an open map — TODO.org, "Class features deferred, each with its - * reason", already defers unknown-slot checking — so a key nobody declared - * can be written to one, and the migration below will *drop* it at the next + * reason", defers unknown-slot checking — so a key nobody declared can be + * written to one, and the migration below will *drop* it at the next * redefinition, because its rule is that an instance's keys are the class's - * slots. That is real data loss and it is written down as such in TODO.org, + * slots. [set] does refuse one, because a slot it writes has to exist. That is real data loss and it is written down as such in TODO.org, * "A redefined defclass migrates its instances lazily", rather than dressed * up as enforcement. * @@ -1219,9 +1221,26 @@ flan_dyn flan_dyn_map_new(void) { * runs ahead of its definition declares itself. */ flan_dyn flan_dyn_kw(const uint8_t *p, int64_t n); +/* What a slot may hold. A dyn value's tag is the whole of what can be asked + * of it, so these are the tags, plus a range on top of the int tag for a + * slot declared with a narrower integer type. [word] is the type as the + * defclass wrote it, for the sentence a refusal prints. */ +enum { ST_ANY, ST_BOOL, ST_INT, ST_FLOAT, ST_TEXT }; + +typedef struct slot_type { + uint8_t kind; + int64_t lo, hi; /* ST_INT only */ + const char *word; /* static; NULL for ST_ANY */ +} slot_type; + typedef struct class_entry { kw_entry *name; kw_entry **slots; /* interned, immortal, in declaration order */ + slot_type *types; /* one per slot, same order */ + /* Per slot, the generation a migration last warned about a value that no + * longer fits the slot's type. One warning per slot per redefinition, + * however many instances carry such a value. */ + uint32_t *warned; int64_t nslots; uint32_t gen; } class_entry; @@ -1237,74 +1256,99 @@ static class_entry *class_find(kw_entry *name) { } /* The generation a new instance of [name] is stamped with. Zero for a class - * no definition has been registered for, which is every class in a program - * that was built and never reloaded: nothing has changed shape, so nothing - * needs to migrate, and the registry earns its keep only once an editor has - * sent a new definition. */ + * no definition has been registered for — which, now that the constructor + * registers its class, is only an instance built by something other than a + * constructor: test/dyn_ops.c, calling the runtime directly. */ static uint32_t class_gen(kw_entry *name) { class_entry *e = class_find(name); return e == NULL ? 0u : e->gen; } -/* One class's current slot list, as the compiler's per-reload thunk hands it - * over: the class's name as a keyword, and the slot names packed into one - * string, newline between and no leading colons — the shape a string literal - * already crosses in, rather than a dyn vector this would have to root. - * - * The generation is bumped only when the list actually differs. That is what - * makes C-c C-k idempotent: reloading a file re-runs every one of its class - * definitions, and a bump per reload would migrate every instance in the - * program every time anybody saved, for no change. */ -void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { - kw_entry *k; - kw_entry **list = NULL; - int64_t count = 0, i, start; - class_entry *e; - if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD) - /* No location: the caller is the thunk a reload runs, which has no - source position of its own — the class's own [defclass] is where a - reader would look, and it is not on any stack by the time this runs. - Unreachable from written Flan in any case; only the compiler emits - this call, and it emits a keyword. */ - trap1(NULL, 0, TYPE_TRAP, "class definition", - "a class name is a keyword", name); - k = dyn_kw(name); +static slot_type slot_type_of(const uint8_t *w, int64_t n) { + static const struct { const char *w; uint8_t kind; int64_t lo, hi; } known[] = { + { "bool", ST_BOOL, 0, 0 }, + { "string", ST_TEXT, 0, 0 }, + { "f32", ST_FLOAT, 0, 0 }, + { "f64", ST_FLOAT, 0, 0 }, + { "i8", ST_INT, INT8_MIN, INT8_MAX }, + { "i16", ST_INT, INT16_MIN, INT16_MAX }, + { "i32", ST_INT, INT32_MIN, INT32_MAX }, + { "i64", ST_INT, INT64_MIN, INT64_MAX }, + { "u8", ST_INT, 0, UINT8_MAX }, + { "u16", ST_INT, 0, UINT16_MAX }, + { "u32", ST_INT, 0, UINT32_MAX }, + { "u64", ST_INT, 0, INT64_MAX }, + }; + slot_type t = { ST_ANY, 0, 0, NULL }; + size_t i; + for (i = 0; i < sizeof known / sizeof known[0]; i++) + if ((int64_t)strlen(known[i].w) == n && memcmp(known[i].w, w, (size_t)n) == 0) { + t.kind = known[i].kind; + t.lo = known[i].lo; + t.hi = known[i].hi; + t.word = known[i].w; + return t; + } + /* A word this table does not know is a compiler newer than this runtime. + Holding anything is the answer that loses no data. */ + return t; +} + +static int slot_fits(const slot_type *t, flan_dyn v) { + int tag = flan_dyn_tag(v); + switch (t->kind) { + case ST_BOOL: return tag == FLAN_DYN_TAG_BOOL; + case ST_TEXT: return tag == FLAN_DYN_TAG_TEXT; + case ST_FLOAT: return tag == FLAN_DYN_TAG_FLOAT; + case ST_INT: { + int64_t x; + if (tag != FLAN_DYN_TAG_INT) return 0; + x = dyn_int_value(v); + return x >= t->lo && x <= t->hi; + } + default: return 1; + } +} + +/* A class's slots as the compiler hands them over: one line per slot, the + * slot's name and then, after a space, its type's name — nothing for a slot + * written with no type. The same string comes from a constructor and from a + * reload, so it is read in one place. The count is returned; both arrays are + * NULL for a class with no slots, which allocates nothing. */ +static int64_t class_spec(const uint8_t *spec, int64_t n, kw_entry ***names, + slot_type **types) { + int64_t count = 0, i, start; if (n < 0) n = 0; - /* Count first, then fill: one allocation of the right size, and an empty - * class — (defclass marker []) is in the corpus — allocates nothing. */ + *names = NULL; + *types = NULL; for (i = 0, start = 0; i <= n; i++) - if (i == n ? i > start : slots[i] == '\n') { + if (i == n ? i > start : spec[i] == '\n') { if (i > start) count++; start = i + 1; } - if (count > 0) { - list = (kw_entry **)malloc((size_t)count * sizeof *list); - if (list == NULL) trap_oom(NULL, 0, count * (int64_t)sizeof *list); - count = 0; - for (i = 0, start = 0; i <= n; i++) - if (i == n ? i > start : slots[i] == '\n') { - if (i > start) - list[count++] = dyn_kw(flan_dyn_kw(slots + start, i - start)); - start = i + 1; + if (count == 0) return 0; + *names = (kw_entry **)malloc((size_t)count * sizeof **names); + *types = (slot_type *)malloc((size_t)count * sizeof **types); + if (*names == NULL || *types == NULL) + trap_oom(NULL, 0, count * (int64_t)(sizeof **names + sizeof **types)); + count = 0; + for (i = 0, start = 0; i <= n; i++) + if (i == n ? i > start : spec[i] == '\n') { + if (i > start) { + int64_t sp = start; + while (sp < i && spec[sp] != ' ') sp++; + (*names)[count] = dyn_kw(flan_dyn_kw(spec + start, sp - start)); + (*types)[count] = sp < i ? slot_type_of(spec + sp + 1, i - sp - 1) + : slot_type_of(NULL, 0); + count++; } - } - e = class_find(k); - if (e != NULL) { - int same = e->nslots == count; - if (same) - for (i = 0; i < count; i++) - if (e->slots[i] != list[i]) { same = 0; break; } - if (same) { free(list); return; } - free(e->slots); - e->slots = list; - e->nslots = count; - /* Wrapping is not a correctness question — what matters is that the new - * generation differs from the one the live instances carry — but zero is - * reserved for "no definition registered", so it is stepped over. */ - e->gen = e->gen + 1u; - if (e->gen == 0u) e->gen = 1u; - return; - } + start = i + 1; + } + return count; +} + +static void class_add(kw_entry *k, kw_entry **list, slot_type *types, + int64_t count) { if (classes_n == classes_cap) { int64_t cap = classes_cap ? classes_cap * 2 : 8; class_entry *t = @@ -1315,6 +1359,11 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { } classes[classes_n].name = k; classes[classes_n].slots = list; + classes[classes_n].types = types; + classes[classes_n].warned = + count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL; + if (count > 0 && classes[classes_n].warned == NULL) + trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); classes[classes_n].nslots = count; /* One, never zero: an instance built before this registration carries zero * and has to be seen as stale, because the definition it was built from is @@ -1323,6 +1372,61 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { classes_n++; } +/* One class's current definition, as the compiler's per-reload thunk hands + * it over: the class's name as a keyword, and [class_spec]'s string. + * + * The generation is bumped only when the definition actually differs — a + * slot's name or its type. That is what makes C-c C-k idempotent: reloading + * a file re-runs every one of its class definitions, and a bump per reload + * would migrate every instance in the program every time anybody saved, for + * no change. */ +void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { + kw_entry *k; + kw_entry **list; + slot_type *types; + int64_t count, i; + class_entry *e; + if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD) + /* No location: the caller is the thunk a reload runs, which has no + source position of its own — the class's own [defclass] is where a + reader would look, and it is not on any stack by the time this runs. + Unreachable from written Flan in any case; only the compiler emits + this call, and it emits a keyword. */ + trap1(NULL, 0, TYPE_TRAP, "class definition", + "a class name is a keyword", name); + k = dyn_kw(name); + count = class_spec(slots, n, &list, &types); + e = class_find(k); + if (e != NULL) { + int same = e->nslots == count; + if (same) + for (i = 0; i < count; i++) + if (e->slots[i] != list[i] || e->types[i].kind != types[i].kind + || e->types[i].lo != types[i].lo || e->types[i].hi != types[i].hi) { + same = 0; + break; + } + if (same) { free(list); free(types); return; } + free(e->slots); + free(e->types); + free(e->warned); + e->slots = list; + e->types = types; + e->warned = + count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL; + if (count > 0 && e->warned == NULL) + trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); + e->nslots = count; + /* Wrapping is not a correctness question — what matters is that the new + * generation differs from the one the live instances carry — but zero is + * reserved for "no definition registered", so it is stepped over. */ + e->gen = e->gen + 1u; + if (e->gen == 0u) e->gen = 1u; + return; + } + class_add(k, list, types, count); +} + /* The migration. [o] is left holding exactly the class's current slots, in * the class's order, with the values it already had for the ones it still * has and nil for the ones it has just gained — which is precisely the @@ -1367,6 +1471,27 @@ static void class_sync(flan_obj *o) { if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD && dyn_kw(key) == e->slots[j]) { v = o->u.v.items[i * 2 + 1]; + /* A kept value that the slot's new type does not admit is kept + anyway: throwing it away would be the data loss a redefinition + exists to avoid, and there is nothing to convert it to. What it + gets is a warning, once per slot per redefinition, and the next + write to the slot is checked like any other. A slot the class + has only just gained holds nil without a word: it holds nothing, + rather than something of the wrong type. */ + if (!slot_fits(&e->types[j], v) && e->warned[j] != e->gen) { + char sv[SAY_MAX]; + kw_entry *c = o->u.v.klass, *sl = e->slots[j]; + e->warned[j] = e->gen; + say(sv, SAY_MAX, v); + fflush(stdout); + fprintf(stderr, + "warning: %.*s was redefined, and its slot :%.*s is now " + "declared %s. An instance holds %s there, which is %s; it " + "keeps that value, and the next write to :%.*s is checked\n", + (int)c->len, (const char *)(c + 1), + (int)sl->len, (const char *)(sl + 1), e->types[j].word, sv, + tag_of(v), (int)sl->len, (const char *)(sl + 1)); + } break; } } @@ -1386,11 +1511,25 @@ static void class_sync(flan_obj *o) { /* The same map with a shape tag on it: what a (defclass ...) constructor * calls. [k] is a keyword and anything else traps by name — the compiler - * hands it the class's own name and nothing else can reach this. */ -flan_dyn flan_dyn_map_new_class(flan_dyn k) { + * hands it the class's own name and nothing else can reach this. + * + * [spec] is the class's definition, [class_spec]'s string, and it registers + * the class the first time any instance of it is built. That is what makes + * a slot's type checked in a program that is never reloaded — the registry + * used to be filled only by a reload. A class already registered keeps + * what it has, and has to: a constructor compiled before a redefinition may + * still be on some stack, and letting its definition win would put the + * class back the way it was. Redefining is [flan_dyn_class_def]'s alone. */ +flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n) { flan_obj *o; if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) trap1(NULL, 0, TYPE_TRAP, "class instance", "a class tag is a keyword", k); + if (class_find(dyn_kw(k)) == NULL) { + kw_entry **list; + slot_type *types; + int64_t count = class_spec(spec, n, &list, &types); + class_add(dyn_kw(k), list, types, count); + } o = gc_alloc(OBJ_MAP, 0); o->len = 0; o->u.v.items = NULL; @@ -2265,8 +2404,141 @@ flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) { return flan_dyn_from_bool(map_find(o, k) >= 0); } -void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) { +/* A class slot's type, checked at the store — SBCL's place for it + * (src/pcl/slots.lisp, [set-slot-value]'s typecheck before the write), + * because the store is where the wrong value is. -1 when [k] is not a slot + * the class declares. */ +static int64_t class_slot(class_entry *e, flan_dyn k) { + int64_t j; + if (e == NULL || flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) return -1; + for (j = 0; j < e->nslots; j++) + if (e->slots[j] == dyn_kw(k)) return j; + return -1; +} + +/* The three stores that reach a declared slot, for the sentence a refusal + * prints: the call as it would have been written. */ +enum { BY_PUT, BY_SET, BY_NEW }; + +static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, + int by, flan_obj *o, class_entry *e, + int64_t j, flan_dyn m, flan_dyn v) { + char sm[SAY_MAX], sv[SAY_MAX]; + kw_entry *sl = e->slots[j], *c = o->u.v.klass; + int sn = (int)sl->len, cn = (int)c->len; + const char *ss = (const char *)(sl + 1), *cs = (const char *)(c + 1); + say(sm, SAY_MAX, m); + say(sv, SAY_MAX, v); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, "dyn %s: the slot :%.*s of %.*s is declared %s, and ", + by == BY_PUT ? "put" : by == BY_SET ? "set" : "construct", sn, ss, + cn, cs, e->types[j].word); + /* An int of the wrong size is the right tag, so the tag is not the news. */ + if (e->types[j].kind == ST_INT && flan_dyn_tag(v) == FLAN_DYN_TAG_INT) + fprintf(stderr, "%s is outside its range — ", sv); + else + fprintf(stderr, "this is %s — ", tag_of(v)); + if (by == BY_PUT) + fprintf(stderr, "(put %s :%.*s %s)\n", sm, sn, ss, sv); + else if (by == BY_SET) + fprintf(stderr, "(set (get %s :%.*s) %s)\n", sm, sn, ss, sv); + else + fprintf(stderr, "(%.*s ...) with :%.*s %s\n", cn, cs, sn, ss, sv); + flan_trap((const uint8_t *)"DynType", 7); +} + +static void check_slot(const uint8_t *loc, int64_t loclen, int by, + flan_obj *o, flan_dyn m, flan_dyn k, flan_dyn v) { + class_entry *e; + int64_t j; + if (o->u.v.klass == NULL) return; + e = class_find(o->u.v.klass); + j = class_slot(e, k); + if (j >= 0 && !slot_fits(&e->types[j], v)) + trap_slot_type(loc, loclen, by, o, e, j, m, v); +} + +static void map_store(flan_obj *o, flan_dyn k, flan_dyn v); + +/* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for + * the constructor call it happened inside rather than for a [put] nobody + * wrote. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v) { + flan_obj *o = want_map("construct", m, k); + check_slot(NULL, 0, BY_NEW, o, m, k, v); + map_store(o, k, v); +} + +/* (set (get inst :slot) v). Three refusals, each its own sentence, because + * they are three different mistakes: the value is not a class instance at + * all (a map's entries are written with [put], which is where inserting a + * key is real); the key is not a slot the class declares; the value does not + * fit the slot's type. The first two are why this is not [put]: a declared + * slot always exists, so writing one is a store and never an insertion. */ +void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen) { + flan_obj *o; + class_entry *e; + int64_t j; + if (!is_map(m) || dyn_obj(m)->u.v.klass == NULL) { + char sm[SAY_MAX]; + say(sm, SAY_MAX, m); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, + "dyn set: (get m k) is a place only on a class instance, and " + "this is %s%s — %s. A map's entries are written with " + "(put m k v)\n", + is_map(m) ? "a map with no class" : "a ", + is_map(m) ? "" : tag_of(m), sm); + flan_trap((const uint8_t *)"DynType", 7); + } + o = dyn_obj(m); + class_sync(o); + e = class_find(o->u.v.klass); + j = class_slot(e, k); + if (j < 0) { + char sk[SAY_MAX]; + kw_entry *c = o->u.v.klass; + int64_t i; + say(sk, SAY_MAX, k); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, "dyn set: %.*s has no slot %s. Its slots are", + (int)c->len, (const char *)(c + 1), sk); + if (e == NULL || e->nslots == 0) fprintf(stderr, " none"); + else + for (i = 0; i < e->nslots; i++) + fprintf(stderr, " :%.*s", (int)e->slots[i]->len, + (const char *)(e->slots[i] + 1)); + fprintf(stderr, "; a key the class does not declare is written with " + "(put inst k v)\n"); + flan_trap((const uint8_t *)"DynType", 7); + } + if (!slot_fits(&e->types[j], v)) + trap_slot_type(loc, loclen, BY_SET, o, e, j, m, v); + map_store(o, k, v); +} + +/* [put]: a key the class declares is checked against its type, and the + * refusal names [loc]. A key it does not declare is let through: an + * instance is an open map to [put], and the next redefinition drops such a + * key — see "Classes" above. */ +void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, + int64_t loclen) { flan_obj *o = want_map("put", m, k); + check_slot(loc, loclen, BY_PUT, o, m, k, v); + map_store(o, k, v); +} + +/* The same with no site: a map literal's stores, and test/dyn_ops.c. */ +void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) { + flan_dyn_map_put(m, k, v, NULL, 0); +} + +/* The store under all three, with the instance already brought up to date. */ +static void map_store(flan_obj *o, flan_dyn k, flan_dyn v) { int64_t i = map_find(o, k); if (i >= 0) { o->u.v.items[i * 2 + 1] = v; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 889be2e7..8b73adf6 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -88,15 +88,28 @@ flan_dyn flan_dyn_map_new(void); * * The tag is not traced and does not have to be: an interned keyword entry is * immortal and is not a collector object. */ -flan_dyn flan_dyn_map_new_class(flan_dyn k); +flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n); + +/* A constructor's store into a slot, checked against the slot's declared + * type — [flan_dyn_map_set] with a refusal worded for the constructor. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v); + +/* (set (get inst :slot) v): [m] must be a class instance and [k] a slot its + * class declares, and [v] must fit the slot's type; each is a trap with its + * own sentence, at [loc]. A declared slot always exists, so this stores and + * never inserts. */ +void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); /* The class's name as a keyword, or nil for anything that is not an instance * — an ordinary map included. Never traps. */ flan_dyn flan_dyn_class_of(flan_dyn v); /* A class definition, registered or re-registered: [name] is the class's name - * as a keyword and [slots]/[n] is its slot names packed into one string, - * newline between and no leading colons. The compiler emits one call per + * as a keyword and [slots]/[n] is its slots packed into one string, a line + * each, the slot's name and then — after a space, for a typed slot — its + * type's name: "x i64\ny" is an i64 slot :x and a slot :y of any value. + * [flan_dyn_map_new_class] takes the same string. The compiler emits one call per * (defclass ...) into the thunk a reload runs, so a definition that changed * lands here before anything touches an instance. * @@ -185,6 +198,10 @@ void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen); * key in place, so a key occurs once and insertion order is print order. */ flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k); void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v); +/* [put]'s: [flan_dyn_map_set], with the site a typed class slot's refusal + * prints. */ +void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k); /* Structural, and per type it renders what typed [print] renders. Never diff --git a/test/dyn_ops.c b/test/dyn_ops.c index dd9eb728..c4f4d292 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -1061,7 +1061,8 @@ static void define(const char *name, const char *slots) { * Built through the same entry point a constructor uses, so it is stamped * exactly as compiled code would stamp it. */ static flan_dyn a_point(int64_t x, int64_t y) { - flan_dyn p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5)); + flan_dyn p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5), + (const uint8_t *)"x\ny", 3); flan_dyn_map_set(p, flan_dyn_kw((const uint8_t *)"x", 1), flan_dyn_from_i64(x)); flan_dyn_map_set(p, flan_dyn_kw((const uint8_t *)"y", 1), @@ -1176,7 +1177,8 @@ static void classes(void) { define("point", "x\ny\nn"); /* Built by hand rather than through [a_point], because it is the instance the *new* constructor would build: three slots, stamped current. */ - q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5)); + q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5), + (const uint8_t *)"x\ny\nn", 5); flan_dyn_map_set(q, flan_dyn_kw((const uint8_t *)"x", 1), flan_dyn_from_i64(1)); flan_dyn_map_set(q, flan_dyn_kw((const uint8_t *)"y", 1), diff --git a/test/programs/dyn-class-slots.flan b/test/programs/dyn-class-slots.flan new file mode 100644 index 00000000..ea38ef7e --- /dev/null +++ b/test/programs/dyn-class-slots.flan @@ -0,0 +1,38 @@ +;;;; Typed class slots, and set on a slot. +;;;; +;;;; A slot vector reads as a defn's parameter vector: [pause bool] is a slot +;;;; of type bool, and a name followed by another name is a slot with no type, +;;;; which holds any dyn value. The type is checked when a value is stored -- +;;;; by the constructor, by put and by set -- and not when one is read: an +;;;; instance is a dyn map whatever its slots say. +;;;; +;;;; set writes a declared slot. A class declares its slots, so one always +;;;; exists and (get s :pause) is a place, where a plain map's absent key is +;;;; not. dyn-slot-trap.flan has the refusals. + +(defclass state [pause bool step i32 speed f64 name string tag]) + +(defn twelve [] i64 12) + +(defn main [] i32 + (let [s (state false 3 1.5 "sand" :x)] + (println s) + (set (get s :pause) true) + (println (get s :pause)) + ;; An i32 slot takes any int in i32's range; a dyn caller passes the + ;; value as it is, with nothing converted first. + (set (get s :step) -7) + (println (get s :step)) + (set (get s :tag) [1 2]) + (println (get s :tag)) + ;; put reaches the same check for a declared slot, and still inserts a + ;; key the class does not declare -- an instance is an open map to put. + (put s :speed 2.5) + (put s :scratch 9) + (println (get s :speed)) + (println (get s :scratch)) + (println (length s)) + ;; A typed caller boxes into the dyn parameter as any call does. + (set (get s :step) (twelve)) + (println (get s :step))) + 0) diff --git a/test/programs/dyn-slot-trap.flan b/test/programs/dyn-slot-trap.flan new file mode 100644 index 00000000..15a025ca --- /dev/null +++ b/test/programs/dyn-slot-trap.flan @@ -0,0 +1,18 @@ +;;;; The refusals of a typed class slot, one per run because each ends the +;;;; process. The argument chooses which. The line numbers are asserted by +;;;; the test, so an edit above them moves them. +(defclass state [pause bool step i32 tag]) + +(defn as-dyn [d dyn] dyn d) + +(defn main [args [string]] i32 + (let [which (if (> (length args) 1) (i32 (bytes->i64 (bytes-view (at args 1)))) 0) + s (state false 3 nil)] + (println "before") + (cond + (= which 0) (println (state 1 2 3)) + (= which 1) (put s :pause 1) + (= which 2) (set (get s :step) 5000000000) + (= which 3) (set (get s :paws) true) + :else (set (get (as-dyn {:pause 1}) :pause) true))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 6ced8956..5487ece0 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -4935,6 +4935,47 @@ level "1" index_site (); index_site ~x86:true (); + (* Typed class slots and set on a slot: the stores that fit, then one + run per refusal. The constructor, put and set each check a declared + slot's type, set refuses a slot the class does not declare and a + value that is not an instance, and put still inserts an undeclared + key. On both backends, because every one of these is a runtime call + whose arguments the two emit separately. *) + let slots_out = + "#state{ :pause false :step 3 :speed 1.5 :name \"sand\" :tag :x}\n\ + true\n-7\n[ 1 2]\n2.5\n9\n6\n12\n" + in + outputs "dyn: typed class slots" "programs/dyn-class-slots.flan" slots_out; + outputs ~x86:true "dyn: typed class slots, --x86" + "programs/dyn-class-slots.flan" slots_out; + let slot_trap ?x86 () = + let exe = compile ?x86 "programs/dyn-slot-trap.flan" in + List.iter + (fun (arg, want) -> + let code, text = run exe (Some arg) in + if code <> 134 || not (contains text want) then begin + incr failures; + Printf.printf + "FAIL dyn: a class slot's refusal%s\n got: %S \ + (exit %d)\n wanted: %S (exit 134)\n" + (match x86 with Some true -> ", --x86" | _ -> "") + text code want + end) + [ ("0", "dyn construct: the slot :pause of state is declared bool, \ + and this is int — (state ...) with :pause 1"); + ("1", "dyn-slot-trap.flan:14:19: dyn put: the slot :pause of state \ + is declared bool, and this is int"); + ("2", "dyn-slot-trap.flan:15:19: dyn set: the slot :step of state \ + is declared i32, and 5000000000 is outside its range"); + ("3", "dyn-slot-trap.flan:16:19: dyn set: state has no slot :paws. \ + Its slots are :pause :step :tag"); + ("4", "dyn-slot-trap.flan:17:13: dyn set: (get m k) is a place only \ + on a class instance, and this is a map with no class") ]; + (try Sys.remove exe with Sys_error _ -> ()) + in + slot_trap (); + slot_trap ~x86:true (); + (* A numeric cast opening a dyn box — TODO.org, "A numeric cast opens a dyn box". programs/dyn-cast.flan is one program because the three behaviours are one story told in order: the same-kind casts print, the diff --git a/test/test_flan.ml b/test/test_flan.ml index d7857883..1c3fddf0 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -2611,14 +2611,31 @@ let () = rejects_check "a constructor takes one argument per slot" "(defclass point [x y])\n(defn main [] i32 (let [p (point 1)] 0))" ~needle:"point"; - (* A slot vector holds names and nothing else. [(defclass point [x i64])] - is therefore two slots, one of them unfortunately named — the parser - cannot tell a type's name from a slot's and does not have to, since a - slot has no type to write. What it can tell is a form that is not a name - at all. *) - rejects_check "a slot is a name, not a type expression" + (* A slot vector is a defn's parameter vector: a name followed by a type + is a typed slot, a name followed by another name is an untyped one. The + type is what a stored dyn value is checked against, so it is one a dyn + value can be checked as, and nothing else. *) + accepts "typed slots, and untyped ones beside them" + "(defclass state [pause bool step bool n i32 tag])\n\ + (defn main [] i32 (let [s (state false true 3 :x)] (if (= (get s :n) 3) 0 1)))"; + rejects_check "a slot's type is one a dyn value can be checked as" "(defclass point [x (Ptr i64)])\n(defn main [] i32 0)" - ~needle:"a class slot is a name"; + ~needle:"the slot x of point is declared (Ptr i64)"; + rejects_check "a capitalised name in a slot vector is an unknown type" + "(defclass point [x Widget])\n(defn main [] i32 0)" + ~needle:"unknown type Widget"; + rejects_check "a slot's type is resolved like any other" + "(defclass point [x f65])\n(defn main [] i32 0)" + ~needle:"did you mean f64"; + (* The slot is a place: its class declares it, so it always exists. *) + accepts "set writes a class slot" + "(defclass state [pause bool])\n\ + (defn main [] i32 (let [s (state false)] (set (get s :pause) true) \ + (if (get s :pause) 0 1)))"; + rejects_check "a class slot has no address" + "(defclass state [pause bool])\n\ + (defn main [] i32 (let [s (state false)] (addr (get s :pause)) 0))" + ~needle:"addr takes the address of a place"; rejects_check "a class does not name a slot twice" "(defclass point [x x])\n(defn main [] i32 0)" ~needle:"names the slot x twice"; @@ -3710,7 +3727,10 @@ let () = into a lookup and no place form for one. Refused with that reason rather than as a milestone that will never arrive. *) rejects_check "a map entry as a place" - "(defn f [] () (set (get m 1) 2))" + "(defn f [m (Map i64 i64)] () (set (get m 1) 2))" + ~needle:"entries are written with (put m k v)"; + rejects_check "get with three arguments is not a place" + "(defn f [m dyn] () (set (get m 1 2) 2))" ~needle:"a map is written with (put m k v)"; (* ── restart-case and invoke-restart, §3 to §6 ─────────────────── *) diff --git a/test/test_session.ml b/test/test_session.ml index 78a3936d..758cb23f 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1384,6 +1384,20 @@ let () = (String.concat " " c.Session.fns) | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a class and its caller evaluated together: %s" m); + (* A slot's type changed and nothing else. Every constructor parameter is + dyn whatever the slot says, so the signature is the one it was and a + compiled caller is no reason to refuse — the type is checked where a + value is stored, at run time. What has to reach the program is the new + definition, and the registration carries it with the type after the + name, which is what makes the runtime see a change and migrate. *) + (let t, _ = Session.create ~file:"programs/dev-class.flan" () in + ignore (Session.eval t "(defn origin [] dyn (point 0 0))"); + match Session.eval t "(defclass point [x i64 y])" with + | c -> + if not (has c.Session.ir "c\"x i64\\0Ay\"") then + fail "a slot's new type did not reach the registration" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a slot's type changed under a compiled caller was refused: %s" m); (* ── What a slot is shown as ────────────────────────────────────────── [strip_rebind] takes only a trailing ~N — [~] is the reader's delimiter diff --git a/web/examples/classes.flan b/web/examples/classes.flan index b79f5b5f..d036b73c 100644 --- a/web/examples/classes.flan +++ b/web/examples/classes.flan @@ -1,5 +1,5 @@ -;; A class is a named dyn map with a shape tag. Its slots are names and -;; carry no types, and its constructor is the class's own name, positional. +;; A class is a named dyn map with a shape tag. A slot with no type holds +;; any value, and its constructor is the class's own name, positional. (defclass point [x y]) (defclass circle [r]) diff --git a/web/index.html b/web/index.html index 7584f36e..0805ca50 100644 --- a/web/index.html +++ b/web/index.html @@ -710,10 +710,16 @@ unit carries nothing for a dyn word to hold, and boxing it is refused — and

Classes and generic functions

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

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

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

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