- fun (name, { mandatory_struct = mandatory }) ->
- if mandatory && not (Hashtbl.mem bodies name) then
- failwith (sprintf "%s: structure %s not found in this kernel" basename name)
- ) structs;
-
- (basename, version, arch, bodies)
- ) infos in
-
- (* Now parse each structure body.
- * XXX This would be better as a proper lex/yacc parser.
- * XXX Even better would be to have a proper interface to libdwarves.
- *)
- let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/" in
- let re_intfield = Pcre.regexp "int\\s+(\\w+);" in
- let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);" in
- let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];" in
- let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$" in
- let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;" in
-
- (* 'basename' is the source file, and second parameter ('body') is
- * the list of text lines which covers this structure (minus the
- * opener line). Result is the list of parsed fields from this
- * structure.
- *)
- let rec parse basename = function
- | [] -> assert false
- | [_] -> [] (* Just the closer line, finished. *)
- | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
- (* Recursively parse a sub-structure. First search for the
- * corresponding closer line.
- *)
- let rec loop depth acc = function
- | [] ->
- eprintf "%s: %S has no matching close structure line\n%!"
- basename line;
- assert false
- | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
- loop (depth+1) (line :: acc) lines
- | line :: lines
- when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
- (line :: acc), lines
- | line :: lines
- when depth > 0 && Pcre.pmatch ~rex:re_structcloser line ->
- loop (depth-1) (line :: acc) lines
- | line :: lines -> loop depth (line :: acc) lines
- in
- let nested_body, rest = loop 0 [] lines in
-
- (* Then parse the sub-structure. *)
- let struct_name, nested_body =
- match nested_body with
- | [] -> assert false
- | closer :: _ ->
- let subs = Pcre.exec ~rex:re_structcloser closer in
- let struct_name =
- try Some (Pcre.get_substring subs 1) with Not_found -> None in
- struct_name, List.rev nested_body in
- let nested_fields = parse basename nested_body in
-
- (* Prefix the sub-fields with the name of the structure. *)
- let nested_fields =
- match struct_name with
- | None -> nested_fields
- | Some prefix ->
- List.map (
- fun (name, details) -> (prefix ^ "'" ^ name, details)
- ) nested_fields in
-
- (* Parse the rest. *)
- nested_fields @ parse basename rest
-
- | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
- (* An int field. *)
- let subs = Pcre.exec ~rex:re_intfield line in
- let name = Pcre.get_substring subs 1 in
- (try
- let subs = Pcre.exec ~rex:re_offsetsize line in
- let offset = int_of_string (Pcre.get_substring subs 1) in
- let size = int_of_string (Pcre.get_substring subs 2) in
- (name, (`Int, offset, size)) :: parse basename lines
- with
- Not_found -> parse basename lines
- );
-
- | line :: lines when Pcre.pmatch ~rex:re_ptrfield line ->
- (* A pointer-to-struct field. *)
- let subs = Pcre.exec ~rex:re_ptrfield line in
- let struct_name = Pcre.get_substring subs 1 in
- let name = Pcre.get_substring subs 2 in
- (try
- let subs = Pcre.exec ~rex:re_offsetsize line in
- let offset = int_of_string (Pcre.get_substring subs 1) in
- let size = int_of_string (Pcre.get_substring subs 2) in
- (name, (`Ptr struct_name, offset, size))
- :: parse basename lines
- with
- Not_found -> parse basename lines
- );
-
- | line :: lines when Pcre.pmatch ~rex:re_strfield line ->
- (* A string (char array) field. *)
- let subs = Pcre.exec ~rex:re_strfield line in
- let name = Pcre.get_substring subs 1 in
- let width = int_of_string (Pcre.get_substring subs 2) in
- (try
- let subs = Pcre.exec ~rex:re_offsetsize line in
- let offset = int_of_string (Pcre.get_substring subs 1) in
- let size = int_of_string (Pcre.get_substring subs 2) in
- (name, (`Str width, offset, size))
- :: parse basename lines
- with
- Not_found -> parse basename lines
- );
-
- | _ :: lines ->
- (* Just ignore any other field we can't parse. *)
- parse basename lines
-
- in