+ (* Let's generate some code! *)
+ let files =
+ List.map (
+ fun (struct_name, kernels, field_types, parsers) ->
+ (* Dummy location required - there are no real locations for
+ * output files.
+ *)
+ let _loc = Loc.ghost in
+
+ (* The structure type. *)
+ let struct_type, struct_sig =
+ let fields = List.map (
+ function
+ | (name, `Int) ->
+ <:ctyp< $lid:name$ : int >>
+ | (name, `Ptr struct_name) ->
+ <:ctyp< $lid:name$ : [`$lid:struct_name$] int64 >>
+ | (name, `Str _) ->
+ <:ctyp< $lid:name$ : string >>
+ ) field_types in
+ let f, fs = match fields with
+ | [] -> failwith (sprintf "%s: structure has no fields" struct_name)
+ | f :: fs -> f, fs in
+ let fields = List.fold_left (
+ fun fs f -> <:ctyp< $fs$ ; $f$ >>
+ ) f fs in
+
+ let struct_type = <:str_item< type t = { $fields$ } >> in
+ let struct_sig = <:sig_item< type t = { $fields$ } >> in
+ struct_type, struct_sig in
+
+ (* The shared parser functions.
+ * We could include bitmatch statements directly in here, but
+ * what happens is that the macros get expanded here, resulting
+ * in 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 patterns = "" and assignments = "" in (* XXX *)
+ 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). *)
+ let code = <:str_item<
+ let warning = "This code is automatically generated from the kernel database by kerneldb-to-parser program. Any edits you make will be lost."
+ exception ParseError of string ;;
+ $struct_type$
+ $parser_stmts$
+ $version_map$
+
+ type kernel_version = string
+ let known version = StringMap.mem version map
+ let size version =
+ let _, size = StringMap.find version map in
+ size
+ let get version bits =
+ let parsefn, _ = StringMap.find version map in
+ parsefn bits
+ >> in
+
+ (* Interface (.mli file). *)
+ let interface = <:sig_item<
+ exception ParseError of string ;;
+ $struct_sig$
+
+ type kernel_version = string
+ val known : kernel_version -> bool
+ val size : kernel_version -> int
+ val get : kernel_version -> Bitstring.bitstring -> t
+ >> in
+
+ (struct_name, code, interface)
+ ) files in
+
+ (* Finally generate the output files. *)
+ List.iter (
+ fun (struct_name, code, interface) ->
+ let output_file = outputdir // "kernel_" ^ struct_name ^ ".ml" in
+ printf "Writing %s implementation to %s ...\n%!" struct_name output_file;
+ Printers.OCaml.print_implem ~output_file code;
+
+ let output_file = outputdir // "kernel_" ^ struct_name ^ ".mli" in
+ printf "Writing %s interface to %s ...\n%!" struct_name output_file;
+ Printers.OCaml.print_interf ~output_file interface
+ ) files