A generic struct's copy prints as (Pair i32 {...}), crosses to C behind a pointer, names each use that made it when refused, settles literal fields at the wider type, and is laid out by stores and restarts that first name it
This commit is contained in:
parent
a95b4c288e
commit
9d0d42e467
93
lib/check.ml
93
lib/check.ml
@ -79,6 +79,16 @@ let rec slot_text = function
|
||||
| Sclass c -> c
|
||||
| Sopt s -> "(Option " ^ slot_text s ^ ")"
|
||||
|
||||
(* Where [sep] first occurs in [m]. *)
|
||||
let find_sub m sep =
|
||||
let n = String.length m and k = String.length sep in
|
||||
let rec go i =
|
||||
if i + k > n then None
|
||||
else if String.sub m i k = sep then Some i
|
||||
else go (i + 1)
|
||||
in
|
||||
go 0
|
||||
|
||||
(* ── Generic structs ─────────────────────────────────────────────────
|
||||
[(defstruct Small [items [$n $t] count i32])] is a template, not a type.
|
||||
Its parameters are the sigil names its fields introduce, in the order
|
||||
@ -1642,7 +1652,17 @@ and struct_copy env loc name targs =
|
||||
restore ();
|
||||
Hashtbl.remove env.copies key;
|
||||
Hashtbl.remove env.structs key;
|
||||
raise e
|
||||
(* A field refused inside the template says nothing about which use
|
||||
asked for this copy; the note names it, one per level of copies. *)
|
||||
(match e with
|
||||
| Loc.Error d when d.Loc.dloc <> loc ->
|
||||
Loc.raise_diag
|
||||
{ d with
|
||||
Loc.notes =
|
||||
d.Loc.notes
|
||||
@ [ Loc.note loc
|
||||
(Types.to_string (Types.Named key) ^ " is made here") ] }
|
||||
| e -> raise e)
|
||||
end
|
||||
|
||||
(* Does a struct argument still mention a variable? *)
|
||||
@ -1728,12 +1748,12 @@ and resolve_name env ~seen loc n =
|
||||
| [ v ] ->
|
||||
Loc.failk "check/unbound-type-variable" loc
|
||||
"nothing binds the type variable %s — this signature introduces %s, \
|
||||
so write %s here, or a concrete type" n v v
|
||||
so write %s here, or a concrete type" n ("$" ^ v) ("$" ^ v)
|
||||
| vars ->
|
||||
Loc.failk "check/unbound-type-variable" loc
|
||||
"nothing binds the type variable %s — this signature introduces %s, \
|
||||
so write one of those here, or a concrete type"
|
||||
n (String.concat " and " vars))
|
||||
n (String.concat " and " (List.map (fun v -> "$" ^ v) vars)))
|
||||
else
|
||||
match Types.ikind_of_name n with
|
||||
| Some k -> Types.Int k
|
||||
@ -1769,7 +1789,15 @@ and resolve_name env ~seen loc n =
|
||||
~notes:[ Loc.note g.gloc (n ^ " is declared here") ]
|
||||
"%s is generic, and a type only once it is given its arguments: \
|
||||
write (%s %s)" n n
|
||||
(String.concat " " (List.map (fun (p, _) -> "$" ^ p) g.gparams))
|
||||
(* Variables are only an answer where a signature binds them; in
|
||||
ordinary code the example is concrete. *)
|
||||
(String.concat " "
|
||||
(List.map
|
||||
(fun (p, is_len) ->
|
||||
if env.tyvars <> [] then "$" ^ p
|
||||
else if is_len then "8"
|
||||
else "i32")
|
||||
g.gparams))
|
||||
| _ when Hashtbl.mem env.structs n -> Types.Named n
|
||||
(* A data type is [Named] exactly as a struct is: one case in [Types.t]
|
||||
covers both, and which table the name is in is what tells them apart.
|
||||
@ -4056,7 +4084,7 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref =
|
||||
to that is still a refusal rather than a guessed pair. *)
|
||||
| Types.Var v ->
|
||||
Loc.failk "check/generic-map-key" loc
|
||||
"a map keyed by the type variable %s has no hash and no equality here. \
|
||||
"a map keyed by the type variable $%s has no hash and no equality here. \
|
||||
Write {:where (hashable? $%s)} at the head of the body, or write the \
|
||||
operation in a function over the concrete key type and call that" v v
|
||||
| Types.String -> Tast.Rtfn "flan_hash_str", Tast.Rtfn "flan_eq_str"
|
||||
@ -6611,12 +6639,37 @@ and generic_ctor ctx ~want loc name given =
|
||||
| Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true
|
||||
| _ -> false
|
||||
in
|
||||
(* A literal's own type, the one it has with nothing expected of it. *)
|
||||
let literal_type (a : Ast.expr) =
|
||||
match a.Ast.e with
|
||||
| Ast.Float _ -> Types.Float Types.F64
|
||||
| Ast.UInt _ -> Types.Int Types.U64
|
||||
| Ast.Byte _ -> Types.Int Types.U8
|
||||
| _ -> Types.Int Types.I32
|
||||
in
|
||||
let pairs =
|
||||
List.filter (fun (_, a) -> not (literal a)) pairs
|
||||
@ List.filter (fun (_, a) -> literal a) pairs
|
||||
in
|
||||
(* Variables only literals have bound so far: a later literal may widen
|
||||
them, as a generic call's literal arguments meet at the wider type —
|
||||
[(Pair 1 2.5)] is a [(Pair f64)]. *)
|
||||
let lit_only = ref [] in
|
||||
List.iter
|
||||
(fun ((f : Tast.field), (a : Ast.expr)) ->
|
||||
match f.Tast.fty with
|
||||
| Types.Var v when literal a && not (List.mem_assoc v !subst && not (List.mem v !lit_only)) ->
|
||||
let t = (literal_type a) in
|
||||
(match List.assoc_opt v !subst with
|
||||
| None -> subst := (v, t) :: !subst; lit_only := v :: !lit_only
|
||||
| Some b ->
|
||||
(match Types.join b t with
|
||||
| Some j -> subst := (v, j) :: List.remove_assoc v !subst
|
||||
| None ->
|
||||
fail a.Ast.loc "%s's .%s is %s here, and this is %s"
|
||||
(Types.to_string (Types.Named open_key)) f.Tast.fname
|
||||
(Types.to_string b) (Types.to_string t)))
|
||||
| _ ->
|
||||
if open_ty f.Tast.fty
|
||||
&& not (literal a && subst_ty !subst f.Tast.fty |> open_ty |> not)
|
||||
then begin
|
||||
@ -6657,7 +6710,13 @@ and generic_ctor ctx ~want loc name given =
|
||||
"%s's $%s is not decided by the fields given here. Name the \
|
||||
type where the value goes, as in (the (%s %s) ...)"
|
||||
name p name
|
||||
(String.concat " " (List.map (fun (q, _) -> "$" ^ q) g.gparams)))
|
||||
(String.concat " "
|
||||
(List.map
|
||||
(fun (q, is_len) ->
|
||||
if env.tyvars <> [] then "$" ^ q
|
||||
else if is_len then "8"
|
||||
else "i32")
|
||||
g.gparams)))
|
||||
g.gparams
|
||||
in
|
||||
struct_copy env loc name targs)
|
||||
@ -11946,7 +12005,7 @@ and generic_call ctx ~want loc name vars pats pret args =
|
||||
| Some (Types.Var v) when not (declares ctx.env.tvpreds v p.Ast.pname) ->
|
||||
Loc.failk "check/predicate-not-carried" loc
|
||||
"%s is written {:where (%s $%s)}, and this call passes the \
|
||||
type variable %s, which nothing here declares %s. Add \
|
||||
type variable $%s, which nothing here declares %s. Add \
|
||||
{:where (%s $%s)} to this function's own clause"
|
||||
name p.Ast.pname p.Ast.pvar v p.Ast.pname p.Ast.pname v
|
||||
| Some t when not (open_ty t) && not (pred_holds p.Ast.pname t) ->
|
||||
@ -12064,17 +12123,29 @@ and instantiate env loc gname vars subst cparams cret =
|
||||
asked for the copy, and the prelude's line comes along as a
|
||||
note. *)
|
||||
| Loc.Error d when in_prelude d.Loc.dloc && not (in_prelude loc) ->
|
||||
(* Only the reason comes along. The rest of the body's message is
|
||||
a fix to the body, which the caller cannot make. *)
|
||||
let reason =
|
||||
let cut sep m =
|
||||
match find_sub m sep with
|
||||
| Some i -> String.sub m 0 i
|
||||
| None -> m
|
||||
in
|
||||
cut ". " (cut " — " d.Loc.dmsg)
|
||||
in
|
||||
Loc.Error
|
||||
(Loc.sort_notes
|
||||
{ d with
|
||||
Loc.dloc = loc;
|
||||
dmsg =
|
||||
Printf.sprintf "%s cannot be made at %s. In its body: %s"
|
||||
gname (at ()) d.Loc.dmsg;
|
||||
Printf.sprintf
|
||||
"%s cannot be made at %s: its body in the prelude does \
|
||||
not compile at that type. Pass a value of a type it \
|
||||
takes, or write the operation here"
|
||||
gname (at ());
|
||||
notes =
|
||||
d.Loc.notes
|
||||
@ [ Loc.note d.Loc.dloc
|
||||
"the refusal is here, in the prelude" ];
|
||||
@ [ Loc.note d.Loc.dloc ("in the prelude, " ^ reason) ];
|
||||
expansion = None })
|
||||
| Loc.Error d when d.Loc.dloc <> loc ->
|
||||
Loc.Error
|
||||
|
||||
12
lib/dev.ml
12
lib/dev.ml
@ -1920,13 +1920,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
|
||||
|
||||
50
lib/parse.ml
50
lib/parse.ml
@ -73,6 +73,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
|
||||
@ -135,23 +145,41 @@ 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 <> [] ->
|
||||
| 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 =
|
||||
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 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 with
|
||||
| Int n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc }
|
||||
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))
|
||||
|
||||
@ -333,7 +333,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 ("(" ^ Types.struct_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
|
||||
|
||||
@ -1543,7 +1543,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 [];
|
||||
@ -1655,7 +1655,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 [];
|
||||
@ -1916,7 +1916,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 [];
|
||||
@ -2233,7 +2233,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 =
|
||||
@ -2270,11 +2270,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 =
|
||||
@ -2287,7 +2291,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))))
|
||||
@ -2359,7 +2365,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 [];
|
||||
@ -2400,17 +2406,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)
|
||||
@ -2443,7 +2454,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 [];
|
||||
@ -2564,7 +2575,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) 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 [];
|
||||
|
||||
118
lib/shim.ml
118
lib/shim.ml
@ -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
|
||||
@ -269,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)
|
||||
@ -546,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;
|
||||
|
||||
@ -229,6 +229,15 @@ let rec equal a b =
|
||||
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
|
||||
|
||||
@ -83,7 +83,8 @@
|
||||
(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 (.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)))]
|
||||
|
||||
@ -3471,7 +3471,8 @@ let () =
|
||||
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\n6\n\
|
||||
"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;
|
||||
@ -4229,6 +4230,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
|
||||
|
||||
@ -628,6 +628,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
|
||||
|
||||
@ -6044,6 +6044,7 @@ let () =
|
||||
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));
|
||||
@ -6720,13 +6721,13 @@ 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. *)
|
||||
@ -6795,6 +6796,40 @@ let () =
|
||||
(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))";
|
||||
|
||||
@ -374,6 +374,56 @@ let () =
|
||||
| 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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user