CHB: convert type resolution and type size to result types

Author: sipma

CodeHawk/CHB/bchlib/bCHARMFunctionInterface.ml

@@ -27,6 +27,7 @@
 
 (* chutil *)
 open CHFormatStringParser
+open CHTraceResult
 open CHUtil
 
 (* bchlib *)
@@ -497,34 +498,42 @@ let rec get_arm_struct_field_locations
           (parameter_location_t list * arm_argument_state_t) =
   let fieldstate = aa_state in
   let bftype = resolve_type (get_struct_field_type bfinfo) in
-  let (bfsize, bfoffset) =
-    match (get_struct_field_size bfinfo,
-           get_struct_field_offset bfinfo) with
-    | (Some s, Some o) -> (s, o)
-    | _ ->
+  match bftype with
+  | Error e ->
+     raise
+       (BCH_failure
+          (LBLOCK [
+               STR "Problem with type resolution: ";
+               STR (String.concat "; " e)]))
+  | Ok bftype ->
+     let (bfsize, bfoffset) =
+       match (get_struct_field_size bfinfo,
+              get_struct_field_offset bfinfo) with
+       | (Some s, Some o) -> (s, o)
+       | _ ->
+          raise
+            (BCH_failure
+               (LBLOCK [
+                    STR "get_arm_struct_field_locations: ";
+                    STR "no layout provided: ";
+                    fieldinfo_to_pretty bfinfo])) in
+     if (is_int bftype || is_pointer bftype) && bfsize = 4 then
+       let (loc, naas) =
+         get_int_paramloc_next_state bfsize bftype fieldstate in
+       ([loc], naas)
+     else if is_int bftype && bfsize < 4 then
+       let (loc, naas) =
+         get_int_paramlocpart_next_state bfsize bftype bfoffset fieldstate in
+       ([loc], naas)
+     else if is_array_type bftype then
+       get_arm_array_locations bfsize bftype bfoffset fieldstate
+     else
        raise
          (BCH_failure
             (LBLOCK [
                  STR "get_arm_struct_field_locations: ";
-                 STR "no layout provided: ";
-                 fieldinfo_to_pretty bfinfo])) in
-  if (is_int bftype || is_pointer bftype) && bfsize = 4 then
-    let (loc, naas) =
-      get_int_paramloc_next_state bfsize bftype fieldstate in
-    ([loc], naas)
-  else if is_int bftype && bfsize < 4 then
-    let (loc, naas) =
-      get_int_paramlocpart_next_state bfsize bftype bfoffset fieldstate in
-    ([loc], naas)
-  else if is_array_type bftype then
-    get_arm_array_locations bfsize bftype bfoffset fieldstate
-  else
-    raise
-      (BCH_failure
-         (LBLOCK [
-              STR "get_arm_struct_field_locations: ";
-              STR "not yet implemented: ";
-              btype_to_pretty bftype]))
+                 STR "not yet implemented: ";
+                 btype_to_pretty bftype]))
 
 
 and get_arm_array_locations
@@ -572,27 +581,36 @@ let arm_vfp_params (funargs: bfunarg_t list): fts_parameter_t list =
   let (_, _, params) =
     List.fold_left
       (fun (index, aa_state, params) (name, btype, _) ->
-        let btype = resolve_type btype in
-        let tysize = size_of_btype btype in
-        (* assume no packing at the argument top level *)
-        let size = if tysize < 4 then 4 else tysize in
-        let (param, new_state) =
-          if (is_int btype || is_pointer btype || is_enum btype) && size = 4 then
-            get_arm_int_param_next_state size name btype aa_state index
-          else if (is_int btype || is_pointer btype) then
-            get_long_int_param_next_state size name btype aa_state index
-          else if is_float btype then
-            get_float_param_next_state size name btype aa_state index
-          else if (is_struct_type btype )
-                  && (get_struct_type_compinfo btype).bcstruct then
-            get_arm_struct_param_next_state size name btype aa_state index
-          else
-            raise
-              (BCH_failure
-                 (LBLOCK [
-                      STR "vfp_params: Not yet implemented; ";
-                      btype_to_pretty btype])) in
-        (index + 1, new_state, param :: params))
+        let btype_r = resolve_type btype in
+        let tysize_r = tbind size_of_btype btype_r in
+        match btype_r, tysize_r with
+        | Error e, _
+          | _, Error e ->
+           raise
+             (BCH_failure
+                (LBLOCK [
+                     STR "Problem with type resolution: ";
+                     STR (String.concat "; " e)]))
+        | Ok btype, Ok tysize ->
+           (* assume no packing at the argument top level *)
+           let size = if tysize < 4 then 4 else tysize in
+           let (param, new_state) =
+             if (is_int btype || is_pointer btype || is_enum btype) && size = 4 then
+               get_arm_int_param_next_state size name btype aa_state index
+             else if (is_int btype || is_pointer btype) then
+               get_long_int_param_next_state size name btype aa_state index
+             else if is_float btype then
+               get_float_param_next_state size name btype aa_state index
+             else if (is_struct_type btype )
+                     && (get_struct_type_compinfo btype).bcstruct then
+               get_arm_struct_param_next_state size name btype aa_state index
+             else
+               raise
+                 (BCH_failure
+                    (LBLOCK [
+                         STR "vfp_params: Not yet implemented; ";
+                         btype_to_pretty btype])) in
+           (index + 1, new_state, param :: params))
       (1, aas_start_state, []) funargs in
   params
 
@@ -684,17 +702,22 @@ let get_arm_format_spec_parameters
             promote_int ftype
           else
             ftype in
-        let size = size_of_btype ftype in
+        let size_r = size_of_btype ftype in
         let name = "vararg_" ^ (string_of_int varargindex) in
         let (param, new_state) =
-          match size with
-          | 4 -> get_arm_int_param_next_state size name ftype aas nxtindex
-          | 8 -> get_long_int_param_next_state size name ftype aas varargindex
-          | _ ->
+          match size_r with
+          | Ok 4 -> get_arm_int_param_next_state 4 name ftype aas nxtindex
+          | Ok 8 -> get_long_int_param_next_state 8 name ftype aas varargindex
+          | Ok size ->
+             raise
+               (BCH_failure
+                  (LBLOCK [
+                       STR "Var-arg size: "; INT size; STR " not supported"]))
+          | Error e ->
              raise
                (BCH_failure
                   (LBLOCK [
-                       STR "Var-arg size: "; INT size; STR " not supported"])) in
+                       STR "Error in var-args: "; STR (String.concat "; " e)])) in
         (new_state, param :: accpars, varargindex + 1, nxtindex + 1))
       (fmtaas, [], 1, nextindex) argspecs in
   pars

CodeHawk/CHB/bchlib/bCHBCFiles.ml

@@ -30,6 +30,7 @@ open CHPretty
 
 (* chutil *)
 open CHLogger
+open CHTraceResult
 open CHXmlDocument
 
 (* bchlib *)
@@ -204,8 +205,8 @@ object (self)
         (BCH_failure
            (LBLOCK [STR "No typedef found with name "; STR name]))
 
-  method resolve_type (ty: btype_t): btype_t =
-    let rec aux (t: btype_t) =
+  method resolve_type (ty: btype_t): btype_t traceresult =
+    let rec aux (t: btype_t): btype_t traceresult =
       match t with
       | TVoid _
         | TInt _
@@ -218,25 +219,40 @@ object (self)
         | TClass _
         | TBuiltin_va_list _
         | TVarArg _
-        | TUnknown _ -> t
-      | TPtr (tt, a) -> TPtr (aux tt, a)
-      | TRef (tt, a) -> TRef (aux tt, a)
-      | TArray (tt, e, a) -> TArray (aux tt, e, a)
-      | TFun (tt, fs, b, a) -> TFun (aux tt, auxfs fs, b, a)
+        | TUnknown _ -> Ok t
+      | TPtr (tt, a) -> tmap (fun v -> TPtr (v, a)) (aux tt)
+      | TRef (tt, a) -> tmap (fun v -> TRef (v, a)) (aux tt)
+      | TArray (tt, e, a) -> tmap (fun v -> TArray (v, e, a)) (aux tt)
+      | TFun (tt, fs, b, a) ->
+         let auxtt_r = aux tt in
+         let auxfs_r = auxfs fs in
+         (match auxtt_r, auxfs_r with
+          | Ok v1, Ok v2 -> Ok (TFun (v1, v2, b, a))
+          | Error e1, Ok _ -> Error e1
+          | Ok _, Error e2 -> Error e2
+          | Error e1, Error e2 -> Error (e1 @ e2))
       | TNamed (name, a) when self#has_typedef name ->
          aux (add_attributes (self#get_typedef name) a)
       | TNamed (name, _) ->
-         begin
-           ch_diagnostics_log#add
-             "unknown typedef"
-             (LBLOCK [STR "Named type "; STR name; STR " not defined"]);
-           t
-         end
-
-    and auxfs (fs: bfunarg_t list option): bfunarg_t list option =
+         Error ["resolve_type: type name not found: " ^ name]
+
+    and auxfs (fs: bfunarg_t list option): bfunarg_t list option traceresult =
       match fs with
-      | None -> None
-      | Some l -> Some (List.map (fun (s, t, a) -> (s, aux t, a)) l)
+      | None -> Ok None
+      | Some l ->
+         let fs_r = List.map (fun (s, t, a) -> (s, aux t, a)) l in
+         let fs_r =
+           List.fold_left (fun acc (s, t_r, a) ->
+               match acc with
+               | Error _ -> acc
+               | Ok accv ->
+                  (match t_r with
+                   | Error e -> Error e
+                   | Ok v -> Ok ((s, v, a) :: accv))) (Ok []) fs_r in
+         match fs_r with
+         | Ok v -> Ok (Some v)
+         | Error e -> Error e
+                        (* Some (List.map (fun (s, t, a) -> (s, aux t, a)) l) *)
 
     in
     aux ty