42 lines
1.7 KiB
OCaml
42 lines
1.7 KiB
OCaml
open Tys
|
|
|
|
module FieldsReg = Map.Make(String)
|
|
module FinReg = Map.Make(Int)
|
|
|
|
(* a tag group, which has an underlying type, and a bunch of key-index pairs *)
|
|
type t = loc_span * Literal.int_size * (int FieldsReg.t)
|
|
|
|
let rev_lookup ival ((_, _, frg): t) =
|
|
FieldsReg.filter (fun _ x -> x == ival) frg |> FieldsReg.choose
|
|
|
|
(* check if variant conforms to tag group (=> is subset) *)
|
|
let conforms (type u) (vrrcd: u FieldsReg.t) ((_, _, tfrg): t) =
|
|
let inner k v acc = match (FieldsReg.find_opt k tfrg, acc) with
|
|
| (_, None) -> None
|
|
| (None, _) -> None
|
|
| (Some lhs, Some rhs) -> Some (FinReg.add lhs v rhs)
|
|
in FieldsReg.fold inner vrrcd (Some FinReg.empty)
|
|
|
|
let parse_opt ps =
|
|
let inner ps ((osp, oisz): loc_span * Literal.int_size) =
|
|
let rec inner2 ps frg = match ps.lt with
|
|
| (DotIdent nam, s)::(LLiteral Literal.LNatural nat, _)::(SemiColon, s3)::lt ->
|
|
let ps = { ps with lt; offset = loc_span_end s3; } in
|
|
(if FieldsReg.mem nam frg then
|
|
Yanais_syntax_err (ERecordDupIdent nam, s) |> raise
|
|
else FieldsReg.add nam nat frg |> inner2 ps)
|
|
| (Brace Close, s)::lt ->
|
|
let ps = { ps with lt; offset = loc_span_end s; } in
|
|
((osp, oisz, frg), ps)
|
|
| (k, s)::_ -> Yanais_syntax_err (EUnexpectedToken (XTagGroupItem, k), s) |> raise
|
|
| [] ->
|
|
Yanais_syntax_err (EUnexpectedEof XTagGroupItem, osp) |> raise
|
|
in inner2 ps FieldsReg.empty
|
|
in match ps.lt with
|
|
| (KTagGroup, s1)::(LLiteral Literal.LIntSize isz, _)::(Brace Open, s3)::lt ->
|
|
let ps = { ps with lt; offset = loc_span_end s3; } in
|
|
Some (inner ps (s1, isz))
|
|
| _ -> None
|
|
|
|
let parse ps = require XTagGroup parse_opt ps
|