From 5a62770e52e31d704fdc05c94ffa2ee3907a1e83 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 14:45:38 +0700 Subject: [PATCH 1/7] Classes and generic functions, milestone 2's last item MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A defclass is a named dyn map with a shape tag, and a generic function dispatches on it two ways: CLOS's, where the dispatch value is the class of the first argument, and Clojure's, where a body computes it. They are one mechanism and not two — a class dispatcher is (class-of arg0) as the dispatch function, which is what lets a method written for the class point and one written for the value :point be the same branch. (defclass point [x y]) (point 3 4) ; the constructor, positional (class-of p) ; :point, or nil for anything else (defgeneric area [self] dyn) (defmethod area point [p] (* (get p :x) (get p :y))) (defmulti describe [x] dyn (get x :kind)) (defmethod describe :square [s] ...) (defmethod describe :else [s] ...) A slot is a key in the instance's own map, so get, put and has-key? are how one is read and written and no operation was added for any of it. What the class adds is the tag, and the tag lives in the object's header rather than in a reserved entry — the queue's note said a reserved key and this departs from it, because a key would be counted by len, walked by the renderer and compared by equality, so every instance would answer a length one larger than its slot count and print a key nobody wrote. A header field cannot be reached by get or put at all, so no user key can collide with it. It costs nothing: the map arm of flan_obj's union grows to the size the view arm already had, and sizeof(flan_obj) is unchanged. It needs no tracing either — the tag is an interned keyword entry, which is immortal and is not a collector object. The tag shows up in exactly three places: class-of answers it, equality compares it (two instances of one class compare by their slots; an instance and a plain map with the same entries do not, which is Clojure's answer for a record beside a map), and both renderers print it — #point{ :x 1 :y 2}, Clojure's own spelling. None of the four forms reaches the checker. lib/classes.ml turns the whole declaration list into ordinary defns at the top of build_program, the way Shim.expand already turns a declare-c into a declare plus a defn: a class becomes its constructor, a generic becomes one function whose body binds the dispatch value and compares it down a chain, and a method becomes a branch of that chain. It is a pass and not a macro because a macro sees one form and the generic's body is not decidable until every method is in hand — a method may be written above its generic, below it, or arrive at a reload an hour later. That last case is why the method bodies are inlined rather than lifted. A generic is exactly one top-level name, so adding a method to a running program is the ordinary redefinition of one function, through the cell every call site already goes through. session.ml names the generic alongside the method's own declaration name for that reason. The cost, recorded rather than hidden: a method is not separately callable and is not a frame of its own. A dispatch that finds no method signals NoMethod, a prelude struct carrying the generic's name and the dispatch value that missed. A condition and not a trap, because a miss is something a program can be written to answer, and handler-case around the call is the shape. Its value field is dyn, the first condition here with one; the per-type descriptor an item-2 struct carries is what the collector reaches it by. No restart is established at the miss, which is BoundsError's decision taken for BoundsError's reason. Both backends, identically: the two new runtime entry points are declared in emit.ml and the x86 backend needs nothing, since a dyn call is a dyn call there. Deferred and written down in FIX.org: inheritance, multi-argument dispatch, :before/:after/:around, named-slot construction, unknown-slot checking, and computed dispatch values. --- bin/main.ml | 9 + lib/ast.ml | 94 ++++++++++- lib/check.ml | 66 +++++++- lib/classes.ml | 311 +++++++++++++++++++++++++++++++++++ lib/emit.ml | 2 + lib/load.ml | 69 +++++++- lib/parse.ml | 121 +++++++++++++- lib/prelude.ml | 22 +++ lib/session.ml | 16 +- runtime/flan_dyn.c | 83 +++++++++- runtime/flan_dyn.h | 18 ++ test/programs/dyn-class.flan | 120 ++++++++++++++ test/test_acceptance.ml | 29 ++++ test/test_flan.ml | 115 +++++++++++++ test/test_sanitize.ml | 8 + 15 files changed, 1067 insertions(+), 16 deletions(-) create mode 100644 lib/classes.ml create mode 100644 test/programs/dyn-class.flan diff --git a/bin/main.ml b/bin/main.ml index 639253f..f950233 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -92,6 +92,15 @@ let summarise (d : Flan.Ast.decl) = Printf.sprintf "declare-c %s (%d params) = %s" fn.name (List.length fn.params) csym | Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms) + | Defclass (n, slots) -> + Printf.sprintf "defclass %s (%d slots)" n (List.length slots) + | Defgeneric fn -> + Printf.sprintf "defgeneric %s (%d params)" fn.name (List.length fn.params) + | Defmulti fn -> + Printf.sprintf "defmulti %s (%d params)" fn.name (List.length fn.params) + | Defmethod m -> + Printf.sprintf "defmethod %s %s (%d body forms)" m.mgen + (dispatch_text m.mkey) (List.length m.mfn.fbody) | Defn fn -> Printf.sprintf "defn %s (%d params, %s return, %d body forms)" fn.name (List.length fn.params) diff --git a/lib/ast.ml b/lib/ast.ml index a6c3fae..222fb24 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -69,7 +69,13 @@ and expr_kind = (* {:a 1 :b s} — a dyn map literal. Braces whose first form is not a [.field] symbol are this; the struct spelling keeps the dot. Keys are ordinary expressions, keywords being the common case. *) - | MapLit of (expr * expr) list + (* The [string option] is a shape tag, and the parser never writes one: a + tagged map is what a (defclass ...) constructor builds, and + [Classes.expand] is the only thing that writes that constructor. The tag + is the class's name; the instance carries it in its object header, not as + an entry, so a tagged literal and an untagged one with the same pairs + differ in exactly one word and in nothing a [get] can see. *) + | MapLit of string option * (expr * expr) list | Arr of expr list (* [0xE6B800FF ...] — a fixed array value *) (* (array 4 rl/Vector2) — a zeroed fixed array, given its count and its element type. [n T] is the ordinary *type* syntax and already works @@ -208,6 +214,52 @@ and decl_kind = (* value is optional: ZII. `uninit` opts out and is recorded as Uninit. *) | Defvar of string * texpr option * init | 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] + 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. + + They are declarations here rather than a macro because the expansion + needs the *whole* declaration list in hand — a method may be written + 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 + (* (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. *) + | Defgeneric of fn + (* (defmulti describe [x] dyn (get x :kind)) — Clojure's: the body IS the + dispatch function, computing the value the methods are keyed by. Exactly + a [defn]'s shape, which is what it is. *) + | Defmulti of fn + (* (defmethod area point [p] body ...) — one method of a generic. [mgen] is + the generic's name, [mkey] the dispatch value it answers for, and [mfn] + carries the parameter vector and the body. There is no return slot: the + generic states the return type once, for all of its methods. *) + | Defmethod of methd + +(* A dispatch value, written at a [defmethod]. Only literals: the value is + compared at run time and the *name* the method is declared under is built + from it at compile time, so it has to be something both passes can read. *) +and dispatch = + (* [point] — a class's name, standing for the keyword its instances carry. + Refused unless a [defclass] of that name is in scope, which is the one + compile-time check a shape tag makes possible. *) + | Dclass of string + | Dkw of string (* :circle *) + | Dstr of string (* "circle" *) + | Dint of int64 + | Dbool of bool + (* [:else] — the method that answers when no other does. The spelling is + [match]'s, not Clojure's [:default], because this language already has + one word for "none of the above" and two would be one too many. *) + | Delse + +and methd = { mgen : string; mkey : dispatch; mfn : fn; mkloc : Loc.t } and variant = { vname : string; vfields : field list; vloc : Loc.t } @@ -225,11 +277,37 @@ and init = Zeroed | Uninit | Init of expr | Ambiguous of expr one top-level namespace, so this is both the set [Load] renames on an import and the set [Check] refuses to see twice — one definition, so the two cannot drift apart. *) +(* How a dispatch value reads back, in a message and in the name below. The + keyword keeps its colon and the string its quotes, so that a method written + for :circle and one written for "circle" — two different values — do not + read as the same thing in a duplicate-method refusal. *) +let dispatch_text = function + | Dclass n -> n + | Dkw k -> ":" ^ k + | Dstr s -> "\"" ^ s ^ "\"" + | Dint i -> Int64.to_string i + | Dbool b -> if b then "true" else "false" + | Delse -> ":else" + +(* The top-level name a [defmethod] declares. No function is ever emitted + under it — a method's body is inlined into its generic's dispatch, so the + only function the pass writes is the generic itself — but a declaration + still needs a name of its own, for the reason every declaration does: a + session replaces a declaration it has already seen by name, and appends one + it has not. Redefining a method has to replace, and adding one has to + append, and the pair (generic, dispatch value) is what tells those two + apart. The [@] is what keeps the name out of a program's reach: no symbol a + reader accepts contains one. *) +let method_name (m : methd) = m.mgen ^ "@" ^ dispatch_text m.mkey + let declared_name (d : decl) = match d.d with | Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defdata (n, _) - | Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _) -> Some n - | Declare (fn, _) | DeclareC (fn, _) | Defn fn -> Some fn.name + | Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _) + | Defclass (n, _) -> Some n + | Declare (fn, _) | DeclareC (fn, _) | Defn fn + | Defgeneric fn | Defmulti fn -> Some fn.name + | Defmethod m -> Some (method_name m) | Package _ | Import _ -> None (* ── Instrumenting a form with (pause) ─────────────────────────────── *) @@ -279,7 +357,7 @@ let map_children f (e : expr) : expr = | Call (fn, args) -> Call (ex fn, List.map ex args) | Match (s, arms) -> Match (ex s, List.map arm arms) | Struct (n, fs) -> Struct (n, List.map (fun (n, v) -> (n, ex v)) fs) - | MapLit kvs -> MapLit (List.map (fun (k, v) -> (ex k, ex v)) kvs) + | MapLit (tag, kvs) -> MapLit (tag, List.map (fun (k, v) -> (ex k, ex v)) kvs) | Arr es -> Arr (List.map ex es) | Fn (ps, es) -> Fn (ps, List.map ex es) | Dotimes (l, n, c, es) -> Dotimes (l, n, ex c, List.map ex es) @@ -331,6 +409,14 @@ let mark_pause ~line ~col (ds : decl list) : decl list option = hit := true; { d with d = Defn { f with fbody = pause_call d.dloc :: f.fbody } } | Defn f -> { d with d = Defn { f with fbody = body f.fbody } } + (* A method's body and a defmulti's dispatch body are code someone wrote + and can stop inside, so both are walked. Marking the whole declaration + — the [at d.dloc] case above — is deliberately not offered for either: + a method is not a function of its own by the time it runs, so there is + no entry to stop at, only the forms inside it. *) + | Defmethod m -> + { d with d = Defmethod { m with mfn = { m.mfn with fbody = body m.mfn.fbody } } } + | Defmulti f -> { d with d = Defmulti { f with fbody = body f.fbody } } | Defvar (n, t, Init e) -> { d with d = Defvar (n, t, Init (walk e)) } (* The value reading of an undecided [defvar] is walked too: if it is the one that wins it is an initialiser like any other, and if the type diff --git a/lib/check.ml b/lib/check.ml index f238763..179bb35 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2417,7 +2417,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = like any other dyn value would. The literal lowers to a fresh slot — a rooted one, because a slot of type dyn is what [dyn_roots] counts — so the map stays reachable across the allocations its own entries make. *) - | Ast.MapLit kvs -> + | Ast.MapLit (tag, kvs) -> let m = fresh_slot ctx Types.Dyn in let mval = mk loc Types.Dyn (Tast.Local m) in let sets = @@ -2428,10 +2428,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = check ctx ~want:Types.Dyn v ]) kvs in + (* A shape tag, if this is the literal a class's constructor was written + from. It is the class's name interned as a keyword, and it goes into + the object's header rather than into the entries — so everything below + this line, the rooting included, is the untagged case unchanged. *) + let empty = + match tag with + | None -> rt loc Types.Dyn "flan_dyn_map_new" [] + | Some cls -> + rt loc Types.Dyn "flan_dyn_map_new_class" + [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ] ] + in expect ctx loc ~want - (mk loc Types.Dyn - (Tast.Let ([ (m, rt loc Types.Dyn "flan_dyn_map_new" []) ], - sets @ [ mval ]))) + (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) | Ast.Quote _ -> unimplemented loc "a quoted symbol (restart names)" 6 | Ast.Var name -> var ctx loc ~want name @@ -5439,6 +5448,25 @@ and named_call ctx ~want loc name args = (Types.to_string other)) | _ -> assert false) + (* (class-of v) -> the class's name as a keyword, or nil. It is the dyn + side's one question about shape, and the dispatch a (defgeneric ...) + compiles to is this call and a comparison — so what a class dispatcher + is, exactly, is the shape tag of the first argument as the dispatch + function, which is what makes the CLOS half and the Clojure half one + mechanism rather than two. + + Anything that is not an instance answers nil rather than trapping: an + ordinary map, a number, nil itself. Asking is not a claim, and the + question is askable of every value — the same line [get] takes about an + absent key. *) + | "class-of" -> + arity loc name 1 args; + (match args with + | [ v ] -> + expect ctx loc ~want + (rt loc Types.Dyn "flan_dyn_class_of" [ check ctx ~want:Types.Dyn v ]) + | _ -> assert false) + (* (map-remove m k) -> (Option V): the value that was there, or None when the key was not. The same answer [get] gives, for the same reason — a key that is not in the map is an answer and not a failure — and the value @@ -6779,6 +6807,12 @@ let builtins : (string * string * string) list = wants, where get would hand back an Option to match on. Over a dyn map \ it is the question that stays askable when nil might also be stored \ under the key."); + ("class-of", "class-of [dyn] dyn", + "The class's name as a keyword for a value built by a defclass \ + constructor, and nil for everything else — an ordinary map included. \ + It is what a defgeneric dispatches on, so a class dispatcher is this \ + call over the first argument and a defmulti whose body is (class-of x) \ + is the same generic function written the other way."); ("keyword", "keyword [string|[u8]] dyn", "The interned dyn keyword named by the bytes, for a name that only \ exists at run time — a reader building :texture-path out of a token's \ @@ -7229,7 +7263,21 @@ let collect env (decls : Ast.decl list) = Hashtbl.replace env.globals n (ty, false) | Ast.Defconst (n, Some t, _) -> Hashtbl.replace env.globals n (resolve env t, true) - | Ast.Defconst (n, None, v) -> untyped := (n, v) :: !untyped) + | Ast.Defconst (n, None, v) -> untyped := (n, v) :: !untyped + (* [Classes.expand] ran at the top of [build_program] and left none of + these behind, the way [Shim.expand] leaves no [declare-c] behind. A + 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.Defmulti { Ast.name = n; _ } -> + fail loc + "internal: %s reached the checker unexpanded — Classes.expand did \ + not run over this declaration list" n + | Ast.Defmethod m -> + fail loc + "internal: a method of %s reached the checker unexpanded — \ + Classes.expand did not run over this declaration list" m.Ast.mgen) decls; (* Also to a fixpoint, and for the same reason: one untyped constant may be defined in terms of another declared after it. A constant that still does @@ -8421,6 +8469,11 @@ let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env = flattening comes back to be compiled into the build. Nothing below this line knows the form exists. *) let decls, cshim = Shim.expand decls in + (* And on the same line: every class and generic function becomes the + [defn]s it stands for. It runs over the whole list because a method may + be written anywhere in it, which is also what makes a reload rebuild + every dispatch from the session's declarations — see lib/classes.ml. *) + let decls = Classes.expand decls in (* Pass one, and it stops at the first thing it refuses. That is not laziness: every name, type and signature in the file comes from here, so a declaration this pass could not make sense of leaves a hole that pass two @@ -8791,6 +8844,9 @@ let memory_class (sym : string) (args : Tast.expr list) = gc "allocates: a dyn vector is an object on the collector's heap" | "flan_dyn_map_new" -> gc "allocates: a dyn map is an object on the collector's heap" + | "flan_dyn_map_new_class" -> + gc "allocates: a class instance is a dyn map on the collector's heap, \ + with the class's name in its header" | "flan_dyn_view_vec" | "flan_dyn_view_flat" -> gc "allocates: a typed container crossing into dyn takes a view record \ on the collector's heap — the elements are not copied, the record is" diff --git a/lib/classes.ml b/lib/classes.ml new file mode 100644 index 0000000..bdf905d --- /dev/null +++ b/lib/classes.ml @@ -0,0 +1,311 @@ +(** The dyn side's classes and generic functions, turned into ordinary + declarations. + + [(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. + + **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 + its generic, below it, or at a reload an hour later — and the generic's + body is not decidable until every method is in hand. The pass runs at the + top of [Check.build_program], over the flat list an import has already + been folded into, so a reload rebuilds every dispatch from the session's + whole set of declarations and a method added to a running program is the + ordinary redefinition of the one function that dispatches. [Shim.expand] + is the precedent, form for form. + + **Why the method bodies are inlined rather than lifted into functions of + their own.** A generic is then exactly one top-level name, which is what + makes adding a method at a reload work: the session installs the bodies + the evaluated form declared, one name each, and a new method has to reach + a call site that was compiled before it existed. One function means one + cell to replace. The cost is that a method is not separately callable and + does not appear as a frame of its own, which is recorded in FIX.org. + + **What it does not do.** There is no inheritance, no multi-argument + dispatch, and no :before/:after/:around — see FIX.org, 2026-09-20, for + which of those were deferred and why. A method's dispatch value is a + literal, so the specificity question CLOS answers with a class precedence + list does not arise here: two methods either answer for the same value, + which is refused, or for different ones. *) + +let dyn_at loc : Ast.texpr = { Ast.t = Ast.Tname "dyn"; tloc = loc } + +let ex loc (e : Ast.expr_kind) : Ast.expr = { Ast.e; loc } + +(* The name the dispatch value is bound to inside a generic's body. [~] is a + delimiter in the reader, so no symbol anyone can write is this one and no + method body can shadow it or be shadowed by it. *) +let dispatch_slot = "~dispatch" + +(* The condition a generic signals when no method answers. Its struct is in + the prelude; this is the only place that builds one. *) +let no_method = "NoMethod" + +(* ── Collecting ────────────────────────────────────────────────────── *) + +type generic = { + gkind : [ `Class | `Multi ]; + gfn : Ast.fn; + gloc : Loc.t; + (* In source order, which is dispatch order: the first method whose value + matches answers, and since duplicates are refused the order is not + observable except for [:else], which is moved to the end regardless. *) + mutable gms : Ast.methd list; +} + +let collect (decls : Ast.decl list) = + let classes : (string, Loc.t) Hashtbl.t = Hashtbl.create 8 in + let generics : (string, generic) Hashtbl.t = Hashtbl.create 8 in + 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.Defgeneric fn -> + Hashtbl.replace generics fn.Ast.name + { gkind = `Class; gfn = fn; gloc = d.Ast.dloc; gms = [] } + | Ast.Defmulti fn -> + Hashtbl.replace generics fn.Ast.name + { gkind = `Multi; gfn = fn; gloc = d.Ast.dloc; gms = [] } + | _ -> ()) + decls; + (* Methods second, so a method may be written above the generic it extends + — which it has to be able to be, since a reload appends. *) + List.iter + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defmethod m -> + let g = + match Hashtbl.find_opt generics m.Ast.mgen with + | Some g -> g + | None -> + Loc.failk "check/unknown-generic" d.Ast.dloc + "no defgeneric or defmulti names %s, so there is nothing for \ + this method to be a method of. A generic function is \ + declared once, with its parameters and its return type, and \ + the methods are written against it" + m.Ast.mgen + in + (match m.Ast.mkey with + | Ast.Dclass c when not (Hashtbl.mem classes c) -> + Loc.failk "check/unknown-class" m.Ast.mkloc + "no defclass names %s. A bare name in a method's dispatch slot \ + is a class, and stands for the shape tag its instances carry; \ + a dispatch value that is not a class is written as itself — a \ + keyword, a string, an integer" + c + | _ -> ()); + let n = List.length m.Ast.mfn.Ast.params + and want = List.length g.gfn.Ast.params in + if n <> want then + Loc.failk "check/method-arity" d.Ast.dloc + "%s takes %d argument%s and this method of it takes %d. Every \ + method of a generic function has the generic's own parameter \ + list: one call site reaches all of them, and it can only pass \ + one number of arguments" + m.Ast.mgen want (if want = 1 then "" else "s") n; + List.iter + (fun (prev : Ast.methd) -> + if prev.Ast.mkey = m.Ast.mkey then + Loc.failk "check/duplicate-method" d.Ast.dloc + "%s already has a method for %s. Two methods for one \ + dispatch value is an ambiguity nothing resolves — there \ + is no specificity rule here, because a dispatch value is \ + a value and not a type" + m.Ast.mgen (Ast.dispatch_text m.Ast.mkey)) + g.gms; + g.gms <- g.gms @ [ m ] + | _ -> ()) + decls; + (classes, generics) + +(* ── Writing the declarations ──────────────────────────────────────── *) + +(* [(defclass point [x y])] becomes + + (defn point [x dyn y dyn] dyn #point{:x x :y y}) + + — the constructor, positional, one argument per slot in the order the + slots were written. The slots are keys in an ordinary dyn map, so [get], + [put] and [has-key?] are how one is read and written and no new operation + is needed for any of it. What the class adds is the tag on the map, which + is what [class-of] answers and what a generic dispatches on. + + Named-slot construction — the dyn twin of [(Cursor {.src s})], with an + omitted slot meaning nil — is deferred, and so is refusing an unknown slot + at [(get p :z)]. Both are recorded in FIX.org. *) +let constructor n slots loc : Ast.decl = + let params = + List.map + (fun (s, sloc) -> { Ast.fname = s; fty = dyn_at sloc; floc = sloc }) + slots + in + let pairs = + List.map (fun (s, sloc) -> (ex sloc (Ast.Kw s), ex sloc (Ast.Var s))) slots + in + { Ast.d = + Ast.Defn + { Ast.name = n; params; praw = None; ret = Some (dyn_at loc); + fwhere = []; fbody = [ ex loc (Ast.MapLit (Some n, pairs)) ]; + nloc = loc }; + dloc = loc } + +(* The dispatch value a method answers for, as an expression to compare + against. A class's name stands for the keyword its instances carry, which + is the whole of how the CLOS half and the Clojure half share one + mechanism: [(defgeneric area [self] dyn)] is [(defmulti area [self] dyn + (class-of self))], and a method written for the class [point] is a method + written for the value [:point]. *) +let key_expr loc (k : Ast.dispatch) : Ast.expr = + match k with + | Ast.Dclass c -> ex loc (Ast.Kw c) + | Ast.Dkw k -> ex loc (Ast.Kw k) + | Ast.Dstr s -> ex loc (Ast.Str s) + | Ast.Dint i -> ex loc (Ast.Int i) + | Ast.Dbool b -> ex loc (Ast.Var (if b then "true" else "false")) + | Ast.Delse -> assert false (* never compared: it is the else arm *) + +(* A method's body, with the method's own parameter names bound to the + generic's. The names are the method's to choose — [(defmethod area point [p] + ...)] under [(defgeneric area [self] dyn)] — and a name that already agrees + binds nothing, so the common case adds no [let] at all. *) +let method_body (g : generic) (m : Ast.methd) : Ast.expr = + let loc = m.Ast.mfn.Ast.nloc in + let bs = + List.filter_map + (fun ((mp : Ast.field), (gp : Ast.field)) -> + if String.equal mp.Ast.fname gp.Ast.fname then None + else + Some { Ast.bname = mp.Ast.fname; bty = None; + bval = ex mp.Ast.floc (Ast.Var gp.Ast.fname); + bloc = mp.Ast.floc }) + (List.combine m.Ast.mfn.Ast.params g.gfn.Ast.params) + in + if bs = [] then ex loc (Ast.Do m.Ast.mfn.Ast.fbody) + else ex loc (Ast.Let (bs, m.Ast.mfn.Ast.fbody)) + +(* What a generic answers when no method does. Common Lisp signals here and + so does this: it is a condition with a handler-case around it, not a trap, + because a dispatch that missed is a thing a program can be written to + answer — a default, a log line, a fallback object — and a trap would take + that away. [error] rather than [signal] because there is no value to carry + on with if nothing handles it. + + No restart is established at the miss. That is BoundsError's and + ArithError's decision, taken here for their reason: a restart frame is + allocated by the form that offers it, and the ones that matter — a frame + loop's [continue] — are already on the stack and reachable from a handler + without this form pushing anything. *) +let miss loc gname : Ast.expr = + ex loc + (Ast.Signal + (Ast.Serror, + ex loc + (Ast.Struct + (no_method, + [ ("generic", ex loc (Ast.Str gname)); + ("value", ex loc (Ast.Var dispatch_slot)) ])))) + +let dispatcher (g : generic) : Ast.decl = + let loc = g.gloc in + let gname = g.gfn.Ast.name in + (* The value the methods are keyed by. A defgeneric computes it — the shape + tag of the first argument — and a defmulti's own body is it. *) + let value = + match g.gkind with + | `Multi -> ex loc (Ast.Do g.gfn.Ast.fbody) + | `Class -> + (match g.gfn.Ast.params with + | p :: _ -> + ex loc + (Ast.Call (ex loc (Ast.Var "class-of"), + [ ex p.Ast.floc (Ast.Var p.Ast.fname) ])) + | [] -> + Loc.failk "check/method-arity" loc + "%s takes no arguments, and a defgeneric dispatches on the class \ + of its first one. Write a defmulti, whose body says what to \ + dispatch on" + gname) + in + (* [:else] last whatever order it was written in, because it is the arm + everything else falls through to and not a value to compare against. *) + let fallback, cases = + List.partition (fun (m : Ast.methd) -> m.Ast.mkey = Ast.Delse) g.gms + in + let last = + match fallback with + | m :: _ -> method_body g m + | [] -> miss loc gname + in + let chain = + List.fold_right + (fun (m : Ast.methd) rest -> + let kloc = m.Ast.mkloc in + ex kloc + (Ast.If + (ex kloc + (Ast.Call (ex kloc (Ast.Var "="), + [ ex kloc (Ast.Var dispatch_slot); + key_expr kloc m.Ast.mkey ])), + method_body g m, Some rest))) + cases last + in + { Ast.d = + Ast.Defn + { g.gfn with + Ast.fbody = + [ ex loc + (Ast.Let ([ { Ast.bname = dispatch_slot; bty = None; + bval = value; bloc = loc } ], + [ chain ])) ] }; + dloc = loc } + +(** Every [defclass], [defgeneric], [defmulti] and [defmethod] in the list, + replaced by the [defn]s they stand for. Everything else is untouched and + keeps its position: a constructor is written where its class was and a + dispatch where its generic was, so declaration order — which is emission + order for globals — does not move. *) +let expand (decls : Ast.decl list) : Ast.decl list = + let has = + List.exists + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defclass _ | Ast.Defgeneric _ | Ast.Defmulti _ + | Ast.Defmethod _ -> true + | _ -> false) + decls + in + if not has then decls + else begin + let _classes, generics = collect decls in + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defclass (n, slots) -> Some (constructor n slots d.Ast.dloc) + | Ast.Defgeneric fn | Ast.Defmulti fn -> + Some (dispatcher (Hashtbl.find generics fn.Ast.name)) + (* Gone: its body is inside its generic's dispatch. *) + | Ast.Defmethod _ -> None + | _ -> Some d) + decls + end diff --git a/lib/emit.ml b/lib/emit.ml index 3ba2f40..6f30937 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -3619,6 +3619,8 @@ 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_class_of(i64) declare i64 @flan_dyn_kw(ptr, i64) declare i64 @flan_dyn_map_get(i64, i64) declare void @flan_dyn_map_set(i64, i64, i64) diff --git a/lib/load.ml b/lib/load.ml index 3c8c7c8..9308fba 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -267,8 +267,11 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = Ast.Struct (name n, List.map (fun (k, v) -> (k, go v)) kvs) (* A dyn map literal has no name of its own to qualify; its keys and values are ordinary expressions and are walked like anything else. *) - | Ast.MapLit kvs -> - Ast.MapLit (List.map (fun (k, v) -> (go k, go v)) kvs) + | Ast.MapLit (tag, kvs) -> + (* The tag is a class's name and is already qualified: the only thing + that writes one is [Classes.expand], which runs over the flat list + after every import has been folded into it. *) + Ast.MapLit (tag, List.map (fun (k, v) -> (go k, go v)) kvs) | Ast.Arr items -> Ast.Arr (gos items) | Ast.ArrayOf t -> Ast.ArrayOf (rename_texpr owned alias t) | Ast.Fn (ps, body) -> @@ -358,6 +361,18 @@ let rename_pitem owned alias (p : Ast.pitem) : Ast.pitem = | Ast.Pname _ -> p | Ast.Ptype t -> Ast.Ptype (rename_texpr owned alias t) +(* A generic function's or a method's signature and body. Its parameters are + all [dyn] and were written out by the parser, so unlike a [defn]'s there is + no undecided vector to qualify and the names the body may shadow are simply + the parameter names. The declared name is qualified by the caller, which + for a method is not [fn.name] at all. *) +let qualify_dyn_fn owned alias (fn : Ast.fn) : Ast.fn = + let bound = List.map (fun (p : Ast.field) -> p.Ast.fname) fn.Ast.params in + { fn with + Ast.name = qualify alias fn.Ast.name; + ret = Option.map (rename_texpr owned alias) fn.Ast.ret; + fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody } + let qualify_decl owned alias (d : Ast.decl) : Ast.decl = let loc = d.Ast.dloc in let k = @@ -432,6 +447,41 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = params; praw; ret = Option.map (rename_texpr owned alias) fn.Ast.ret; fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody } + (* ── The class forms ────────────────────────────────────────────── + [Classes.expand] has not run — it runs over the whole flat list, after + every import has been folded into it — so these arrive here as written + 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 + 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) + (* 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. *) + | Ast.Defgeneric fn -> Ast.Defgeneric (qualify_dyn_fn owned alias fn) + | Ast.Defmulti fn -> Ast.Defmulti (qualify_dyn_fn owned alias fn) + (* Both halves of the head are names this package owns or does not: the + generic being extended, and — when the dispatch value is a class — the + class being dispatched on. A method written in one package for another + package's generic therefore keeps working, because [owned] answers no + for that name and the alias-qualified spelling the source wrote is left + alone by [rename_expr]'s rule. *) + | Ast.Defmethod m -> + let mkey = + match m.Ast.mkey with + | Ast.Dclass c when List.mem c owned -> Ast.Dclass (qualify alias c) + | k -> k + in + let mgen = if List.mem m.Ast.mgen owned then qualify alias m.Ast.mgen + else m.Ast.mgen in + let mfn = qualify_dyn_fn owned alias m.Ast.mfn in + Ast.Defmethod + { m with Ast.mgen; mkey; + mfn = { mfn with Ast.name = mgen ^ "@" ^ Ast.dispatch_text mkey } } | Ast.Package _ -> Ast.Package alias (* A package's own imports were resolved before this ran and are not in the list it is given, so one arriving here is a bug in [import] rather @@ -681,7 +731,7 @@ let rec expr_uses acc (e : Ast.expr) = | Ast.Struct (n, kvs) -> acc := (n, e.Ast.loc) :: !acc; List.iter (fun (_, v) -> go v) kvs - | Ast.MapLit kvs -> List.iter (fun (k, v) -> go k; go v) kvs + | Ast.MapLit (_, kvs) -> List.iter (fun (k, v) -> go k; go v) kvs | Ast.Arr items -> gos items | Ast.ArrayOf t -> texpr_uses acc t | Ast.Fn (_, body) -> gos body @@ -755,6 +805,19 @@ 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 _ -> () + | 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 + same reason a type in a signature is. *) + | Ast.Defmethod m -> + acc := (m.Ast.mgen, d.Ast.dloc) :: !acc; + (match m.Ast.mkey with + | Ast.Dclass c -> acc := (c, m.Ast.mkloc) :: !acc + | _ -> ()); + fn m.Ast.mfn let uses (ds : Ast.decl list) = let acc = ref [] in diff --git a/lib/parse.ml b/lib/parse.ml index 3210cf6..6a5ac37 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -140,6 +140,52 @@ and pitems (items : Form.t list) : Ast.pitem list = | _ -> Ast.Ptype (texpr it)) items +(* A generic's or a method's parameter vector. Every slot is a bare name and + every parameter is [dyn], so the types are written out here rather than + left for [Check.pair_params] to decide: the pairing exists because a + [defn]'s vector is ambiguous until every type name is known, and this one + never is. A parameter named after a type is therefore fine here, where in a + [defn] it would be refused. *) +and dyn_params which (items : Form.t list) : Ast.field list = + List.map + (fun (it : Form.t) -> + match it.v with + | Sym s -> + { Ast.fname = s; + fty = { Ast.t = Ast.Tname "dyn"; tloc = it.loc }; + floc = it.loc } + | _ -> + fail it + "a %s's parameter is a bare name, and found %s. Every parameter of \ + a generic function is dyn — there is no type to write, and a \ + method that wanted one could not be reached by a dispatch that \ + does not know types either" + which (Form.to_string it)) + items + +(* A [defmethod]'s dispatch value. Literals only: the value is compared + against what the dispatch answered at run time, and the method is declared + under a name built from it at compile time, so it has to be something both + passes can read off the source. A computed one — Clojure allows any value a + method is registered under, because registration there is a run-time call — + is not available and the message says so. *) +and dispatch (f : Form.t) : Ast.dispatch = + match f.v with + | Kw "else" -> Ast.Delse + | Sym "true" -> Ast.Dbool true + | Sym "false" -> Ast.Dbool false + | Sym s -> Ast.Dclass s + | Kw k -> Ast.Dkw k + | Str s -> Ast.Dstr s + | Int i -> Ast.Dint i + | _ -> + fail f + "a method's dispatch value is a class's name, a keyword, a string, an \ + integer, true, false, or :else for the one that answers when no other \ + does — and found %s. It is matched at compile time as well as at run \ + time, so it is written out rather than computed" + (Form.to_string f) + (* ── The constraint map at the head of a defn body ────────────────────── [(defn sort [s [$t]] () {:where (ordered? $t)} body ...)]. Clojure's [{:pre [...] :post [...]}] is the precedent and the reason it is a map @@ -274,7 +320,7 @@ let rec expr (f : Form.t) : Ast.expr = | Map ({ v = Sym s; _ } :: _) when String.length s > 1 && s.[0] = '.' -> fail f "a bare map is not an expression; write (Type {.field v})" - | Map items -> mk (Ast.MapLit (map_pairs f items)) + | Map items -> mk (Ast.MapLit (None, map_pairs f items)) | List [] -> fail f "() is not an expression" | List (head :: args) -> form f mk head args @@ -567,7 +613,7 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = output rather than a dependency. Building a declaration as a value is what a macro is for. *) | Sym ("defmacro" | "defn" | "defvar" | "defconst" | "defstruct" | "defdata" - | "defunion" + | "defunion" | "defclass" | "defgeneric" | "defmulti" | "defmethod" | "defenum" | "defalias" | "import" as name) -> fail f "%s is a top-level declaration, not an expression. A quasiquoted one is \ @@ -1215,6 +1261,77 @@ let rec decl (f : Form.t) : Ast.decl = "defn is (defn name [param Type ...] ReturnType body ...). The return \ type is not optional; a function that returns nothing writes ()") + (* ── The dyn side's classes and generic functions ────────────────── + Four forms, all of them shorthand: nothing below [Classes.expand] knows + they exist, and what it writes in their place is ordinary [defn]s. The + parsing here is only the shape check — which slots are present, and what + kind of thing is in each — because everything that needs the other + declarations to answer (is that a class? is there a generic by that + name? has this dispatch value a method already?) is the expansion's. + + Every parameter of a generic and of a method is [dyn], written or not, + so a parameter vector here takes bare names and nothing else. That is + what keeps these off [defn]'s undecided-pairing path: a [defn]'s vector + cannot be read until every type name is known, and one that may hold + only names can be read here. *) + | List ({ v = Sym "defclass"; _ } :: args) -> + (match args with + | [ n; { v = Vec slots; _ } ] -> + mk (Ast.Defclass + (sym n, + List.map + (fun (s : Form.t) -> + match s.v with + | Sym name -> (name, s.loc) + | _ -> + fail s + "a class slot is a name. Its value is dyn and there is \ + no type to write: an instance is a dyn map with a \ + shape tag on it, and (get p :%s) is how a slot is read" + (Form.to_string s)) + slots)) + | _ -> fail f "defclass is (defclass Name [slot ...])") + + | List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) -> + let generic = String.equal which "defgeneric" in + let usage = + if generic then + "defgeneric is (defgeneric name [param ...] ReturnType). It has no \ + body: its dispatch value is the class of its first argument, which \ + is what makes it the class-dispatching half of the pair. Write \ + defmulti for a dispatch value of your own" + else + "defmulti is (defmulti name [param ...] ReturnType body ...), and the \ + body is the dispatch: it answers the value the methods are keyed by" + in + (match args with + | n :: { v = Vec ps; _ } :: ret :: body + when if generic then body = [] else body <> [] -> + mk ((if generic then (fun fn -> Ast.Defgeneric fn) + else fun fn -> Ast.Defmulti fn) + { Ast.name = sym n; params = dyn_params which ps; praw = None; + ret = Some (texpr ret); fwhere = []; fbody = body_of body; + nloc = n.loc }) + | _ -> fail f "%s" usage) + + | List ({ v = Sym "defmethod"; _ } :: args) -> + (match args with + | n :: key :: { v = Vec ps; _ } :: body when body <> [] -> + let gen = sym n and k = dispatch key in + mk (Ast.Defmethod + { Ast.mgen = gen; mkey = k; mkloc = key.loc; + (* The name is the declaration's, not a symbol anything emits: + no function is ever written under it. *) + mfn = { Ast.name = gen ^ "@" ^ Ast.dispatch_text k; + params = dyn_params "defmethod" ps; praw = None; + ret = None; fwhere = []; fbody = body_of body; + nloc = n.loc } }) + | _ -> + fail f + "defmethod is (defmethod generic dispatch [param ...] body ...). \ + There is no return type: the generic states it once, for every \ + method written for it") + | List ({ v = Sym ("declare" | "declare-c" as which); _ } :: args) -> (* (declare name [param Type ...] ReturnType? "c_symbol"). The C symbol is last and is always written: a foreign name is not derivable from a Flan diff --git a/lib/prelude.ml b/lib/prelude.ml index 847109c..b015fd9 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -148,6 +148,28 @@ let source = {flan| ;; pushed here. (defstruct ArithError [op i32 lhs i64 rhs i64]) +;; What a generic function signals when no method answers. `generic` is the +;; name written at the defgeneric or defmulti, and `value` is what the +;; dispatch actually produced -- the class of the first argument for a +;; defgeneric, whatever the body answered for a defmulti. A miss is nil for +;; the common case of a value that is not an instance at all. +;; +;; A condition and not a trap, and that is the decision rather than the +;; obvious default: Common Lisp signals here, and a dispatch that missed is +;; something a program can be written to answer -- a default object, a log +;; line, a fallback -- which a trap would take away. `handler-case` around +;; the call is the shape, and a method written for `:else` is the other +;; answer, in the generic rather than at the call. +;; +;; `value` is dyn, which is the one field type no other condition here has. +;; It is the honest one: a dispatch value is whatever the dispatch answered +;; and there is no narrower type it has. The collector reaches it through the +;; per-type descriptor a struct with a dyn field carries. +;; +;; No restart is established at the miss, which is BoundsError's decision +;; taken for BoundsError's reason -- see the note above it. +(defstruct NoMethod [generic string value dyn]) + ;; A breakpoint. (pause) stops the program where it stands and hands it to the ;; break loop, with the whole stack under it readable — C-c C-b lists the ;; frames, TAB opens one, and taking `continue` resumes at the call. diff --git a/lib/session.ml b/lib/session.ml index a724f25..49daeb5 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -586,7 +586,21 @@ let eval ?(origin = "") ?pause t src : change = fail loc "nothing to pause at line %d, column %d of the form sent" line col) in - let names = List.filter_map Ast.declared_name incoming in + (* A method declares a name of its own — that is what makes evaluating one + twice a replacement and evaluating a new one an append, through the same + kept/added logic every other declaration goes through. But no function is + emitted under that name: a method's body is inlined into its generic's + dispatch by [Classes.expand], so the body that has to be installed is the + *generic's*. Naming it here is what makes [C-c C-c] on a defmethod reach + a call site compiled before the method existed, which is the whole of why + this feature is usable in the loop the project exists for. *) + let names = + List.filter_map Ast.declared_name incoming + @ List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None) + incoming + in let replacement n = List.find_opt (fun (d : Ast.decl) -> Ast.declared_name d = Some n) diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 34afd76..8169146 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -220,6 +220,11 @@ typedef struct flan_dyn_alloc_hdr { uint64_t epoch; } flan_dyn_alloc_hdr; +/* A keyword's interned entry, declared here because a map's shape tag is one. + * The definition, the table and the argument for interning are further down, + * under "Keywords". */ +struct kw_entry; + typedef struct flan_obj { struct flan_obj *next; /* every object ever allocated, newest first */ uint8_t kind; @@ -228,7 +233,26 @@ typedef struct flan_obj { of a map */ union { int64_t i; /* OBJ_INT */ - struct { flan_dyn *items; int64_t cap; } v; /* OBJ_VEC and OBJ_MAP — + struct { flan_dyn *items; int64_t cap; + /* OBJ_MAP only, and NULL for every map that is not a defclass + instance: the shape tag. It is the interned entry of the + class's name — :point for (defclass point [x y]) — so the + identity compare that makes keyword equality cheap is also + what makes a class check cheap, and the tag needs no marking + because an interned entry is immortal and is not a GC object + (see [mark_value], which follows BOX_OBJ and nothing else). + + It lives in the header rather than in a reserved entry of the + map itself, which is the one place this departs from the + queue's note: an entry would be counted by [len], walked by + [render], and compared by [dyn_equal]'s key loop, so every + instance would answer a length one larger than its slot count + and print a key nobody wrote. A field cannot be reached by + [get] or [put] at all, so no user key can collide with it. + + A vec leaves it NULL. The arm is shared, so the field exists + for both kinds; nothing reads it for an OBJ_VEC. */ + struct kw_entry *klass; } v; /* OBJ_VEC and OBJ_MAP — a map shares the vec's arm on purpose: its entries are the same malloc block of dyn words, interleaved key then value, with [len] counting entries and [cap] counting entries too. Sharing the arm is what lets the @@ -555,6 +579,13 @@ static void render(flan_dyn v, int depth, int nested) { case FLAN_DYN_TAG_MAP: { flan_obj *o = dyn_obj(v); int64_t i; + /* A class instance prints its shape tag in front, Clojure's own spelling + * for a record: #point{ :x 1 :y 2}. The tag is not an entry, so it is + * written here or it is not written at all. */ + if (o->u.v.klass != NULL) { + emit("#"); + emit_n(kw_bytes(o->u.v.klass), o->u.v.klass->len); + } emit("{"); for (i = 0; i < o->len; i++) { emit(" "); @@ -651,6 +682,19 @@ static void say_render(sayer *s, flan_dyn v, int depth) { flan_obj *o = dyn_obj(v); int64_t i; if (depth >= 2) { say_puts(s, "{...}"); return; } + /* The same tag [render] writes, so a trap sentence naming an instance + * says which class it was. Truncated with the rest when the buffer is + * short: [say] is a 96-byte sentence, not a printer. */ + if (o->u.v.klass != NULL && s->n < s->cap - 8) { + int64_t j; + say_puts(s, "#"); + for (j = 0; j < o->u.v.klass->len && s->n < s->cap - 8; j++) { + char c[2]; + c[0] = (char)kw_bytes(o->u.v.klass)[j]; + c[1] = '\0'; + say_puts(s, c); + } + } say_puts(s, "{"); for (i = 0; i < o->len && s->n < s->cap - 8; i++) { say_puts(s, " "); @@ -1015,6 +1059,9 @@ flan_dyn flan_dyn_vec_new(void) { o->len = 0; o->u.v.items = NULL; o->u.v.cap = 0; + /* Shared arm, and nothing reads this for a vec; written anyway so that the + field's value is never whatever [gc_alloc] happened to leave. */ + o->u.v.klass = NULL; return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } @@ -1023,9 +1070,37 @@ flan_dyn flan_dyn_map_new(void) { o->len = 0; o->u.v.items = NULL; o->u.v.cap = 0; + o->u.v.klass = NULL; return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)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) { + flan_obj *o; + if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) + trap1(TYPE_TRAP, "class instance", "a class tag is a keyword", k); + o = gc_alloc(OBJ_MAP, 0); + o->len = 0; + o->u.v.items = NULL; + o->u.v.cap = 0; + o->u.v.klass = dyn_kw(k); + return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); +} + +/* The shape tag, as a value: the class's name as a keyword, or nil. Never + * traps. Absence is an answer here for the reason it is one in [map_get] — + * asking what class a value is, is a question every value can be asked, and + * an ordinary map, a number and nil all truthfully answer "none". */ +flan_dyn flan_dyn_class_of(flan_dyn v) { + flan_obj *o; + if (flan_dyn_tag(v) != FLAN_DYN_TAG_MAP) return flan_dyn_nil(); + o = dyn_obj(v); + if (o->u.v.klass == NULL) return flan_dyn_nil(); + return dyn_make(BOX_KW, (uint64_t)(uintptr_t)o->u.v.klass); +} + /* ── Keywords ────────────────────────────────────────────────────────── * * One global table, append-only, never freed: a keyword is a *name*, the set @@ -1483,6 +1558,12 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) { int64_t i, j; if (x == y) return 1; if (depth >= EQ_DEPTH) return 0; + /* The shape tag is part of the value. Two instances of one class compare + * by their entries as any two maps do; an instance and a plain map with + * the same entries do not, which is Clojure's answer for a record beside + * a map and is the only answer a tag can have if it means anything. An + * identity compare, because both sides are interned entries. */ + if (x->u.v.klass != y->u.v.klass) return 0; if (x->len != y->len) return 0; for (i = 0; i < x->len; i++) { flan_dyn k = x->u.v.items[i * 2]; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 2f95b6b..928e1e9 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -76,6 +76,24 @@ flan_dyn flan_dyn_from_bytes(const uint8_t *p, int64_t n); flan_dyn flan_dyn_vec_new(void); flan_dyn flan_dyn_map_new(void); +/* A map carrying a shape tag: what a (defclass point [x y]) constructor + * builds. [k] is the class's name as a keyword and anything else traps. + * + * The tag lives in the object's header and not in an entry of the map, so it + * is invisible to [get], [set], [contains] and [len] — an instance's length + * is its slot count and no key a program can write collides with it. What can + * see it is [flan_dyn_class_of], [flan_dyn_eq] (two values of different + * classes are unequal, and an instance is never equal to a plain map) and + * [flan_dyn_print] (an instance renders as #point{ :x 1 :y 2}). + * + * 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); + +/* 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 keyword: :foo as a run-time value. Interned — the runtime keeps one entry * per distinct name forever, so two keywords with the same bytes are the same * word and equality is an identity compare, never a memcmp. The entries are diff --git a/test/programs/dyn-class.flan b/test/programs/dyn-class.flan new file mode 100644 index 0000000..06a9543 --- /dev/null +++ b/test/programs/dyn-class.flan @@ -0,0 +1,120 @@ +;;;; Classes and generic functions, the dyn side's two dispatch styles. +;;;; +;;;; A defclass is a named dyn map with a shape tag. The constructor is the +;;;; class's own name, positional over the slots; the slots are ordinary map +;;;; keys, so get and put are how one is read and written and nothing new was +;;;; needed for either. What the class adds is the tag, which lives in the +;;;; object's header and not in the entries: (len p) is the slot count, no key +;;;; a program can write collides with it, and it shows up in exactly three +;;;; places -- class-of, equality, and the printed form #point{ :x 1 :y 2}. +;;;; +;;;; The two dispatch styles are one mechanism. A defgeneric dispatches on the +;;;; class of its first argument, which is Common Lisp's; a defmulti's body IS +;;;; the dispatch, which is Clojure's. A class dispatcher is the shape tag of +;;;; the first argument as the dispatch function, so the second spells the +;;;; first, and a method is a branch either way. + +(defclass point [x y]) +(defclass circle [r]) + +;; CLOS's half: dispatch on the class of the first argument. The generic +;; declares the parameters and the return type once; a method states neither. +(defgeneric area [self] dyn) + +(defmethod area point [p] (* (get p :x) (get p :y))) +;; A method may name its parameter whatever it likes -- the generic's name is +;; bound to it on the way in. +(defmethod area circle [c] (* 3 (* (get c :r) (get c :r)))) + +;; Clojure's half: the dispatch is a body, over the same parameter list every +;; method has, answering the value the methods are keyed by. +(defmulti describe [thing] dyn (get thing :kind)) + +(defmethod describe :square [s] (get s :side)) +(defmethod describe "round" [s] "a round thing, keyed by a string") +(defmethod describe 7 [s] "the one keyed by a number") +;; The method that answers when no other does. It is :else, which is the word +;; match already uses, and it is the last arm whatever order it is written in. +(defmethod describe :else [s] "something else") + +;; A generic with no :else: a miss signals, and the program answers it. +(defgeneric name-of [self] dyn) +(defmethod name-of point [p] "a point") + +(defn main [] i32 + (let [p (point 3 4) + c (circle 2)] + ;; The instance is a map, and prints as one with its tag in front. + (println p) + (println (len p)) + (println (get p :x)) + (put p :x 10) + (println (get p :x)) + (println (has-key? p :x)) + (println (has-key? p :nothing)) + (println (get p :nothing)) + + ;; The shape tag, as a value. Every value can be asked; only an instance + ;; answers with a name. + (println (class-of p)) + (println (class-of c)) + (println (class-of {:x 3 :y 4})) + (println (class-of 1)) + (println (class-of nil)) + + ;; Equality takes the tag into account: two instances of one class compare + ;; by their slots, an instance and a plain map with the same entries do + ;; not, and two classes with the same slots are two classes. + (println (= (point 1 2) (point 1 2))) + (println (= (point 1 2) (point 1 3))) + (println (= (point 1 2) {:x 1 :y 2})) + (println (= (circle 2) (circle 2))) + + ;; Class dispatch. Same call site, two classes, two methods. + (println (area p)) + (println (area c)) + + ;; Arbitrary dispatch, over three kinds of dispatch value and the + ;; fallback. The dispatch runs on every call, so the value is whatever + ;; the map holds at the time. + (println (describe {:kind :square :side 5})) + (println (describe {:kind "round"})) + (println (describe {:kind 7})) + (println (describe {:kind :hexagon})) + ;; An empty map on its own is the zero-field struct literal, so it is + ;; bound first -- the dispatch answers nil for a map with no :kind, and + ;; nil finds no method either. + (let [empty {:no :kind}] + (println (describe empty))) + + ;; An instance is an ordinary dyn value: it goes in a vec, keys a map, + ;; and is collected like anything else. + (let [v [p c]] + (println (len v)) + (println (class-of (at v 1)))) + + ;; The miss. No method and no :else, so the generic signals NoMethod, and + ;; handler-case answers the whole form with a value -- the condition + ;; carries the generic's name and the dispatch value that found nothing. + (println (name-of p)) + (println + (handler-case (name-of c) + [(NoMethod [e] (.generic e))])) + ;; The condition carries the dispatch value that found nothing, which for + ;; a defgeneric over a value that is no instance at all is nil. + (println + (handler-case (name-of 42) + [(NoMethod [e] (.value e))]))) + + ;; Instances under the collector: enough of them to pass the 1 MiB floor + ;; many times over, with one live instance in a rooted global. A marker that + ;; lost an instance's slots would free something live and the sum would come + ;; out wrong -- the tag itself is an interned keyword and immortal, which is + ;; why it needs no tracing. + (let [total (point 0 0)] + (dotimes [i 50000] + (let [q (point i "forty-seven bytes of text to fatten each row")] + (put total :x (+ (get total :x) (len q))))) + (println (get total :x)) + (println (class-of total))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index fecf848..90e930e 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3575,6 +3575,35 @@ level "1" "programs/dyn-map.flan" dyn_map_out; outputs ~x86:true "dyn: maps and keywords, --x86" "programs/dyn-map.flan" dyn_map_out; + (* ── Classes and generic functions, M2 item 6 ──────────────────── + The dyn side's two dispatch styles over one mechanism, at all three + rows because dispatch is a chain of dyn comparisons and the shape tag + is a word in an object header — two things the backends could differ + about and do not. Captured from the running program. The first line + pins the tagged rendering (#point in front of the map the renderer + already wrote, with its space-per-element convention unchanged) and + the 2 after it pins the other half of the decision: the tag is not an + entry, so an instance's length is its slot count. The three nils in + the middle are class-of over a plain map, a number and nil — asking + is not a claim. The 40 and the 12 are class dispatch over two + classes at one call site; the four lines under them are arbitrary + dispatch over a keyword, a string, a number and the :else fallback. + name-of, then nil, are a dispatch miss answered by handler-case: the + generic's name out of the condition, then the dispatch value that + found nothing. The 100000 at the end is 50000 instances allocated + against one live instance, well past the collector's 1 MiB floor. *) + let dyn_class_out = + "#point{ :x 3 :y 4}\n2\n3\n10\ntrue\nfalse\nnil\n:point\n\ + :circle\nnil\nnil\nnil\ntrue\nfalse\nfalse\ntrue\n40\n12\n5\n\ + a round thing, keyed by a string\nthe one keyed by a number\n\ + something else\nsomething else\n2\n:circle\na point\nname-of\n\ + nil\n100000\n:point\n" + in + outputs "dyn: classes and dispatch" "programs/dyn-class.flan" dyn_class_out; + outputs ~opt:"-O0" "dyn: classes and dispatch, -O0" + "programs/dyn-class.flan" dyn_class_out; + outputs ~x86:true "dyn: classes and dispatch, --x86" + "programs/dyn-class.flan" dyn_class_out; (* ── Per-type descriptors, M2 item 2 ───────────────────────────── The first program anywhere with a dyn field in a struct, which was a refusal until the descriptors landed. It matters at all three rows diff --git a/test/test_flan.ml b/test/test_flan.ml index 477e57a..a30703f 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1732,6 +1732,121 @@ let () = main_at "a wrong main parameter points at main" "(defn main [n i32] ())"; main_at "a wrong main return type points at main" "(defn main [] bool true)"; + (* ── Classes and generic functions — M2 item 6 ─────────────────── *) + (* A class is a constructor and a shape tag. The constructor is the class's + own name, positional over the slots, and everything that reads or writes + an instance is the dyn map operation that was already there. *) + accepts "a class and its constructor" + "(defclass point [x y])\n\ + (defn main [] i32 (let [p (point 1 2)] (if (= (get p :x) 1) 0 1)))"; + accepts "a class with no slots" + "(defclass marker [])\n(defn main [] i32 (let [m (marker)] 0))"; + accepts "class-of answers nil for anything that is not an instance" + "(defn main [] i32 (if (= (class-of 1) nil) 0 1))"; + (* The constructor is an ordinary function, so its arity is the ordinary + arity check and a wrong one names the class. *) + 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" + "(defclass point [x (Ptr i64)])\n(defn main [] i32 0)" + ~needle:"a class slot is a name"; + 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"; + + (* Both halves of the dispatch, and the fact that they are one mechanism: + a defgeneric is a defmulti whose dispatch is (class-of first-argument), + so a method written for a class is a method written for its keyword. *) + accepts "class dispatch" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p] (* (get p :x) (get p :y)))\n\ + (defn main [] i32 (if (= (area (point 2 3)) 6) 0 1))"; + accepts "arbitrary dispatch, with a fallback" + "(defmulti describe [x] dyn (get x :kind))\n\ + (defmethod describe :square [s] 1)\n\ + (defmethod describe :else [s] 2)\n\ + (defn main [] i32 (if (= (describe {:kind :round}) 2) 0 1))"; + accepts "a method may name its parameters whatever it likes" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [whatever] (get whatever :x))\n\ + (defn main [] i32 0)"; + accepts "a method may be written above its generic" + "(defclass point [x y])\n\ + (defmethod area point [p] (get p :x))\n\ + (defgeneric area [self] dyn)\n\ + (defn main [] i32 0)"; + (* A generic with no methods at all is legal and always misses; that is a + run-time answer (the NoMethod condition), not a compile-time refusal. *) + accepts "a generic with no methods" + "(defgeneric area [self] dyn)\n(defn main [] i32 0)"; + + rejects_check "a method needs a generic" + "(defclass point [x y])\n(defmethod area point [p] 1)\n\ + (defn main [] i32 0)" + ~needle:"no defgeneric or defmulti names area"; + rejects_check "a method dispatching on an unknown class" + "(defgeneric area [self] dyn)\n(defmethod area square [p] 1)\n\ + (defn main [] i32 0)" + ~needle:"no defclass names square"; + rejects_check "two methods for one dispatch value" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p] 1)\n\ + (defmethod area point [p] 2)\n\ + (defn main [] i32 0)" + ~needle:"already has a method for point"; + rejects_check "two :else methods for one generic" + "(defmulti d [x] dyn x)\n\ + (defmethod d :else [x] 1)\n\ + (defmethod d :else [x] 2)\n\ + (defn main [] i32 0)" + ~needle:"already has a method for :else"; + rejects_check "a method's arity is its generic's" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p q] 1)\n\ + (defn main [] i32 0)" + ~needle:"and this method of it takes 2"; + rejects_check "a generic's parameter is a bare name" + "(defgeneric area [self (Ptr i64)] dyn)\n(defn main [] i32 0)" + ~needle:"parameter is a bare name"; + rejects_check "a defgeneric has no body" + "(defgeneric area [self] dyn (class-of self))\n(defn main [] i32 0)" + ~needle:"It has no body"; + rejects_check "a defmulti has one" + "(defmulti describe [x] dyn)\n(defn main [] i32 0)" + ~needle:"the body is the dispatch"; + rejects_check "a defgeneric needs something to dispatch on" + "(defgeneric area [] dyn)\n(defn main [] i32 0)" + ~needle:"dispatches on the class of its first"; + rejects_check "a dispatch value is written out, not computed" + "(defmulti d [x] dyn x)\n(defmethod d (f 1) [x] 1)\n\ + (defn main [] i32 0)" + ~needle:"is written out rather than computed"; + (* A method has no return slot: the generic states the type once, for all + of them. What that means for anyone writing the defn spelling by habit + is that the slot they would have written is read as the first form of + the body, and a lone type name there is an unknown name. *) + rejects_check "a method has no return slot" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p] dyn (get p :x))\n\ + (defn main [] i32 0)" + ~needle:"dyn"; + (* A class and a function are one namespace, as a defn and a defvar are: + the constructor is a defn, so the collision is the ordinary one. *) + rejects_check "a class collides with a function of the same name" + "(defclass point [x y])\n(defn point [] i32 0)\n(defn main [] i32 0)" + ~needle:"point"; + (* ── Unconstrained operators, and everything past milestone 2 ──── *) (* M2 queue item 5: typed = and != grow strings, bytewise. Ordering does not — there is no collation the language has picked, so < stays diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index 04bb183..ad37a9d 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -195,6 +195,14 @@ let corpus = amount of reading the offsets can. *) "programs/dyn-struct.flan", []; "programs/dyn-map.flan", []; + (* Classes, M2 queue item 6. A class instance is a map with one more word + in its header, so what this adds over [dyn-map] is that word: it is + written by a constructor, read by class-of, compared by equality and + printed by both renderers, and it is the one field in an object that + the marker deliberately does not trace — an interned keyword entry is + immortal and is not a collector object. If that reasoning is wrong, + 50000 instances past the one-megabyte floor is where ASan says so. *) + "programs/dyn-class.flan", []; (* nil <-> None at (Option T), M2 queue item 4: an Option's tag is read with a raw [Field] the surface language never writes (check.ml's [box_option]/[unbox_option], the same access Render's structural From 52a1ea183a591f57148cd389e17e2818f6e41a83 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 15:02:39 +0700 Subject: [PATCH 2/7] A method added to a running program, proved end to end MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The claim classes were built for, made against a real daemon rather than at the session's report: dev-class.flan is compiled with one method for one class, a second method is delivered into the live process, and the call through the generic's cell answers with the new method's body while the original one goes on answering. That is what a generic being exactly one top-level name buys, and it is now pinned rather than argued. Two things came out of writing it, neither of them about classes. The x86 backend's redefinition module never emitted the per-type dyn descriptors. Emit.redefinition has always emitted them, by going through finish; the x86 twin ended at the rodata section and stopped. Nothing had reached it, because a redefined body had to construct a struct holding a dyn to need one, and until NoMethod there was no such struct a compiler-written body could build. What it looks like is not a bad read at run time but a link failure — desc_of mints a local label, the body references it, and ld refuses the module with an undefined symbol. One line, beside the same call in the executable path. And the thing the test had to be written around: a dyn value answered by eval-expr does not come back in the reply's :value at all. It renders to the program's own stdout, which reaches a *later* reply's :output — the dyn-global rows already read one that way and say so. So every answer here is compared inside the expression, and what crosses the wire is a typed 1 or 0. Left as it is; where a dyn expression's value should surface is a question about the editor protocol, not about this lane. The session-level test stays: it pins which names an added method reports for installation, which is the half a daemon test cannot see. --- lib/x86.ml | 11 +++++ test/programs/dev-class.flan | 26 +++++++++++ test/test_dev.ml | 85 ++++++++++++++++++++++++++++++++++++ test/test_session.ml | 47 ++++++++++++++++++++ 4 files changed, 169 insertions(+) create mode 100644 test/programs/dev-class.flan diff --git a/lib/x86.ml b/lib/x86.ml index c585400..096382f 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -4922,6 +4922,17 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) \t.size\tflan_reload_transient, 1\n\ flan_reload_transient:\n\t.byte\t1\n" | _ -> ()); + (* The per-type dyn descriptors this module's own bodies asked for, exactly + as [program] emits them. They were missing here, and the hole only became + reachable when a redefined body first constructed a struct holding a dyn: + [desc_of] mints a local label and the body references it, so a module + that never wrote the label out is one [ld] refuses with an undefined + symbol rather than one that loads and reads garbage. The labels are local + in both backends — [desc_of] says so, and this is the other half of that + sentence — so emitting the same type's descriptor here and in the host is + not a duplicate symbol. [Emit.redefinition] has always emitted them, by + going through [finish]. *) + Buffer.add_string out (Emit.descriptors_asm md); Buffer.add_string out "\n\t.section\t.rodata\n"; Buffer.add_buffer out rodata; Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n"; diff --git a/test/programs/dev-class.flan b/test/programs/dev-class.flan new file mode 100644 index 0000000..d64371a --- /dev/null +++ b/test/programs/dev-class.flan @@ -0,0 +1,26 @@ +;;;; A class and a generic function, for the dev loop rather than for output. +;;;; +;;;; What a session does with this is the question the feature is judged on: +;;;; adding a method to a running program has to reach the call sites that +;;;; were compiled before the method existed. It does, and the reason is that +;;;; a generic is one function — the methods are branches of its body, not +;;;; functions of their own — so a new method is the ordinary redefinition of +;;;; one name, through the cell the call already goes through. +;;;; +;;;; It keeps running rather than returning, for dev-repl.flan's reason: an +;;;; expression typed at the editor is a thunk the agent runs at a frame +;;;; boundary, and a parked program has none. +(import agent "vendor:agent") + +(defclass point [x y]) +(defclass circle [r]) + +(defgeneric area [self] dyn) + +(defmethod area point [p] (* (get p :x) (get p :y))) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-class-fallback.sock") + (dotimes [i 4000] + (agent/wait 5)) + 0) diff --git a/test/test_dev.ml b/test/test_dev.ml index 0a14909..e8cfbb2 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -4899,6 +4899,91 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; gout ]; + (* ── A method added to a running program ─────────────────────── + The one claim classes rest on, made end to end rather than at the + session's report: a generic function compiled with one method gets a + second one delivered into the live process, and the call that goes + through its cell answers with the new method's body. The session test + pins which name is installed; this pins that installing it works. + + Its own daemon over [programs/dev-class.flan], which keeps running so + that an expression has a frame boundary to be run at. *) + let csock = tmp "class.sock" and cout = tmp "class.out" in + (try Sys.remove csock with Sys_error _ -> ()); + let cfd = Unix.openfile cout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let cpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-class.flan"; "-s"; csock |] + Unix.stdin cfd Unix.stderr + in + Unix.close cfd; + if not (listening ~pid:cpid csock) then begin + fail "the class daemon %s (%S)" !listen_why + (In_channel.with_open_bin cout In_channel.input_all); + (try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect csock in + let said r = Option.value ~default:"" (Wire.string_field r "message") in + let value r = Option.value ~default:"" (Wire.string_field r "value") in + let ask code = + request c + (Printf.sprintf + "(:op \"eval-expr\" :code %S :file \"programs/dev-class.flan\")" + code) + in + (* Every answer is compared inside the expression rather than read out + of it. A generic answers a dyn, and a dyn value is rendered to the + program's own stdout rather than into the reply's :value — it does + reach a later reply's :output, which is how the dyn-global rows + below read one, but the flush is the next reply's and not this one's. + Asking the running program whether the answer is 12 puts a typed + value in :value and takes the timing out of the test. + + The first ask is retried: the agent's thread is let go only after the + socket is bound, so an early ask is a race with the startup and not a + result. *) + let answered = ref "" in + let asked () = + let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in + status r = "ok" && (answered := value r; true) + in + if not (await asked) then + fail "the class daemon never reached a frame boundary" + else begin + if !answered <> "1" then + fail "the method the program was built with answered %S" !answered; + (* A circle has no method yet, so the dispatch misses and the generic + signals NoMethod — the answer a program handles, spelled here as + the thing that makes the next step's success mean something. *) + let r = + request c + "(:op \"eval\" :code \"(defmethod area circle [q] (* 3 (* (get q \ + :r) (get q :r))))\" :file \"programs/dev-class.flan\")" + in + if status r <> "ok" then fail "delivering a new method: %s" (said r) + else begin + (* The call site in the generic's own cell now reaches a branch that + did not exist when the process started. *) + let r = ask "(if (= (area (circle 2)) 12) 1 0)" in + if status r <> "ok" then + fail "calling a generic after a method was added: %s" (said r) + else if value r <> "1" then + fail "the added method did not answer 12 (%S)" (value r); + (* And the method that was already there still answers, which is + what says the generic was extended rather than replaced. *) + let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in + if value r <> "1" then + fail "the original method stopped answering (%S)" (value r) + end + end; + (try Unix.close c with Unix.Unix_error _ -> ()); + (try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] cpid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) + [ csock; cout ]; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; Test_support.report ~label:"dev" () diff --git a/test/test_session.ml b/test/test_session.ml index 7351a61..6dff651 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -303,6 +303,53 @@ let () = | _ -> () | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a name added earlier was forgotten: %s" m); + (* ── A method added to a running program ──────────────────────── + The dev loop is what classes were built for, so this is the case that + decides whether the feature is usable at all. A generic function is one + top-level name whose body dispatches, and a method is a branch of it — + so adding a method has to install the *generic's* body, not a function + of the method's own, and it has to do it through the cell the call site + already goes through. If it reported only the method's own declaration + name, [report]'s compiled call to [area] would go on running the body it + was built with and the new method would be invisible. *) + let t, _ = Session.create ~file:"programs/dev-class.flan" () in + let c = Session.eval t "(defmethod area circle [c] (* 3 (* (get c :r) (get c :r))))" in + if not c.Session.installs then + fail "adding a method had nothing to install"; + if not (List.mem "area" c.Session.fns) then + fail "adding a method installed %s, not the generic's body" + (String.concat " " c.Session.fns); + (* Redefining one is the same path, and the declaration is replaced rather + than appended: a second (defmethod area circle ...) is not a duplicate + method, it is this one again. *) + let c = Session.eval t "(defmethod area circle [c] 0)" in + if not (List.mem "area" c.Session.fns) then + fail "redefining a method installed %s" (String.concat " " c.Session.fns); + (* And it stays in the session: the class the method dispatches on, the + generic it extends, and the method itself are all still there for the + next form to check against. *) + (match Session.eval t "(defmethod area point [p] (+ (get p :x) (get p :y)))" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a method added earlier left the session broken: %s" m); + (* A method for a class that is not there is refused, and refusing leaves + the session exactly as it was — the same rule every other refusal here + follows. *) + (match Session.eval t "(defmethod area square [s] 1)" with + | _ -> fail "a method dispatching on an unknown class was accepted" + | exception Loc.Error _ -> ()); + (* A whole new class and a method for it, in one form — the shape of + actually growing a program in the loop. The constructor is a name the + process was never built with, so it goes through the registry the way + any added function does, and the generic is redefined around it. *) + let c = + Session.eval t + "(do (defclass square [s]) (defmethod area square [q] (* (get q :s) (get q :s))))" + in + if not (List.mem "square" c.Session.fns && List.mem "area" c.Session.fns) then + fail "adding a class and a method installed %s" + (String.concat " " c.Session.fns); + (* A file with imports, re-evaluated whole — the C-c C-k case. The session keeps the *expanded* declarations, so the package's names are replaced in place rather than appended a second time and rejected as duplicates. *) From 0511cc1a014377ca1b783d81003d042dd937317b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 15:06:36 +0700 Subject: [PATCH 3/7] A class's name and its keyword are one dispatch value (defmethod area point ...) and (defmethod area :point ...) were both accepted and the second was dead code: a class stands for the keyword its instances carry -- that is the whole of how the two dispatch styles share a mechanism -- so the duplicate scan has to compare them as one. It compared the written forms, which differ. Normalised in the scan and pinned in test_flan.ml. --- lib/classes.ml | 8 +++++++- test/test_flan.ml | 10 ++++++++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/lib/classes.ml b/lib/classes.ml index bdf905d..f93c384 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -124,9 +124,15 @@ let collect (decls : Ast.decl list) = list: one call site reaches all of them, and it can only pass \ one number of arguments" m.Ast.mgen want (if want = 1 then "" else "s") n; + (* A class's name and its keyword are one dispatch value — a class + stands for the keyword its instances carry, which is the whole of + how the two dispatch styles share a mechanism — so [point] and + [:point] have to be compared as one or the second method is + accepted and is dead code. *) + let norm = function Ast.Dclass c -> Ast.Dkw c | k -> k in List.iter (fun (prev : Ast.methd) -> - if prev.Ast.mkey = m.Ast.mkey then + if norm prev.Ast.mkey = norm m.Ast.mkey then Loc.failk "check/duplicate-method" d.Ast.dloc "%s already has a method for %s. Two methods for one \ dispatch value is an ambiguity nothing resolves — there \ diff --git a/test/test_flan.ml b/test/test_flan.ml index a30703f..f271d2f 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1803,6 +1803,16 @@ let () = (defmethod area point [p] 2)\n\ (defn main [] i32 0)" ~needle:"already has a method for point"; + (* A class's name and its keyword are one value: a class stands for the + keyword its instances carry, so these two methods are the same method + written twice and the second would be dead code. *) + rejects_check "a class and its keyword are one dispatch value" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p] 1)\n\ + (defmethod area :point [p] 2)\n\ + (defn main [] i32 0)" + ~needle:"already has a method for :point"; rejects_check "two :else methods for one generic" "(defmulti d [x] dyn x)\n\ (defmethod d :else [x] 1)\n\ From 90110f525a73e35cf8aa7ccfa364d00c55550c1c Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 15:07:34 +0700 Subject: [PATCH 4/7] Classes and generic functions, written down Item 6 marked LANDED, and the section under it: the four spellings with an example each, why the shape tag is a header field and not the reserved key the queue's note assumed, why the method bodies are inlined rather than lifted, and what was deferred -- inheritance, multi-argument dispatch, the qualifier methods, named-slot construction, unknown-slot checking, computed dispatch values -- each with the reason rather than a list. Plus the two findings that outlive the lane: the x86 redefinition module's missing descriptors, and eval-expr never answering a dyn in :value. --- FIX.org | 174 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 173 insertions(+), 1 deletion(-) diff --git a/FIX.org b/FIX.org index 61d3eea..7c8d20f 100644 --- a/FIX.org +++ b/FIX.org @@ -519,7 +519,10 @@ rename. typed-flan branch freezes the static language pre-dyn. 5. Typed = and != grow strings: bytewise, length + same-pointer fast paths, both backends, one survey program. Ordering stays refused. — LANDED, daed039 6. defclass = named dyn map + shape tag; CLOS class dispatch AND - Clojure-style arbitrary dispatch functions. After 1. + Clojure-style arbitrary dispatch functions. After 1. — LANDED, 8d2bf2a + (the feature), 5af990e (the daemon proof and an x86 descriptor fix it + turned up) and 6c6024e. Written up below, "Classes and generic + functions, 2026-09-20". 7. dyn if: truthiness (nil/false are false, all else true). Typed stays strict bool. — LANDED, 264765a @@ -1359,3 +1362,172 @@ test/programs/defvar-dyn.flan is both readings in one program, pinned in acceptance at the default, -O0 and --x86; and dev-rerun.flan grew a [(defvar tally 0)] whose line is 4 after three re-runs, which is the claim that the new spelling goes through the old guard. +* Classes and generic functions, 2026-09-20 — M2 queue item 6 +The recorded decision was "defclass = named dyn map + shape tag; CLOS class +dispatch AND Clojure-style arbitrary dispatch functions", and it is built as +written. The two dispatch styles are one mechanism and not two: a class +dispatcher is the shape tag of the first argument used as the dispatch +function, so a method written for the class ~point~ and one written for the +value ~:point~ are the same branch — which is also why the two spellings are +refused as duplicates of each other. + +** The surface, as landed +#+begin_src lisp +(defclass point [x y]) ; a class: named slots, no types +(point 3 4) ; the constructor — the class's own name +(class-of p) ; :point, and nil for anything else +(get p :x) (put p :x 10) ; the slots are map keys; nothing new + +(defgeneric area [self] dyn) ; CLOS: dispatch on the class +(defmethod area point [p] (* (get p :x) (get p :y))) + +(defmulti describe [x] dyn (get x :kind)) ; Clojure: the body is the dispatch +(defmethod describe :square [s] (get s :side)) +(defmethod describe :else [s] "something else") +#+end_src + +- *A slot is a key.* An instance is a dyn map, so ~get~, ~put~, ~has-key?~ + and ~len~ are how one is read and written, and no operation was added for + any of it. ~(len p)~ is the slot count. +- *The constructor is positional*, one argument per slot in the order they + were written, and it is an ordinary ~defn~ — so its arity refusal, its cell + in a dev build and its behaviour under redefinition are the ones every + function already has. The named-slot spelling is deferred; see below. +- *A method has no return slot.* The generic states the return type once, for + every method written for it, which is also what makes the parse + unambiguous: the vector is always the third form. +- *Every parameter of a generic and of a method is dyn*, written or not, and + a slot that is not a bare name is refused. That keeps these forms off the + undecided-pairing path a ~defn~'s vector is on: a vector that may hold only + names can be read by the parser, where a ~defn~'s cannot be read until + every type name is known. +- *A dispatch value is a literal* — a class's name, a keyword, a string, an + integer, ~true~, ~false~, or ~:else~ for the arm everything falls through + to. ~:else~ and not Clojure's ~:default~, because ~match~ already spells + "none of the above" that way and two words for it would be one too many. + ~:else~ is the last arm whatever order it was written in. +- *A miss signals.* ~(defstruct NoMethod [generic string value dyn])~ in the + prelude, signalled with ~error~, carrying the name written at the generic + and the value the dispatch actually produced. A condition and not a trap, + because a miss is something a program can be written to answer; + ~handler-case~ around the call is the shape, and a ~:else~ method is the + other answer. No restart is established at the miss, which is + BoundsError's decision taken for BoundsError's reason. ~value~ is the first + ~dyn~ field in any condition here; the per-type descriptor an item-2 struct + carries is what the collector reaches it by. + +** The shape tag: a header field, not a reserved key +This queue item's own note said "named dyn map + shape tag", and the obvious +reading was a reserved entry in the map. It is a field in the object's header +instead — an interned ~kw_entry *~ in the map arm of ~flan_obj~'s union — and +the departure is deliberate. + +An entry would be counted by ~len~, walked by both renderers, and compared by +~dyn_equal~'s key loop. Every instance would answer a length one larger than +its slot count, print a key nobody wrote, and be one ~put~ away from having +its own class changed. A header field cannot be reached by ~get~ or ~put~ at +all, so the question of a user key colliding with it does not arise rather +than being answered by picking an unlikely spelling. + +It cost nothing. The view arm of that union is 24 bytes, so the map arm +growing from 16 to 24 does not grow the union, and ~sizeof(flan_obj)~ is 48 +before and after — checked, not assumed. It needs no marking either: an +interned keyword entry is immortal by construction and is not a collector +object, which ~mark_value~ states by following ~BOX_OBJ~ and nothing else. + +The tag is visible in exactly three places: ~class-of~ answers it; equality +compares it, so two instances of one class compare by their slots and an +instance is never equal to a plain map with the same entries (Clojure's +answer for a record beside a map); and both renderers print it — +~#point{ :x 1 :y 2}~, which is Clojure's own spelling for a record. + +The tag is built from the *qualified* class name, so two packages' ~point~ +classes are two classes and their instances are never equal. + +** How it is built: a pass, not a macro +None of the four forms reaches the checker. ~lib/classes.ml~ rewrites the +whole declaration list at the top of ~Check.build_program~, exactly where +~Shim.expand~ rewrites a ~declare-c~: a class becomes its constructor, a +generic becomes one function whose body binds the dispatch value and compares +it down a chain, and a method becomes a branch of that chain. + +A macro sees one form and this needs the whole list, because a method may be +written above its generic, below it, or arrive at a reload an hour later. +Running over the flat list is also what makes the dev loop work: a reload +rebuilds every dispatch from the session's whole set of declarations. + +*The method bodies are inlined rather than lifted into functions of their +own*, and that is the load-bearing choice. A generic is then exactly one +top-level name, so adding a method to a running program is the ordinary +redefinition of one function, through the cell the call site already goes +through. ~session.ml~ names the generic alongside the method's own +declaration name for that reason — without it a ~C-c C-c~ on a ~defmethod~ +would install something no call site reads. A method still declares a name of +its own, ~area@:circle~, which is what makes re-evaluating one a replacement +and evaluating a new one an append; no function is emitted under it. Proved +end to end against a real daemon (~test_dev.ml~, "a method added to a running +program"), not only at the session's report. + +The cost, recorded rather than hidden: *a method is not separately callable +and is not a frame of its own*. A break loop under a method shows the +generic. + +** Deferred, each with the reason +- *Inheritance.* plan.org's own rule is that method specificity and ambiguity + rules are required before inheritance or multiple dispatch is enabled, and + with single dispatch on literal values there is no specificity question at + all: two methods either answer for the same value, which is refused, or for + different ones. A hierarchy would create the question, and the author never + asked for one. +- *Multi-argument dispatch.* plan.org names it as the later extension, for + ~(collide Player Enemy)~. It wants the specificity rules above. +- *~:before~, ~:after~, ~:around~ and ~call-next-method~.* They only mean + something once methods can be ordered by anything but equality, which is + the same gate inheritance is behind. +- *Named-slot construction*, ~(point {:x 1})~ with an omitted slot meaning + nil — the dyn twin of ~(Cursor {.src s})~ with its omitted-is-zeroed rule. + Positional is what a generated ~defn~ gives for free, arity included; the + named form is a checker special case and was not worth one at v1. +- *Unknown-slot checking at ~(get p :z)~.* The one compile-time win a + declared slot set makes possible (docs/SPIKE-DUPLICITY.md §8 names it), and + it needs the checker to know the class of an expression — class-typed + tracking on the dyn side, which dyn deliberately does not have. A class + adds a tag and a dispatch, not a static slot discipline. +- *Computed dispatch values.* Clojure registers a method under any value + because registration there is a run-time call; here it is compile-time, and + the method's declaration name is built from the value. +- *~nil~ and floats as dispatch values.* ~:else~ covers the nil case, which + is the common one (~class-of~ answers nil for anything that is not an + instance); a float compared for equality is a trap waiting to be sprung. +- *Class redefinition and migration* — plan.org's ~redefine-class~ / + ~migrate-instances~. A heterogeneous map has no layout to be stale, so + nothing breaks today when a class gains a slot: old instances simply lack + it. Enumerating live instances is the part that is missing, and it is the + pool's question rather than this lane's. +- *The JS backend.* It refuses dyn wholesale, so none of this compiles there. + Same parking as the string-equality hole above. + +** Two things found on the way, neither about classes +- *The x86 backend's redefinition module never emitted the per-type dyn + descriptors.* ~Emit.redefinition~ has always emitted them, by going through + ~finish~; the x86 twin ended at the rodata section and stopped. Nothing had + reached it, because a redefined body had to construct a struct holding a + dyn to need one, and until ~NoMethod~ there was no such struct a + compiler-written body could build. It is not a bad read at run time — a + descriptor label is local, so ~ld~ refuses the module with an undefined + symbol. Fixed with one line beside the same call in the executable path. +- *A dyn value answered by ~eval-expr~ never reaches the reply's ~:value~.* + It renders to the program's own stdout, which arrives on a *later* reply's + ~:output~ — the dyn-global rows already read one that way and say so, and + ~(+ 2 3)~ answering "5" beside ~(area (point 3 4))~ answering "" is the + whole of the difference. Left standing: where a dyn expression's value + should surface is a question about the editor protocol, not about this + lane. The dev test works around it by comparing inside the expression, so + what crosses the wire is a typed 1. + +** What was run +~dune test --root .~ green (exit 0, no FAIL lines) after each of the three +commits. Three acceptance rows for ~test/programs/dyn-class.flan~ — default, +~-O0~ and ~--x86~ — and a three-way diff of the program's real output across +the same three, captured by hand before the rows were written. It is in +~test_sanitize.ml~'s list; per the sweep policy the sweep itself was not run. From ac7608f94b096e2ab1809b40e3da5448a7d3d15c Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 15:36:02 +0700 Subject: [PATCH 5/7] A method's parameter names are bound in parallel, not in sequence A let binds in sequence, so binding a method's names pairwise from the generic's reads a name it has just bound. A generic [a b] with a method [b a] -- a swap, which is what renaming parameters most often is -- was handed its first argument twice and could not reach its second at all; [b c] is the same bug one step shorter. Every argument is now copied into a temp in the unspellable ~ namespace first and every method name bound from a temp, uniformly rather than only for the pairs that collide, because a rule that fires on the tangled case alone is one nobody exercises. Both shapes are in dyn-class.flan, where the values are what is wrong rather than the types, and across all three rows. With it, two things the descriptor fix left behind. descriptors_asm wrote the descriptors into .rodata and a descriptor holds the address of its own offset table, so every one of them was a relocation in a read-only section -- a DT_TEXTREL, which ld warns about in a PIE and refuses in a shared object, and which was warning in the new daemon case's own output. They go in .data.rel.ro now, in both the executable and the reload module; readelf -d on a reload module from each backend shows no TEXTREL. And FIX.org: the stale held line for item 6, the fourth read site of the shape tag (say_render, not just print), the warning that a class's qualifier is the importer's alias so a hand-written :a/point is coupled to one import's name, and the gap flagged for the next sweep -- marking through a descriptor an x86 reload module emitted is still unexercised. --- FIX.org | 60 ++++++++++++++++++++++++++++++------ lib/classes.ml | 60 ++++++++++++++++++++++++++++-------- lib/emit.ml | 10 +++++- test/programs/dyn-class.flan | 17 ++++++++++ test/test_acceptance.ml | 10 ++++-- test/test_flan.ml | 13 ++++++++ 6 files changed, 144 insertions(+), 26 deletions(-) diff --git a/FIX.org b/FIX.org index 7c8d20f..ed2d19c 100644 --- a/FIX.org +++ b/FIX.org @@ -185,8 +185,9 @@ against 985ms on LLVM. * Landed on dev-loop Items 1, 2, 3 and 5 are merged and green (dune test --force, 232 elisp checks, -0 failures). Items 4 (drop) and 7 (defdata) are still being written. Item 6 is -held. +0 failures). Items 4 (drop) and 7 (defdata) are still being written. Item 6 — +classes and generic functions — is no longer held: it landed, and the M2 queue +above records it under item 6 with its commits. ** Re-run is merged, and does not work under --x86 Park and re-run live in the merged entry point's main(), and --x86 refuses the @@ -1435,14 +1436,25 @@ before and after — checked, not assumed. It needs no marking either: an interned keyword entry is immortal by construction and is not a collector object, which ~mark_value~ states by following ~BOX_OBJ~ and nothing else. -The tag is visible in exactly three places: ~class-of~ answers it; equality -compares it, so two instances of one class compare by their slots and an -instance is never equal to a plain map with the same entries (Clojure's -answer for a record beside a map); and both renderers print it — -~#point{ :x 1 :y 2}~, which is Clojure's own spelling for a record. +The tag is read in exactly four places in flan_dyn.c: ~class-of~ answers it; +~dyn_equal~ compares it, so two instances of one class compare by their slots +and an instance is never equal to a plain map with the same entries +(Clojure's answer for a record beside a map); and *both* renderers write it — +~render~, which is what ~print~ goes through, and ~say_render~, the 96-byte +sentence a trap prints, so a dyn trap naming an instance says which class it +was. The spelling is ~#point{ :x 1 :y 2}~, Clojure's own for a record. -The tag is built from the *qualified* class name, so two packages' ~point~ -classes are two classes and their instances are never equal. +The tag is built from the class's *qualified* name, and the qualifier is the +**importer's alias** rather than anything the defining package chose — the +same class imported as ~a~ and as ~zz~ tags its instances ~:a/point~ and +~:zz/point~. That falls straight out of [Load]'s rename, and it is right for +the dispatch, which resolves the class name through the same rename and +therefore agrees with it. What it is *not* safe for is a hand-written +dispatch value: ~(defmethod g :a/point ...)~ is a keyword and nobody +qualifies it, so it is coupled to one import's alias and silently answers for +nothing under another. Write the class's name, ~(defmethod g point ...)~, +which is renamed with everything else. Two packages' own ~point~ classes are +two classes either way, which was the property wanted. ** How it is built: a pass, not a macro None of the four forms reaches the checker. ~lib/classes.ml~ rewrites the @@ -1468,9 +1480,21 @@ and evaluating a new one an append; no function is emitted under it. Proved end to end against a real daemon (~test_dev.ml~, "a method added to a running program"), not only at the session's report. +A method's own parameter names are bound from the generic's *in parallel*, +through temporaries in the unspellable ~[~]~ namespace. A [let] binds in +sequence, so the pairwise spelling reads a name it has just bound: a method +[[b a]] under a generic [[a b]] would be handed its first argument twice and +the second would be unreachable. Both the swap and the one-step shift are +pinned in the survey program, where the values are what is wrong rather than +the types. + The cost, recorded rather than hidden: *a method is not separately callable and is not a frame of its own*. A break loop under a method shows the -generic. +generic. And the generic's own parameter names stay in scope inside a method +that renamed them, so a body reaching for ~self~ where it declared ~p~ +silently resolves instead of being refused — small, and closing it would mean +giving the dispatcher unspellable parameter names, which is what the +inspector reads. ** Deferred, each with the reason - *Inheritance.* plan.org's own rule is that method specificity and ambiguity @@ -1516,6 +1540,22 @@ generic. compiler-written body could build. It is not a bad read at run time — a descriptor label is local, so ~ld~ refuses the module with an undefined symbol. Fixed with one line beside the same call in the executable path. + + Emitting them turned up the second half: ~descriptors_asm~ wrote them into + ~.rodata~, and a descriptor holds the address of its own offset table. A + relocation in a read-only section is a ~DT_TEXTREL~ — ld warns about it in + a PIE and refuses it in a shared object — so the section is now + ~.data.rel.ro~, which exists for exactly this and is what both the + executable and the reload module use. Verified with ~readelf -d~ on a + reload module from each backend: no ~TEXTREL~, descriptors in + ~.data.rel.ro~. + + *Still unexercised, and for the next sweep rather than this lane:* marking + THROUGH a descriptor that an x86 reload module emitted. What is proved is + that the module links and runs; what is not is a collection happening while + a live instance of a dyn-holding struct sits in a frame of a body that + module delivered. The LLVM path has been exercised since item 2; this one + has existed for a day. - *A dyn value answered by ~eval-expr~ never reaches the reply's ~:value~.* It renders to the program's own stdout, which arrives on a *later* reply's ~:output~ — the dyn-global rows already read one that way and say so, and diff --git a/lib/classes.ml b/lib/classes.ml index f93c384..7afe0c6 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -193,22 +193,56 @@ let key_expr loc (k : Ast.dispatch) : Ast.expr = (* A method's body, with the method's own parameter names bound to the generic's. The names are the method's to choose — [(defmethod area point [p] - ...)] under [(defgeneric area [self] dyn)] — and a name that already agrees - binds nothing, so the common case adds no [let] at all. *) + ...)] under [(defgeneric area [self] dyn)] — and a method whose names + already agree with the generic's binds nothing, so the common case adds no + [let] at all. + + **The rebinding is parallel, and it has to be.** A [let] here binds in + sequence: each binding is in scope for the next one's value. So the + pairwise spelling — [(let [b a a b] ...)] for a generic [[a b]] and a + method [[b a]] — reads the [b] it has just bound and hands the method its + first argument twice, with the second unreachable. That is a swap, and a + swap is exactly what a method renaming its parameters is most likely to be + doing; the non-swap case [[b c]] is the same bug one step shorter, since + [b] reads the binding above it rather than the parameter. Both are what + [rotatef] and Clojure's destructuring do in parallel, and neither language + would read a name it was in the middle of rebinding. + + So every argument is copied into a temp first and every method name is + bound from a temp, never from a parameter. [~] is a delimiter in the + reader, so the temps cannot collide with a method's names whatever they + are, and one uniform shape is written rather than only the pairs that + actually collide — a rule that fires only on the tangled case is a rule + nobody exercises. *) let method_body (g : generic) (m : Ast.methd) : Ast.expr = let loc = m.Ast.mfn.Ast.nloc in - let bs = - List.filter_map + let pairs = List.combine m.Ast.mfn.Ast.params g.gfn.Ast.params in + if + List.for_all (fun ((mp : Ast.field), (gp : Ast.field)) -> - if String.equal mp.Ast.fname gp.Ast.fname then None - else - Some { Ast.bname = mp.Ast.fname; bty = None; - bval = ex mp.Ast.floc (Ast.Var gp.Ast.fname); - bloc = mp.Ast.floc }) - (List.combine m.Ast.mfn.Ast.params g.gfn.Ast.params) - in - if bs = [] then ex loc (Ast.Do m.Ast.mfn.Ast.fbody) - else ex loc (Ast.Let (bs, m.Ast.mfn.Ast.fbody)) + String.equal mp.Ast.fname gp.Ast.fname) + pairs + then ex loc (Ast.Do m.Ast.mfn.Ast.fbody) + else begin + let tmp i = Printf.sprintf "~arg%d" i in + let hold = + List.mapi + (fun i ((_ : Ast.field), (gp : Ast.field)) -> + { Ast.bname = tmp i; bty = None; + bval = ex gp.Ast.floc (Ast.Var gp.Ast.fname); + bloc = gp.Ast.floc }) + pairs + in + let rename = + List.mapi + (fun i ((mp : Ast.field), (_ : Ast.field)) -> + { Ast.bname = mp.Ast.fname; bty = None; + bval = ex mp.Ast.floc (Ast.Var (tmp i)); + bloc = mp.Ast.floc }) + pairs + in + ex loc (Ast.Let (hold @ rename, m.Ast.mfn.Ast.fbody)) + end (* What a generic answers when no method does. Common Lisp signals here and so does this: it is a condition with a handler-case around it, not a trap, diff --git a/lib/emit.ml b/lib/emit.ml index 6f30937..ca4d8a5 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4036,7 +4036,15 @@ let descriptors_asm m = "\n# The per-type dyn descriptors — runtime/flan_dyn.h's flan_desc: the\n\ # size of one instance, how many dyn words it holds, and where they are.\n\ # Read by the collector through flan_dyn_root_push_desc and by nothing\n\ - # else; no value points at one.\n\t.section\t.rodata\n"; + # else; no value points at one.\n\ + #\n\ + # .data.rel.ro and not .rodata, because a descriptor holds the address\n\ + # of its own offset table. That is a relocation, and a relocation in a\n\ + # read-only section is one the dynamic linker can only apply by making\n\ + # the section writable — a DT_TEXTREL, which ld warns about in a PIE\n\ + # and refuses outright in a shared object. .data.rel.ro is the section\n\ + # for exactly this: relocated at load and read-only from then on.\n\ + \t.section\t.data.rel.ro,\"aw\",@progbits\n"; List.iter (fun (_, (sym, offs, size)) -> Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s.offs:\n" sym); diff --git a/test/programs/dyn-class.flan b/test/programs/dyn-class.flan index 06a9543..5bc6ed4 100644 --- a/test/programs/dyn-class.flan +++ b/test/programs/dyn-class.flan @@ -41,6 +41,17 @@ (defgeneric name-of [self] dyn) (defmethod name-of point [p] "a point") +;; A method's parameter names are its own, and the rebinding that gives it +;; them is parallel. [reorder] names them in the generic's order reversed, which +;; a sequential binding would get wrong in the worst possible way -- it would +;; read the name it had just bound and hand the method its first argument +;; twice. [shift] is the same bug one step shorter: [b] there is the +;; generic's second parameter and must not become the first. +(defmulti reorder [a b] dyn (class-of a)) +(defmethod reorder point [b a] [b a]) +(defmulti shift [a b] dyn (class-of a)) +(defmethod shift point [b c] [b c]) + (defn main [] i32 (let [p (point 3 4) c (circle 2)] @@ -93,6 +104,12 @@ (println (len v)) (println (class-of (at v 1)))) + ;; The renamed parameters, in the generic's own order: the first element + ;; of each answer is the first argument. A sequential rebinding would + ;; print the point twice in the first and lose the 99 in the second. + (println (reorder p 99)) + (println (shift p 99)) + ;; The miss. No method and no :else, so the generic signals NoMethod, and ;; handler-case answers the whole form with a value -- the condition ;; carries the generic's name and the dispatch value that found nothing. diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 90e930e..bcc7366 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3588,6 +3588,11 @@ level "1" is not a claim. The 40 and the 12 are class dispatch over two classes at one call site; the four lines under them are arbitrary dispatch over a keyword, a string, a number and the :else fallback. + The two bracketed lines are a method whose parameter names are the + generic's reversed and one whose names are shifted along: both answer + first-argument-first, which is what says the rebinding is parallel — + a sequential one prints the point twice in the first and loses the 99 + in the second. name-of, then nil, are a dispatch miss answered by handler-case: the generic's name out of the condition, then the dispatch value that found nothing. The 100000 at the end is 50000 instances allocated @@ -3596,8 +3601,9 @@ level "1" "#point{ :x 3 :y 4}\n2\n3\n10\ntrue\nfalse\nnil\n:point\n\ :circle\nnil\nnil\nnil\ntrue\nfalse\nfalse\ntrue\n40\n12\n5\n\ a round thing, keyed by a string\nthe one keyed by a number\n\ - something else\nsomething else\n2\n:circle\na point\nname-of\n\ - nil\n100000\n:point\n" + something else\nsomething else\n2\n:circle\n\ + [ #point{ :x 10 :y 4} 99]\n[ #point{ :x 10 :y 4} 99]\n\ + a point\nname-of\nnil\n100000\n:point\n" in outputs "dyn: classes and dispatch" "programs/dyn-class.flan" dyn_class_out; outputs ~opt:"-O0" "dyn: classes and dispatch, -O0" diff --git a/test/test_flan.ml b/test/test_flan.ml index f271d2f..753bc77 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1778,6 +1778,19 @@ let () = (defgeneric area [self] dyn)\n\ (defmethod area point [whatever] (get whatever :x))\n\ (defn main [] i32 0)"; + (* The rebinding that gives a method its own parameter names is parallel. + A [let] binds in sequence, so the pairwise spelling reads a name it has + just bound: these two type-check either way and the values are what is + wrong, which is why dyn-class.flan is where they are really pinned. What + is pinned here is that both shapes are legal at all. *) + accepts "a method may reverse its generic's parameter names" + "(defmulti g [a b] () (class-of a))\n\ + (defmethod g :else [b a] (println b) (println a))\n\ + (defn main [] i32 0)"; + accepts "a method may shift its generic's parameter names along" + "(defmulti g [a b] () (class-of a))\n\ + (defmethod g :else [b c] (println b) (println c))\n\ + (defn main [] i32 0)"; accepts "a method may be written above its generic" "(defclass point [x y])\n\ (defmethod area point [p] (get p :x))\n\ From bd29eee3e43aa535ca4ac82712096e99c579e8b9 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 15:38:19 +0700 Subject: [PATCH 6/7] The rebase is what was run, so it is what the note says The what-was-run paragraph counted three commits and no rebase. It is five commits and a rebase onto the defvar-dyn lane now, whose load.ml and ast.ml arms sit beside the four this lane added and were read against them by hand rather than left to the auto-merge. --- FIX.org | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/FIX.org b/FIX.org index ed2d19c..5b8cb1b 100644 --- a/FIX.org +++ b/FIX.org @@ -1566,8 +1566,12 @@ inspector reads. what crosses the wire is a typed 1. ** What was run -~dune test --root .~ green (exit 0, no FAIL lines) after each of the three -commits. Three acceptance rows for ~test/programs/dyn-class.flan~ — default, -~-O0~ and ~--x86~ — and a three-way diff of the program's real output across -the same three, captured by hand before the rows were written. It is in +~dune test --root .~ green (exit 0, no FAIL lines) after each commit, and +again on the rebase onto the defvar-dyn lane — whose ~load.ml~ arms are the +~defvar~ one and whose ~ast.ml~ arm is the ~Ambiguous~ initialiser, disjoint +from the four class arms beside them; both sets were read against each other +by hand rather than trusted to the auto-merge. Three acceptance rows for +~test/programs/dyn-class.flan~ — default, ~-O0~ and ~--x86~ — and a three-way +diff of the program's real output across the same three, captured by hand +before the rows were written and again after the rebase. It is in ~test_sanitize.ml~'s list; per the sweep policy the sweep itself was not run. From 0b4bf850ec8f85c9c1ccb02817146e5d6507444b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 15:47:06 +0700 Subject: [PATCH 7/7] The random exit 1 is test_dev's trap rows, and it predates this lane dune test exits 1 roughly two runs in five with no FAIL line anywhere: test_dev's trap_park polls a daemon that has just aborted at the break loop, using a bare Wire.send/Wire.recv pair, and a daemon that exits between the two raises Wire.Closed with nothing to catch it. The binary dies and every row after it is skipped. Measured on a detached worktree at dev-loop's tip with none of this lane in it: 2 of 5 runs, same exception, same row. Same rate as this branch, because it is the same code. Written down rather than patched -- the fix is a claim about what those rows mean when the program ends under them, which belongs to whoever owns them. --- FIX.org | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/FIX.org b/FIX.org index 5b8cb1b..58df760 100644 --- a/FIX.org +++ b/FIX.org @@ -1575,3 +1575,26 @@ by hand rather than trusted to the auto-merge. Three acceptance rows for diff of the program's real output across the same three, captured by hand before the rows were written and again after the rebase. It is in ~test_sanitize.ml~'s list; per the sweep policy the sweep itself was not run. + +** Found while running it: ~dune test~ exits 1 at random, and has since before + this lane +~test_dev.ml~'s ~trap_park~ rows are racy, and when they lose the race the +whole test binary dies with ~Fatal error: exception Flan.Wire.Closed~ — exit +1 with no FAIL line anywhere, which is the worst shape a failure can have +given that the sweep policy says a lane is judged on the exit status. + +The mechanism: ~trap_park~ polls with ~ask~, which is a bare ~Wire.send~ / +~Wire.recv~ pair with nothing around it, and the program it is polling has +just aborted at the break loop. If the daemon exits between the send and the +recv, ~Wire.recv~ raises ~Closed~, nothing catches it, and every row after it +— in this lane's case the new class daemon among them — never runs. Both +observed failures landed at the same row, ~dev-trap-null-alloc~. + +*It is not this lane's.* Measured on a detached worktree at dev-loop's tip +(c4e0725) with nothing of this lane in it: 2 of 5 runs exit 1 with the same +exception at the same row, against 2 of 5 on this branch. The rates match +because the code is the same. + +Not fixed here, deliberately: the fix is to catch ~Closed~ in that poll and +read it as the program having ended, which is a claim about what those rows +mean and belongs to whoever owns them. Flagged rather than patched.