Joseph Ferano
0511cc1a01
(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.
318 lines
14 KiB
OCaml
318 lines
14 KiB
OCaml
(** 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;
|
|
(* 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 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 \
|
|
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
|