JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A struct can be generic over types and lengths, and an error in a generic names the call that made it

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 20:03:49 +07:00
commit 241ea67fbb
19 changed files with 1799 additions and 247 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
TODO.org
View File

@ -736,15 +736,10 @@ depth it gave up at. The bare depth number is a backstop that also prints the
chain. Before any of it, the compiler hung rather than failed, which wedges =C-c
C-c= with nothing to show.
** NEXT Generic types
Decided 2026-09-25: the freeze is lifted for this; build both type and length parameters.
=(defstruct Pair [a $t b $t])= cannot be spelled, and neither can a length
parameter. =Types.Named= is a bare string with no room for parameters; giving it
some changes the type, the layout calculator, both backends, the renderer and the
DWARF path. Same price for one as for both. Decided and unblocked, deliberately
not started — it is a language feature under a freeze, and it was stopped once
already for that reason. The motivating case is Odin's =Small_Array=: a
fixed-capacity array with a count and no allocation.
** DONE Generic types
CLOSED: [2026-09-25]
A struct's parameters are its fields' $-names in first-written order, a length by position; there is no
explicit parameter vector. Each application is an ordinary struct under a key, so no backend sees a parameter.
** WAIT A value predicate over a length parameter
Decided 2026-09-25: waits until a program wants one.
@ -753,12 +748,6 @@ clause here admits nothing but type predicates. Whether it should take value
predicates over a length parameter deserves answering deliberately rather than
falling out of the implementation.
** TODO "In instantiation of" notes
A refusal inside a copy points at the generic's source with no note naming the
call site that asked for that type. The data is there — =instantiation_origin=
exists and the session already uses it — and wiring it into every failure under an
instantiation is a lane of its own.
** DONE A program is one compilation, so a generic's body is always visible
CLOSED: [2026-09-25]
Odin's and Zig's model: packages are never compiled separately. The cost is build
@ -983,15 +972,6 @@ ignore order, writable access has to alias the real storage. Flexible field orde
waits for classes deliberately, because a class owns its layout and a =Vector2=
should not pay for identity and metadata. Not implemented.
** TODO An error in a called generic's body is reported twice
=(defn g [x $t] u64 (nosuch x))= called once from =main= prints "unknown
function nosuch" twice at the same place and counts 2 errors — once from the
abstract pass and once from the instantiation.
** TODO A type variable is printed without its $
=Types.to_string= prints =Var t= as =t=, so a refusal reads "selection-sort
expects [t] here, found [3 i32]" where the source wrote =[$t]=.
** DONE Two refusals suggested something that does not compile
CLOSED: [2026-09-25]
=vec-new= and =map-new= with no type no longer say "or give the binding a type";

3
lib/ast.ml
View File

@ -24,6 +24,9 @@ and texpr_kind =
them identically — the difference is a fact about the value, and it is
[Check.resolve] that turns it into one. *)
| Tfn of bool * texpr list * texpr
(* An integer written as a generic struct's argument, the 8 in
(Small 8 i32). Parsed only there; it is not a type anywhere else. *)
| Tlen of int64
(* An array length is an integer or a compile-time constant's name. *)
and len =

1216
lib/check.ml
View File

File diff suppressed because it is too large Load Diff

1
lib/cimport.ml
View File

@ -407,6 +407,7 @@ let rec ty_source (t : Ast.texpr) =
| Ast.Tname n -> n
| Ast.Tapp (n, args) ->
Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args))
| Ast.Tlen n -> Int64.to_string n
| Ast.Tslice (c, e) ->
Printf.sprintf "[%s%s]" (if c then "const " else "") (ty_source e)
| Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e)

41
lib/dev.ml
View File

@ -704,14 +704,12 @@ let host_loc t name =
that was written finds nothing in the program, and these are how it gets
from that name to what the program does hold. *)
(* Its signature as written, [$] and all — [Types.to_string] prints a variable
bare, and [[t]] is not how anyone wrote it. *)
(* Its signature as written, [$] and all. *)
let generic_signature t name =
match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with
| None -> None
| Some (vars, params, ret) ->
let dollar = List.map (fun v -> (v, Types.Var ("$" ^ v))) vars in
let show ty = Types.to_string (Check.subst_ty dollar ty) in
| Some (_, params, ret) ->
let show ty = Types.to_string ty in
Some
(Printf.sprintf "%s [%s] %s" name
(String.concat " " (List.map show params)) (show ret))
@ -1914,8 +1912,27 @@ let defs t =
~loc:(Loc.to_string loc) ())
classes
in
(* A generic struct is listed by its template, as [(Pair $t)]; its copies
are struct names only the compiler wrote. *)
let structs =
Hashtbl.fold
(fun name _ acc ->
if Hashtbl.mem env.Check.copies name then acc
else entry ~name ~kind:"struct" ~sign:name ~loc:"" () :: acc)
env.Check.structs []
@ Hashtbl.fold
(fun name (g : Check.gstruct) acc ->
entry ~name ~kind:"struct"
~sign:
(Printf.sprintf "(%s %s)" name
(String.concat " "
(List.map (fun (p, _) -> "$" ^ p) g.Check.gparams)))
~loc:"" ()
:: acc)
env.Check.gstructs []
in
List.sort compare
(of_table "struct" env.Check.structs
(structs
@ datas @ classes
@ of_table "union" env.Check.unions
@ of_table "enum" env.Check.enums
@ -1996,13 +2013,19 @@ let defs t =
text about the type and never touches the program. *)
let layout t ~ty =
let structs = t.session.Session.program.Tast.structs in
(* A generic struct's copy answers to the spelling a printed value's head
gives it, [Pair i32], and to its type's, [(Pair i32)], as well as to its
key. *)
let names (s : Tast.structure) =
[ s.Tast.sname; Types.struct_head s.Tast.sname;
Types.to_string (Types.Named s.Tast.sname) ]
in
match
List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname ty)
structs
List.find_opt (fun (s : Tast.structure) -> List.mem ty (names s)) structs
with
| Some s ->
ok
[ ":type " ^ Wire.quote s.Tast.sname;
[ ":type " ^ Wire.quote (Types.to_string (Types.Named s.Tast.sname));
":fields "
^ Wire.list
(List.map

7
lib/emit.ml
View File

@ -370,7 +370,7 @@ let rec ll (t : Types.t) =
integer spelling costs no casts and keeps the emitter honest about not
knowing whether the bits are a pointer. *)
| Types.Dyn -> "i64"
| Types.Var _ ->
| Types.Var _ | Types.Len _ | Types.LArray _ ->
(* The checker rejects it by name — nothing reaches here. *)
internal "no layout for %s" (Types.to_string t)
@ -647,7 +647,8 @@ let rec lay m (t : Types.t) : int * int =
| Some u -> union_lay m u
| None -> internal "no layout for struct %s" n)
| Types.Dyn -> 8, 8
| Types.Var _ -> internal "no layout for %s" (Types.to_string t)
| Types.Var _ | Types.Len _ | Types.LArray _ ->
internal "no layout for %s" (Types.to_string t)
(* Size, alignment, and the offset of every member. *)
and lay_fields m tys =
@ -1210,7 +1211,7 @@ let rec dty m d (t : Types.t) : int =
reading: it prints, and the person reading it can hand it to the
runtime's own printer. *)
| Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned"
| Types.Var _ ->
| Types.Var _ | Types.Len _ | Types.LArray _ ->
internal "no debug type for %s" (Types.to_string t)
in
Hashtbl.replace d.dtys key n;

2
lib/js.ml
View File

@ -249,6 +249,8 @@ let rec refuse_ty loc (t : Types.t) =
host's own, and that work has not been done"
| Types.Var n ->
at loc "a type variable (%s) reached the backend, which cannot happen" n
| Types.Len _ | Types.LArray _ ->
at loc "a length variable reached the backend, which cannot happen"
(* Aggregates in the sense that matters here: the types whose assignment
copies in Flan and would alias in JS. A slice is deliberately not one —

8
lib/load.ml
View File

@ -213,8 +213,11 @@ let rec rename_texpr owned alias (t : Ast.texpr) : Ast.texpr =
Ast.Tarray (rename_len owned alias l, rename_texpr owned alias e)
| Ast.Tmap (k, v) ->
Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v)
(* The head too, when it is a generic struct the package declares. *)
| Ast.Tapp (n, args) ->
let n = if List.mem n owned then qualify alias n else n in
Ast.Tapp (n, List.map (rename_texpr owned alias) args)
| Ast.Tlen _ as k -> k
| Ast.Tfn (env, ps, r) ->
Ast.Tfn (env, List.map (rename_texpr owned alias) ps,
rename_texpr owned alias r)
@ -800,8 +803,11 @@ let rec texpr_uses acc (t : Ast.texpr) =
(match l with Ast.Lname n -> acc := (n, t.Ast.tloc) :: !acc | Ast.Lint _ -> ());
texpr_uses acc e
| Ast.Tmap (k, v) -> texpr_uses acc k; texpr_uses acc v
| Ast.Tapp (_, args) -> List.iter (texpr_uses acc) args
| Ast.Tapp (n, args) ->
acc := (n, t.Ast.tloc) :: !acc;
List.iter (texpr_uses acc) args
| Ast.Tfn (_, ps, r) -> List.iter (texpr_uses acc) ps; texpr_uses acc r
| Ast.Tlen _ -> ()
let rec expr_uses acc (e : Ast.expr) =
let go = expr_uses acc in

50
lib/parse.ml
View File

@ -99,6 +99,16 @@ let no_pattern (f : Form.t) =
(* ── Type expressions ──────────────────────────────────────────────── *)
(* A type constructor's spelling: its last segment starts with a capital. *)
let capitalised_name name =
let base =
match String.rindex_opt name '/' with
| Some i -> String.sub name (i + 1) (String.length name - i - 1)
| None -> name
in
base <> "" && Char.uppercase_ascii base.[0] = base.[0]
&& Char.lowercase_ascii base.[0] <> base.[0]
let rec texpr (f : Form.t) : Ast.texpr =
let mk t = { Ast.t; tloc = f.loc } in
match f.v with
@ -161,8 +171,44 @@ let rec texpr (f : Form.t) : Ast.texpr =
| [ { v = Vec params; _ }; ret ] ->
mk (Ast.Tfn (env, List.map texpr params, texpr ret))
| _ -> fail f "a function type is (%s [T ...] R)" which)
| List ({ v = Sym name; _ } :: args) when args <> [] ->
mk (Ast.Tapp (name, List.map texpr args))
| List ({ v = Sym name; _ } :: args)
when args <> [] || capitalised_name name ->
(* An integer argument is a generic struct's length, and a type
constructor is capitalised. A lowercase head is a body form in the
return slot — (+ x 1) — and its integer is the type parser's reason to
give up, which is the refusal that slot is built on. *)
let capitalised = capitalised_name name in
(* Integer arithmetic over literals is a length too — [(Small (+ 4 4)
i32)] — folded here, since nothing later reads it as a value. *)
let rec fold (a : Form.t) =
match a.v with
| Int n -> Some n
| List ({ v = Sym (("+" | "-" | "*") as op); _ } :: (_ :: _ as xs)) ->
let vs = List.map fold xs in
if List.for_all Option.is_some vs then
let vs = List.map Option.get vs in
match op, vs with
| "-", [ x ] -> Some (Int64.neg x)
| "+", v :: rest -> Some (List.fold_left Int64.add v rest)
| "-", v :: rest -> Some (List.fold_left Int64.sub v rest)
| "*", v :: rest -> Some (List.fold_left Int64.mul v rest)
| _ -> None
else None
| _ -> None
in
let arg (a : Form.t) =
match a.v, fold a with
| _, Some n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc }
| List _, None when capitalised ->
(try texpr a with
| Loc.Error _ ->
fail a
"%s is not a type or a length. An argument here is a type, or a \
length: an integer, a constant's name or a length variable"
(Form.to_string a))
| _ -> texpr a
in
mk (Ast.Tapp (name, List.map arg args))
| _ -> fail f "expected a type, found %s" (Form.to_string f)
and len (f : Form.t) : Ast.len =

8
lib/render.ml
View File

@ -103,6 +103,12 @@ let print_refusal _loc t =
Printf.sprintf "no printer for %s — print the values you want out of it"
(Types.to_string t)
(* The head a struct value prints under: its name, or for a generic struct's
copy the template and its arguments, [Pair i32], so the value reads
[(Pair i32 {.a 1 .b 2})] the way its type is written. Every renderer of a
struct value goes through this, so they all print the same text. *)
let head n = Types.struct_head n
let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr list =
let render c depth e = render ~refuse c depth e in
let loc = e.Tast.loc in
@ -333,7 +339,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis
@ render c (depth + 1) v)
shown)
in
[ do_ ((lit ("(" ^ n ^ " {") :: parts)
[ do_ ((lit ("(" ^ head n ^ " {") :: parts)
@ (if List.length fields > max_span then [ lit " ..." ] else [])
@ [ lit "})" ]) ])
(* A fixed array's length is in its type, so it unrolls — capped, because

40
lib/session.ml
View File

@ -597,7 +597,7 @@ let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) =
if not same then
fail loc
"%s changes layout. Restart to change it."
s.Tast.sname
(Types.to_string (Types.Named s.Tast.sname))
| None -> ())
new_.Tast.structs
@ -1596,7 +1596,7 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
let loc = fn.Tast.floc in
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -1708,7 +1708,7 @@ let render_condition t ~(st : Tast.structure) : change * (string * string) list
let loc = Loc.unknown in
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -1969,7 +1969,7 @@ let render_slot ?(origin = "<inspect>") t ~frame ~(fn : Tast.fn) ~slot ~path
| Some name ->
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2286,7 +2286,7 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
in
let extra = ref [] and nslots = ref (Array.length base) in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums =
@ -2323,11 +2323,15 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
Array.append bnames
(Array.make (List.length !extra) None) }
in
(* A struct copy the values named first, laid out in this
module and kept, as [eval_expr] keeps one. *)
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program =
{ t.program with
Tast.fns =
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname
@ [ thunk ];
structs = t.program.Tast.structs @ copies;
externs = t.program.Tast.externs @ externs }
in
let ir =
@ -2340,7 +2344,9 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
[eval_expr] says why, and the caller takes the same [held]
around this that it takes around one. *)
t.program <-
{ t.program with Tast.fns = t.program.Tast.fns @ fresh };
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
where, Types.to_string shown.Tast.ty))))
@ -2412,7 +2418,7 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
in
let extra = ref [] and nslots = ref (Array.length base) in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2453,17 +2459,22 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
slots = Array.append base (Array.of_list (List.rev !extra));
snames = Array.append bnames (Array.make (List.length !extra) None) }
in
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program =
{ t.program with
Tast.fns =
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ];
structs = t.program.Tast.structs @ copies;
externs = t.program.Tast.externs @ externs }
in
let ir =
redefinition t ~call:tname program
~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ])
in
t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh };
t.program <-
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
List.map Types.to_string params)
@ -2496,7 +2507,7 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
let loc = Loc.unknown in
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2682,7 +2693,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
appended past [base] and collected here to size the frame below. *)
let extra = ref [] and nslots = ref (Array.length base) in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2728,10 +2739,12 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
let placed =
List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed
in
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program =
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh @ placed;
structs = t.program.Tast.structs @ Check.env_structs t.env lifted;
structs =
t.program.Tast.structs @ copies @ Check.env_structs t.env lifted;
externs = t.program.Tast.externs @ externs }
in
let ir =
@ -2757,7 +2770,10 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
caller closes that half by taking a [held] before this and restoring it
when either fails — a copy the session holds and no module defines is a
null cell exactly as a stranded declaration is. *)
t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh };
t.program <-
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
{ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }
(* ── What a macro call expands to ──────────────────────────────────── *)

119
lib/shim.ml
View File

@ -177,6 +177,106 @@ let prim_cty = function
| "bool" -> Some "bool"
| _ -> None
(* ── Generic structs ──────────────────────────────────────────────────
A defstruct whose fields introduce [$t] is a template, and C only ever sees
one of its copies: the fields with the arguments written in, laid out the
way [Check] lays the same copy out. The copy is registered here under its
written spelling, [(G u8)], which [ctype_name] turns into a C name. *)
let sigil n = n <> "" && n.[0] = '$'
let bare n = if sigil n then String.sub n 1 (String.length n - 1) else n
(* A template's parameters, in the order its fields first introduce them, and
whether each is a length — [Check]'s reading, repeated over the AST
because this runs before [Check] does. *)
let rec template_params ?(fuel = 16) env n =
match Hashtbl.find_opt env.structs n with
| None -> []
| Some fs ->
let acc = ref [] in
let add m is_len =
if sigil m && not (List.mem_assoc (bare m) !acc) then
acc := (bare m, is_len) :: !acc
in
let rec walk (t : Ast.texpr) =
match t.Ast.t with
| Ast.Tname m -> add m false
| Ast.Tslice (_, e) -> walk e
| Ast.Tarray (Ast.Lname m, e) -> add m true; walk e
| Ast.Tarray (_, e) -> walk e
| Ast.Tmap (k, v) -> walk k; walk v
| Ast.Tapp (h, args) ->
let kinds =
if fuel = 0 || String.equal h n then []
else List.map snd (template_params ~fuel:(fuel - 1) env h)
in
if List.length kinds = List.length args then
List.iter2
(fun is_len (a : Ast.texpr) ->
match a.Ast.t with
| Ast.Tname m when is_len -> add m true
| _ -> walk a)
kinds args
else List.iter walk args
| Ast.Tfn (_, ps, r) -> List.iter walk ps; walk r
| Ast.Tlen _ -> ()
in
List.iter (fun (f : Ast.field) -> walk f.Ast.fty) fs;
List.rev !acc
let rec source (t : Ast.texpr) =
match t.Ast.t with
| Ast.Tname n -> n
| Ast.Tlen n -> Int64.to_string n
| Ast.Tapp (n, args) ->
Printf.sprintf "(%s %s)" n (String.concat " " (List.map source args))
| Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (source e)
| Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (source e)
| Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (source e)
| Ast.Tmap (k, v) -> Printf.sprintf "(Map %s %s)" (source k) (source v)
| Ast.Tfn (env, ps, r) ->
Printf.sprintf "(%s [%s] %s)" (if env then "Fn" else "CFn")
(String.concat " " (List.map source ps)) (source r)
(* The copy of template [n] at [args], registered and named. *)
let copy env ~loc n (args : Ast.texpr list) =
let ps = template_params env n in
if List.length ps <> List.length args then
fail loc "%s takes %d argument%s, and this gives %d" n (List.length ps)
(if List.length ps = 1 then "" else "s") (List.length args);
let key = source { Ast.t = Ast.Tapp (n, args); tloc = loc } in
if not (Hashtbl.mem env.structs key) then begin
let sub = List.combine (List.map fst ps) args in
let rec go (t : Ast.texpr) =
let k =
match t.Ast.t with
| Ast.Tname m when List.mem_assoc (bare m) sub ->
(List.assoc (bare m) sub).Ast.t
| Ast.Tname _ | Ast.Tlen _ -> t.Ast.t
| Ast.Tslice (c, e) -> Ast.Tslice (c, go e)
| Ast.Tarray (Ast.Lname m, e) when List.mem_assoc (bare m) sub ->
let l =
match (List.assoc (bare m) sub).Ast.t with
| Ast.Tlen k -> Ast.Lint k
| Ast.Tname c -> Ast.Lname c
| _ -> fail loc "%s's $%s is a length" n (bare m)
in
Ast.Tarray (l, go e)
| Ast.Tarray (l, e) -> Ast.Tarray (l, go e)
| Ast.Tmap (k, v) -> Ast.Tmap (go k, go v)
| Ast.Tapp (h, a) -> Ast.Tapp (h, List.map go a)
| Ast.Tfn (b, ps, r) -> Ast.Tfn (b, List.map go ps, go r)
in
{ t with Ast.t = k }
in
Hashtbl.replace env.structs key
(List.map (fun (f : Ast.field) -> { f with Ast.fty = go f.Ast.fty })
(Hashtbl.find env.structs n))
end;
key
let is_template env n = template_params env n <> []
(* [needed] collects the structs whose typedefs this signature pulls in, in the
order they were first met. Order is the program's and never a hash fold's:
the object cache keys on the generated text, so a reordering would be a
@ -184,6 +284,14 @@ let prim_cty = function
let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
let t = unalias env t in
match t.Ast.t with
| Ast.Tname n when Hashtbl.mem env.structs n && is_template env n ->
fail loc "%s is %s, a generic struct, which is a type only at its \
arguments — write them, as in (%s %s)" what n n
(String.concat " "
(List.map (fun (_, l) -> if l then "8" else "i32")
(template_params env n)))
| Ast.Tapp (n, args) when Hashtbl.mem env.structs n && is_template env n ->
cty env ~needed ~loc ~what { t with Ast.t = Ast.Tname (copy env ~loc n args) }
| Ast.Tname n ->
(match prim_cty n with
| Some c -> c
@ -256,6 +364,7 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
fail loc "%s is a function type, and a C callback is not implemented" what
| Ast.Tapp (n, _) ->
fail loc "%s is %s, which is not a type this shim generator knows" what n
| Ast.Tlen n -> fail loc "%s is %Ld, which is not a type" what n
(* ── What one parameter does at the boundary ────────────────────────── *)
@ -268,6 +377,14 @@ let classify env ~needed ~loc ~what (t : Ast.texpr) =
let t' = unalias env t in
match t'.Ast.t with
| Ast.Tname "string" -> (Pstr, "const char *")
(* A copy crosses behind a pointer only: by value, the Flan half this
generator writes would have to spell the copy's type, and it builds its
wrapper from struct names. *)
| Ast.Tapp (n, _) when Hashtbl.mem env.structs n && is_template env n ->
fail loc
"%s is %s, a generic struct's copy, which crosses to C behind a pointer \
only — declare (Ptr %s) and let the C side read it"
what (source t') (source t')
| Ast.Tname n when Hashtbl.mem env.structs n ->
ignore (cty env ~needed ~loc ~what t');
(Pstruct n, ctype_name n)
@ -545,6 +662,8 @@ let typedefs env needed =
(fun (f : Ast.field) ->
match (unalias env f.Ast.fty).Ast.t with
| Ast.Tname m when Hashtbl.mem env.structs m -> define m
| Ast.Tapp (m, args) when Hashtbl.mem env.structs m && is_template env m ->
define (copy env ~loc:f.Ast.floc m args)
| _ -> ())
fs;
Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n;

37
lib/types.ml
View File

@ -106,6 +106,15 @@ type t =
| Fn of t list * t (* (Fn [T ...] R) *)
| CFn of t list * t (* (CFn [T ...] R) *)
| Var of string (* a type variable — milestone 5 *)
(* The two halves of a length parameter, and neither is the type of a value.
[Len] is a length standing where a generic struct's argument goes — the 8
in (Small 8 i32) — and what a length variable is bound to. [LArray] is a
fixed array whose length is a variable, [[$n $t]], and exists only in a
generic signature, as the pattern a call site binds [n] from. A generic
body is checked with its lengths at [Check.abstract_len], so neither ever
reaches a backend. *)
| Len of int64
| LArray of string * t
(* [dyn]: one machine word whose contents the runtime knows and this module
does not. It is a written type — [(defonce x dyn 5)] boxes the 5 — and it
is also what an unannotated [defn] parameter means, which is why it is a
@ -206,8 +215,29 @@ let rec equal a b =
&& List.for_all2 equal ps ps'
&& equal r r'
| Var x, Var y -> String.equal x y
| Len x, Len y -> Int64.equal x y
| LArray (n, x), LArray (m, y) -> String.equal n m && equal x y
| _ -> false
(* How a generic struct's copy is spelled to a reader. The copy is an
ordinary struct under a symbol-safe key — [Small-8-i32] — and this is the
key's written form, [(Small 8 i32)], filled in as each copy is made. Global
rather than on a checker's env because every message that prints a type
comes through here with no env in hand. The key determines the spelling,
so an entry left from an earlier program in the same process is wrong only
for a struct that program's successor declares under a copy's key by hand,
and then only in how a message spells it. *)
let display : (string, string) Hashtbl.t = Hashtbl.create 16
(* A struct's name as a printed value's head: its own name, or for a generic
struct's copy the template and its arguments, [Pair i32] — so a value
prints as [(Pair i32 {.a 1 .b 2})], the way its type is written. *)
let struct_head n =
match Hashtbl.find_opt display n with
| Some d when String.length d >= 2 && d.[0] = '(' ->
String.sub d 1 (String.length d - 2)
| _ -> n
let rec to_string = function
| Int k -> ikind_name k
| Float k -> fkind_name k
@ -215,7 +245,8 @@ let rec to_string = function
| String -> "string"
| Unit -> "()"
| Never -> "Never"
| Named n | Enum n -> n
| Named n -> (match Hashtbl.find_opt display n with Some d -> d | None -> n)
| Enum n -> n
| Slice (Mut, t) -> "[" ^ to_string t ^ "]"
| Slice (Const, t) -> "[const " ^ to_string t ^ "]"
| Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t)
@ -231,7 +262,9 @@ let rec to_string = function
| CFn (ps, r) ->
Printf.sprintf "(CFn [%s] %s)"
(String.concat " " (List.map to_string ps)) (to_string r)
| Var n -> n
| Var n -> "$" ^ n
| Len n -> Int64.to_string n
| LArray (n, t) -> Printf.sprintf "[$%s %s]" n (to_string t)
| Dyn -> "dyn"
let is_numeric = function Int _ | Float _ -> true | _ -> false

1
lib/x86.ml
View File

@ -533,6 +533,7 @@ let is_agg (t : Types.t) =
the arithmetic. *)
| Types.Dyn -> false
| Types.Var v -> unsupported "type variable %s" v
| Types.Len _ | Types.LArray _ -> unsupported "length variable"
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false

109
test/programs/generic-struct.flan Normal file
View File

@ -0,0 +1,109 @@
;;;; Generic structs, end to end: type parameters and length parameters.
;;;;
;;;; A defstruct whose fields introduce $t is a template, and each set of
;;;; arguments it is given is a copy — an ordinary struct. A parameter is a
;;;; length when it stands in an array's length slot, and a type anywhere else;
;;;; the arguments are written in the order the fields first introduce them.
;;;;
;;;; Small is Odin's Small_Array: a fixed-capacity array with a count, and no
;;;; allocation anywhere.
(defstruct Small [items [$n $t] count i32])
;; A generic function over a generic struct binds both of its parameters from
;; the argument, and reads the length back as a value.
(defn append! [s (Ptr (Small $n $t)) x $t] bool
(if (< (.count s) n)
(do (set (at (.items s) (.count s)) x)
(set (.count s) (+ (.count s) 1))
true)
false))
;; One generic over the struct calling another at its own variables.
(defn append-all! [s (Ptr (Small $n $t)) xs [$t]] ()
(dotimes [i (length xs)]
(append! s (at xs i))))
(defn pop! [s (Ptr (Small $n $t))] (Option $t)
(if (= (.count s) 0)
None
(do (set (.count s) (- (.count s) 1))
(Some (at (.items s) (.count s))))))
(defn capacity [s (Ptr (Small $n $t))] i32 n)
(defn total [s (Ptr (Small $n $t))] $t {:where (numeric? $t)}
(let [acc (the $t 0)]
(dotimes [i (.count s)]
(set acc (+ acc (at (.items s) i))))
acc))
;; A type parameter alone, built positionally with the type read off the
;; fields, and returned under a variable.
(defstruct Pair [a $t b $t])
(defn swapped [p (Pair $t)] (Pair $t) (Pair (.b p) (.a p)))
;; A copy that names itself through a pointer, and a literal field that
;; takes its width from the one beside it.
(defstruct Node [v $t next (Option (Ptr (Node $t)))])
(defn sum-list [n (Ptr (Node i64))] i64
(loop [at n acc (the i64 0)]
(let [acc (+ acc (.v at))]
(match (.next at)
(Some p) (recur p acc)
None acc))))
;; A template naming another at its own parameters.
(defstruct Twice [x (Small $m $u) y (Small $m $u)])
;; A copy as a map key, and a named function over one handed where a
;; function value is wanted.
(defn pair-sum [p (Pair i32)] i32 (+ (.a p) (.b p)))
(defn apply-to [f (Fn [(Pair i32)] i32) p (Pair i32)] i32 (f p))
;; A length variable straight on an array parameter.
(defn len-of [a [$k $e]] i32 k)
(defconst cap 3)
(defn main [] i32
(let [s (the (Small 4 i32) (zeroed))
f (the (Small cap f64) (zeroed))]
(append! (addr s) 10)
(append! (addr s) 20)
(append! (addr s) 30)
(println (total (addr s)) (.count s) (capacity (addr s)))
(append! (addr f) 1.5)
(append! (addr f) 2.5)
(append! (addr f) 3.5)
(println (append! (addr f) 4.5) (total (addr f)) (capacity (addr f)))
(println (pop! (addr f)) (pop! (addr f)) (.count f))
(let [p (Pair 1 2)
q (swapped p)
r (swapped (Pair {.a 1.5 .b 2.5}))]
(println (.a q) (.b q) (.a r) (.b r))
(println q (Pair 1 2.5)))
(let [c (the (Node i64) {.v 3})
b (Node 2 (Some (addr c)))
a (Node 1 (Some (addr b)))]
(println (sum-list (addr a))))
(let [w (the (Twice 2 u8) (zeroed))]
(append! (addr (.y w)) 7)
(println (.count (.x w)) (.count (.y w)) (capacity (addr (.x w)))))
(println (len-of [1 2 3]) (len-of [1.5 2.5]))
(let [v (vec-new (Pair i32))]
(push v (Pair 5 6))
(println (.b (at v 0)))
(free v))
(let [t (the (Small 5 i64) (zeroed))
xs (the [3 i64] [1 2 3])]
(append-all! (addr t) (slice xs))
(println (total (addr t)) (.count t)))
(let [m (map-new (Pair i32) i32)]
(put m (Pair 1 2) 12)
(put m (Pair 3 4) 34)
(println (get m (Pair 3 4)) (get m (Pair 2 1)) (apply-to pair-sum (Pair 7 8)))
(free m))
0))

49
test/test_acceptance.ml
View File

@ -3523,6 +3523,19 @@ let () =
outputs "generics" "programs/generics.flan" generics_out;
outputs ~opt:"-O0" "generics, -O0" "programs/generics.flan" generics_out;
(* Generic structs — see the program's header. The third line is two pops
printed in one call, which is also the pin for a printed call being
evaluated once: the walk reads an option's tag and then its payload,
and each read used to make the call again. *)
let generic_struct_out =
"60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n\
(Pair i32 {.a 2 .b 1}) (Pair f64 {.a 1 .b 2.5})\n6\n\
0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n"
in
outputs "generic structs" "programs/generic-struct.flan" generic_struct_out;
outputs ~x86:true "generic structs, --x86" "programs/generic-struct.flan"
generic_struct_out;
(* integer?, end to end — see the program's own header. The first eight
lines are the collapsed abs at six widths and both signed minimums
(which answer themselves; the negation wraps). The [0 0] after them is
@ -3665,7 +3678,7 @@ let () =
chain of instantiations and not a depth it gave up at. *)
refuses "an unconstrained operator in a generic body"
"programs/generic-reject.flan"
"nothing declares t numeric?";
"nothing declares $t numeric?";
refuses "an unconstrained operator names the way out"
"programs/generic-reject.flan" "{:where (numeric? $t)}";
refuses "a runaway instantiation" "programs/generic-runaway.flan"
@ -4279,6 +4292,36 @@ level "1"
end
in
let v2 = "(defstruct Vector2 [x f32 y f32])\n" in
(* A generic struct's copy crosses behind a pointer, as a typedef of its
own with the arguments written in, and one held by value inside a
struct is defined before that struct. clang reads the text, so the
typedef is C and not only a spelling. *)
let gsrc =
"(defstruct G [x $t count i32])\n\
(defstruct O [v i32 inner (G u8)])\n\
(declare-c c-g [s (Ptr (G u8))] i32 \"c_g\")\n\
(declare-c c-o [o (Ptr O)] i32 \"c_o\")\n"
in
shim_case "declare-c: a generic struct's copy crosses behind a pointer" gsrc
[ "/* (G u8) */\n uint8_t x;\n int32_t count;\n"; "inner;\n" ];
(match shim_of gsrc with
| c ->
let file = Filename.temp_file "flan-shim-generic" ".c" in
let oc = open_out file in
output_string oc c;
close_out oc;
if Sys.command (Printf.sprintf "clang -fsyntax-only %s" (Filename.quote file)) <> 0
then begin
incr failures;
print_endline "FAIL declare-c: a generic struct's copy is C clang accepts"
end;
Sys.remove file
| exception Loc.Error _ -> ());
shim_refuses "declare-c: a generic struct's copy by value"
"(defstruct G [x $t])\n(declare-c c-v [s (G u8)] i32 \"c_v\")"
"crosses to C behind a pointer only";
let img =
"(defstruct Image [data (Ptr u8) width i32 height i32])\n"
in
@ -4785,10 +4828,10 @@ level "1"
the easier of the two to leave open. *)
refuses "a nested function type does not widen"
"programs/fn-generic-nested.flan"
"hof expects (Fn [(Fn [t] t)] i32) here";
"hof expects (Fn [(Fn [$t] $t)] i32) here";
refuses "and neither does one in return position"
"programs/fn-generic-nested-return.flan"
"call-twice expects (Fn [] (Fn [] t)) here";
"call-twice expects (Fn [] (Fn [] $t)) here";
outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan"
fn_capture_out;

22
test/test_dev.ml
View File

@ -802,6 +802,28 @@ let () =
| Some { Form.v = Form.Sym "t"; _ } -> ()
| _ -> fail "an expression against the park reported the program live");
(* A generic struct's copy prints the way its type is written, with the
arguments after the template's name, and [layout] answers to that
spelling. *)
let r =
request c
"(:op \"eval\" :code \"(defstruct GPair [a $t b $t])\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "a generic struct at the daemon: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
let r =
request c
"(:op \"eval-expr\" :code \"(GPair 1 2)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "(GPair i32 {.a 1 .b 2})" then
fail "a generic struct's copy printed as %s"
(Option.value ~default:(status r) (Wire.string_field r "value"));
let r = request c "(:op \"layout\" :type \"GPair i32\")" in
if Wire.string_field r "type" <> Some "(GPair i32)" then
fail "layout of a copy by its printed head: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* And the half that needs the process rather than only the compiler.
[extra] is a global this session introduced and the first run left at
105 — the third reload's [step] does not touch it — so this is the

235
test/test_flan.ml
View File

@ -1417,7 +1417,7 @@ let () =
accepts "all-distinct over a type variable"
"(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))";
rejects_check "a chain still wants the right predicate"
~needle:"nothing declares t ordered?"
~needle:"nothing declares $t ordered?"
"(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))";
(* One operand and none. Both would have to be [true] whatever they were
handed, which is a typo carrying a value. *)
@ -1470,10 +1470,10 @@ let () =
can actually be written there; the parameter-vector suggestion survives
where it works, which the return-type pin further down exercises. *)
rejects_check "a real type variable at a field" "(defstruct Holder [x elem])"
~needle:"a field is built at one type for every value";
~needle:"in a defstruct's fields that makes the struct generic over it";
rejects_check "and the field message offers what a field can hold"
"(defstruct Holder [x elem])"
~needle:"Write a concrete type here, or dyn to hold any value";
~needle:"Write $elem, a concrete type, or dyn to hold any value";
rejects_check "an unknown concrete type" "(defn f [x Widget] ())"
~needle:"unknown type Widget";
@ -2873,13 +2873,11 @@ let () =
(* [(Pair i32)] in a defonce falls down the value fork now that the third
element takes either reading, and the generics answer the type fork gave
it has to be reachable from here too. *)
(* A capitalised head with arguments is a *type* given type arguments, and
that is the half of generics that is not built — Types.Named is a bare
string with no room for parameters. The sentence says which half, since
generic functions are here and pointing at them is the useful part. *)
(* A capitalised head with arguments is a *type* given type arguments; with
no such struct declared, the sentence says how one is. *)
rejects_check "a capitalised call with arguments is a generic type"
"(defonce x (Pair i32)) (defn f [] i32 0)"
~needle:"is a generic type, which is not there yet";
~needle:"no struct or generic struct Pair is declared";
accepts "and the generic function it points at is"
"(defn pair-fst [a $t b $u] $t (do b a))\n\
(defn main [] () (println (pair-fst 1 true)))";
@ -6187,6 +6185,110 @@ let () =
check "and they are in source order"
(List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ]));
(* A generic whose abstract pass was refused is not checked again at each
copy: the refusal is one error, however many types call it, and the
caller's own later refusal is still found. *)
(match
Check.program_all
(Parse.program_all
(read "(defn g [x $t] u64 (nosuch x))\n\
(defn main [] i32 (g 3) (g true) nope 0)\n"))
with
| _ -> check "a refused generic body is refused" false
| exception Loc.Errors ds ->
check "a refused generic body is one error, and its caller's is another"
(List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2 ]));
(* A refusal inside a copy names the call that asked for it, and each copy
between: the chain walks back to the line the programmer wrote. *)
(match
checked
"(defn show [v $t] () (println v)) \
(defn outer [v $t] () (show v)) \
(defn main [] i32 (outer main) 0)"
with
| _ -> check "a copy with no printer is refused" false
| exception Loc.Error d ->
let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in
check "a refusal in a copy names both instantiations"
(contains d.Loc.dmsg "no printer for"
&& notes
= [ "show is instantiated at $t = (CFn [] i32) here";
"outer is instantiated at $t = (CFn [] i32) here" ]));
(* A refusal made while collecting declarations — a generic struct that
holds itself, one that grows without end, a where clause over a length —
is one error among the rest of the file's, not the end of the check. *)
let all_lines src =
match Check.program_all (Parse.program_all (read src)) with
| _ -> []
| exception Loc.Errors ds ->
List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds
in
check "a self-containing generic struct is one error of several"
(all_lines
"(defstruct Loop [next (Loop $t)])\n\
(defn g [] i32 (let [p (the (Loop i32) (zeroed))] nope1))\n\
(defn h [] i32 nope2)\n"
= [ 1; 2; 3 ]);
check "a generic struct that grows without end is one error of several"
(all_lines
"(defstruct Grow [next (Ptr (Grow [$t]))])\n\
(defn g [] i32 (let [p (the (Grow i32) (zeroed))] nope1))\n\
(defn h [] i32 nope2)\n"
= [ 1; 2; 3 ]);
check "a where clause over a length is one error of several"
(all_lines
"(defn f [a [$n i32]] i32 {:where (numeric? $n)} nope1)\n\
(defn h [] i32 nope2)\n"
= [ 1; 1; 2 ]);
(* A literal that does not fit what a typed field decided names that field. *)
(match
checked
"(defstruct Pair [a $t b $t]) \
(defn main [] i32 (let [p (Pair (the i32 1) 2.5)] 0))"
with
| _ -> check "a float literal where a typed field decided i32" false
| exception Loc.Error d ->
check "the refusal names the field that decided the variable"
(contains d.Loc.dmsg "Pair's .b is $t, which is i32 here"
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg ".a is i32 here, which decides $t")
d.Loc.notes));
(* A copy that cannot be built at a closure's type: the zeroed value in the
body is refused there, and the call that asked is named. *)
(match
checked
"(defn blank [x $t] $t (let [z (the $t (zeroed))] z)) \
(defn use-it [f (Fn [i32] i32)] i32 (blank f) 0)"
with
| _ -> check "a zeroed closure in a copy is refused" false
| exception Loc.Error d ->
check "a copy at a closure type names the call that asked"
(List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "blank is instantiated at $t = (Fn [i32] i32) here")
d.Loc.notes));
(* A prelude generic's body is nobody's source at the call: the refusal is
at the call, and the prelude's line is a note. *)
(match
checked
"(defn keep [g (Vec u8)] bool true) \
(defn use-it [xs [(Vec u8)]] i32 (length (filter xs keep)))"
with
| _ -> check "a prelude copy that cannot be built is refused" false
| exception Loc.Error d ->
check "a prelude copy's refusal is at the user's call"
(d.Loc.dloc.Loc.file <> Prelude.file
&& contains d.Loc.dmsg "filter cannot be made at $t = (Vec u8)"
&& not (contains d.Loc.dmsg "clone")
&& List.exists
(fun (n : Loc.note) -> n.Loc.nloc.Loc.file = Prelude.file)
d.Loc.notes));
(* The parser resynchronises on a top-level form, so two bad declarations are
two errors rather than one. *)
(match Parse.program_all (read "(defn a)\n(defn b)\n") with
@ -6245,7 +6347,7 @@ let () =
accepts "numeric? admits +"
"(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))";
rejects_check "equal? does not admit <"
~needle:"nothing declares t ordered?"
~needle:"nothing declares $t ordered?"
"(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))";
(* The entailments, which are the reason a signature is one predicate long
rather than two. Every type the language orders is a number or an enum,
@ -6273,10 +6375,10 @@ let () =
accepts "integer? admits the shifts"
"(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))";
rejects_check "numeric? does not admit bit-and"
~needle:"nothing declares t integer?"
~needle:"nothing declares $t integer?"
"(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))";
rejects_check "nor the shifts"
~needle:"nothing declares t integer?"
~needle:"nothing declares $t integer?"
"(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))";
(* An integer?-bounded caller satisfies a numeric?-bounded callee: the
entailment carries across generic calls exactly as ordered?-over-equal?
@ -6879,19 +6981,118 @@ let () =
bound, because inside a signature that introduces one the mistake is
nearly always the second spelling of the first. *)
rejects_check "vec-new over a sigil that names no variable in scope"
~needle:"this signature introduces t, so write t here"
~needle:"this signature introduces $t, so write $t here"
"(defn f [x $t] i32 (do x (let [v (vec-new $u)] (free v) 0)))";
rejects_check "and a cast over one tells the same story"
~needle:"this signature introduces t, so write t here"
~needle:"this signature introduces $t, so write $t here"
"(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($u x)))";
rejects_check "two variables in scope are both named"
~needle:"introduces t and u, so write one of those"
~needle:"introduces $t and $u, so write one of those"
"(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))";
(* Where no variable is in scope there is none to name, and the answer is
the rule: a sigil binds, and only a defn signature is a binding site. *)
rejects_check "a sigil in a struct field, where nothing can bind one"
~needle:"only a defn signature can"
"(defstruct S [v $t])";
rejects_check "a sigil in a data case's field, where nothing can bind one"
~needle:"only a defn signature or a defstruct's fields can"
"(defdata D [(C [v $t])])";
(* ── Generic structs: what is refused, and where ─────────────────── *)
rejects_check "a generic struct given the wrong number of arguments"
~needle:"Pair takes 1 argument, (Pair $t), and this gives 2"
"(defstruct Pair [a $t b $t]) (defn f [p (Pair i32 i64)] i32 0)";
rejects_check "a generic struct named with no arguments"
~needle:"Pair is generic, and a type only once it is given its arguments"
"(defstruct Pair [a $t b $t]) (defn f [p Pair] i32 0)";
rejects_check "a type where a length argument goes"
~needle:"Small's $n is a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small i32 4)] i32 0)";
rejects_check "a length where a type argument goes"
~needle:"Small's $t is a type, and 4 is a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small 4 4)] i32 0)";
rejects_check "a negative length argument"
~needle:"-1 is negative"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small -1 i32)] i32 0)";
rejects_check "one variable as both a length and a type"
~needle:"$t stands for a length in one place here and a type in another"
"(defstruct Bad [x $t y [$t i32]])";
rejects_check "a length variable where a type goes"
~needle:"n is a length, not a type"
"(defn f [a [$n i32]] i32 (let [x (the n 0)] 0))";
rejects_check "a where clause over a length variable"
~needle:"$n is a length, and a where clause takes type predicates only"
"(defn f [a [$n i32]] i32 {:where (numeric? $n)} 0)";
rejects_check "a generic struct that contains itself by value"
~needle:"(Loop $t) contains itself by value"
"(defstruct Loop [next (Loop $t)])";
rejects_check "a generic struct that asks for bigger copies of itself"
~needle:"Grow names a copy of itself at a type built around its own"
"(defstruct Grow [next (Ptr (Grow [$t]))]) (defn f [p (Grow i32)] i32 0)";
rejects_check "a copy whose key is already a struct's name"
~needle:"Pair at these arguments is called Pair-i32, and Pair-i32 is \
already defined"
"(defstruct Pair [a $t b $t]) (defstruct Pair-i32 [x i32]) \
(defn f [p (Pair i32)] i32 0)";
rejects_check "a generic struct literal whose fields decide nothing"
~needle:"Pair's $t is not decided by the fields given here"
"(defstruct Pair [a $t b $t]) (defn f [] i32 (let [p (Pair {})] 0))";
rejects_check "two fields that disagree about the variable"
~needle:"(Pair $t)'s .b is i32 here, and this is f64"
"(defstruct Pair [a $t b $t]) \
(defn f [] i32 (let [p (Pair (the i32 1) (the f64 2.5))] 0))";
accepts "a literal field takes its width from a typed one beside it"
"(defstruct Pair [a $t b $t]) \
(defn f [] f64 (let [p (Pair 1 (the f64 2.5))] (.a p)))";
rejects_check "a generic struct as a condition"
~needle:"Pair is generic, and a condition struct is not"
"(defstruct Pair :parent Error [a $t])";
rejects_check "an operator a generic body's struct field does not support"
~needle:"+ over the type variable $t"
"(defstruct Pair [a $t b $t]) (defn f [p (Pair $t)] $t (+ (.a p) (.b p)))";
accepts "the same body with the predicate declared"
"(defstruct Pair [a $t b $t]) \
(defn f [p (Pair $t)] $t {:where (numeric? $t)} (+ (.a p) (.b p))) \
(defn main [] i32 (f (Pair 1 2)))";
accepts "a copy wanted where it is built takes its type from there"
"(defstruct Pair [a $t b $t]) (defn f [] (Pair i64) (Pair 1 2))";
(* A copy whose field is refused names each use that asked for it. *)
(match
checked
"(defstruct Box [f $t]) (defstruct Outer [b (Box $w)]) \
(defn go [g (Fn [i32] i32)] i32 \
(.x (the (Outer (Fn [i32] i32)) (zeroed))) 0)"
with
| _ -> check "a copy with a zeroed function field is refused" false
| exception Loc.Error d ->
let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in
check "a refused copy names each use that made it"
(List.mem "(Box (Fn [i32] i32)) is made here" notes
&& List.mem "(Outer (Fn [i32] i32)) is made here" notes));
rejects_check "a bare generic struct in ordinary code suggests real arguments"
~needle:"write (Pair i32)"
"(defstruct Pair [a $t b $t]) (defn main [] i32 (let [p (the Pair (zeroed))] 0))";
rejects_check "a generic struct applied to nothing"
~needle:"Pair takes 1 argument, (Pair $t), and this gives 0"
"(defstruct Pair [a $t b $t]) \
(defn main [] i32 (let [p (the (Pair) (zeroed))] 0))";
rejects_check "a length argument that is not one"
~needle:"(+ n 1) is not a type or a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn main [] i32 (let [n 3 p (the (Small (+ n 1) i32) (zeroed))] 0))";
accepts "a length argument of literal arithmetic is folded"
"(defstruct Small [items [$n $t] count i32]) \
(defn main [] i32 (let [p (the (Small (+ 1 2) i32) (zeroed))] \
(length (.items p))))";
accepts "two literal fields meet at the wider type"
"(defstruct Pair [a $t b $t]) \
(defn f [] f64 (let [p (Pair 1 2.5)] (+ (.a p) (.b p))))";
rejects_check "a callee's predicate names the caller's variable with its $"
~needle:"passes the type variable $t, which nothing here declares ordered?"
"(defn f [s [$t]] () (sort s))";
accepts "a defonce of a generic struct's copy"
"(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \
(defn main [] i32 (.a g))";
(* ── The builtin table against the arms it describes ──────────────
[Check.builtins] is what the editor's C-c C-v and M-. read for a name no

70
test/test_session.ml
View File

@ -367,6 +367,76 @@ let () =
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "the session was poisoned by a bad expression: %s" m);
(* A generic struct's copy first named by an expression typed at the
session: the module built for it has to lay the copy out, and the
session keeps it, as it keeps a generic function's copy. *)
(let gt, _ = Session.create ~file:"programs/reload.flan" () in
(match Session.eval gt "(defstruct Pair [a $t b $t])" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a generic struct was refused at the session: %s" m);
match Session.eval_expr gt "(println (.b (Pair 7 8)))" with
| e ->
if not (has e.Session.ir "%\"Pair-i32\" = type") then
fail "the expression's module did not carry the struct copy";
if not
(List.exists
(fun (s : Tast.structure) -> String.equal s.Tast.sname "Pair-i32")
gt.Session.program.Tast.structs)
then fail "the session did not keep the struct copy an expression made"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "an expression building a generic struct was refused: %s" m);
(* And the same for the other two modules the break loop builds out of
typed-in values: a store into a frame slot, and a restart's arguments.
A copy first named in one of them is laid out there and kept. *)
(let keeps t what =
List.exists
(fun (s : Tast.structure) -> String.equal s.Tast.sname what)
t.Session.program.Tast.structs
in
let lays_out (c : Session.change) what =
has c.Session.ir ("%\"" ^ what ^ "\" = type")
in
let st, _ = Session.create ~file:"programs/reload.flan" () in
(match Session.eval st "(defstruct Pair [a $t b $t])" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "Pair: %s" m);
(match Session.eval st "(defn holder [] i64 (let [x (the i64 0)] x))" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "holder: %s" m);
let fn =
List.find (fun (f : Tast.fn) -> f.Tast.name = "holder")
st.Session.program.Tast.fns
in
let slot =
let r = ref (-1) in
Array.iteri (fun i n -> if n = Some "x" then r := i) fn.Tast.snames;
!r
in
(match
Session.write_slot st ~frame:0 ~fn ~slot ~path:[]
~edits:[ ([], "(.a (Pair (the i64 5) 6))") ]
with
| Ok (c, _, _) ->
if not (lays_out c "Pair-i64") then
fail "a store's module did not carry the struct copy its value made";
if not (keeps st "Pair-i64") then
fail "the session did not keep the struct copy a store made"
| Error why -> fail "a store building a generic struct was refused: %s" why
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a store building a generic struct was refused: %s" m);
match
Session.arm_restart st ~index:0 ~params:[ Types.Int Types.U16 ]
~codes:[ "(.b (Pair (the u16 5) 6))" ]
with
| Ok (c, _) ->
if not (lays_out c "Pair-u16") then
fail "a restart's module did not carry the struct copy its argument made"
| Error why -> fail "a restart building a generic struct was refused: %s" why
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a restart building a generic struct was refused: %s" m);
(* The other half of "a refusal costs nothing", and the half that used to be
missing: a form can check and *then* fail, in the build or at the agent,
and the session that already accepted it has no way to hear about it