flan/lib/classes.ml

(** 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