+ (* The shared parser functions.
+ *
+ * We could include bitmatch statements directly in here, but
+ * what happens is that the macros get expanded here, resulting
+ * in (even more) unreadable generated code. So instead just
+ * do a textual substitution later by post-processing the
+ * generated files. Not type-safe, but we can't have
+ * everything.
+ *)
+ let parser_stmts, parser_subs =
+ let parser_stmts = List.map (
+ fun (i, _) ->
+ let fnname = sprintf "parser_%d" i in
+ <:str_item<
+ let $lid:fnname$ bits = $str:fnname$
+ >>
+ ) parsers in
+
+ let parser_stmts =
+ match parser_stmts with
+ | [] -> <:str_item< >>
+ | p :: ps ->
+ List.fold_left (fun ps p -> <:str_item< $ps$ $p$ >>) p ps in
+
+ (* What gets substituted for "parser_NN" ... *)
+ let parser_subs = List.map (
+ fun (i, (endian, fields)) ->
+ let fnname = sprintf "parser_%d" i in
+ let endian =
+ match endian with
+ | Bitstring.LittleEndian -> "littleendian"
+ | Bitstring.BigEndian -> "bigendian"
+ | _ -> assert false in
+ let patterns =
+ (* Fields must be sorted by offset, otherwise bitmatch
+ * will complain.
+ *)
+ let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in
+ let fields = List.sort ~cmp fields in
+ String.concat ";\n " (
+ List.map (
+ function
+ | (field_name, (`Int, offset, size))
+ | (field_name, (`Ptr _, offset, size)) ->
+ (* 'zero+' is a hack to force the type to int64. *)
+ sprintf "%s : zero+%d : offset(%d), %s"
+ field_name (size*8) (offset*8) endian
+ | (field_name, (`Str width, offset, size)) ->
+ sprintf "%s : %d : offset(%d), string"
+ field_name (width*8) (offset*8)
+ ) fields
+ ) in
+ let assignments =
+ String.concat ";\n " (
+ List.map (
+ function
+ | (field_name, (`Ptr "list_head", offset, size)) ->
+ sprintf "%s = Int64.sub %s %dL" field_name field_name offset
+ | (field_name, _) ->
+ sprintf "%s = %s" field_name field_name
+ ) fields
+ ) in
+
+ let sub =
+ sprintf "\
+ bitmatch bits with
+ | { %s } -> { %s }
+ | { _ } -> raise (ParseError (%S, %S, \"failed to match kernel structure\"))"
+ patterns assignments struct_name fnname in
+
+ fnname, sub
+ ) parsers in
+
+ parser_stmts, parser_subs in
+
+ (* Define a map from kernel versions to parsing functions. *)
+ let version_map =
+ let stmts = List.fold_left (
+ fun stmts (_, version, arch, total_size, i) ->
+ let parserfn = sprintf "parser_%d" i in
+ <:str_item<
+ $stmts$
+ let v = ($lid:parserfn$, $`int:total_size$)
+ let map = StringMap.add $str:version$ v map
+ >>
+ ) <:str_item< let map = StringMap.empty >> kernels in
+
+ <:str_item<
+ module StringMap = Map.Make (String)
+ $stmts$
+ >> in
+
+ (* Code (.ml file). *)