Merge pull request #103 from AbsInt/KR_fundefs

Revised handling of old-style, K&R function definitions

4 files changed, 171 insertions, 64 deletions

diff --git a/cparser/Elab.ml b/cparser/Elab.ml
index 722303d2..2b454f5b 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -1909,100 +1909,165 @@ let enter_decdefs local loc env sto dl =
   let (decls, env') = List.fold_left enter_decdef ([], env) dl in
   (List.rev decls, env')
 
+(* Processing of K&R-style function definitions.  Synopsis:
+      T f(X1, ..., Xn)
+          T1 Y1; ...; Tm Ym;
+      { ... }
+  "params" is the list [X1; ...; Xn]
+  "defs" is the list of declarations [T1 Y1; ... Tm Ym]
+  We need to match the names Xi's with the Yj's so as to find the types Ti'
+  of the Xi and produce a typed argument list in prototyped style.
+  Owing to default argument promotion, the types Ti' and Tj may not match,
+  in which case we need to declare a local variable with the correct type.
+  Consider:
+      float f(x)  float x;  { return x; }
+  Since float arguments are promoted by default to double, this must
+  be converted as
+      float f(double x)  { float x1 = x; return x1; }
+*)  
+
+let elab_KR_function_parameters env params defs loc =
+  (* Check that the parameters have unique names *)
+  List.iter (fun id ->
+    if List.length (List.filter ((=) id) params) > 1 then
+      error loc "Parameter '%s' appears more than once in function declaration" id)
+    params;
+  (* Check that the declarations only declare parameters *)
+  let extract_name (Init_name(Name(s, dty, attrs, loc') as name, ie)) =
+    if not (List.mem s params) then
+      error loc' "Declaration of '%s' which is not a function parameter" s;
+    if ie <> NO_INIT then
+      error loc' "Illegal initialization of function parameter '%s'" s;
+    name
+  in
+  (* Extract names and types from the declarations *)
+  let elab_param_def env = function
+  | DECDEF((spec', name_init_list), loc') ->
+      let name_list = List.map extract_name name_init_list in
+      let (paramsenv, sto) = elab_name_group loc' env (spec', name_list) in
+      if sto <> Storage_default && sto <> Storage_register then
+        error loc' "'extern' or 'static' storage not supported for function parameter";
+      paramsenv
+  | d -> (* Should never be produced by the parser *)
+      fatal_error (get_definitionloc d)
+                      "Illegal declaration of function parameter" in
+  let kr_params_defs =
+    List.concat (fst (mmap elab_param_def env defs)) in
+  (* Find the type of a parameter *)
+  let type_of_param param =
+    match List.filter (fun (p, _) -> p = param) kr_params_defs with
+    | [] ->
+        (* Parameter is not declared, defaults to "int" in ISO C90,
+           is an error in ISO C99.  Just emit a warning. *)
+        warning loc "Type of '%s' defaults to 'int'" param;
+        TInt (IInt, [])
+    | (_, ty) :: rem ->
+        if rem <> [] then 
+          error loc "Parameter '%s' defined more than once" param;
+        ty in
+  (* Match parameters against declarations *)
+  let rec match_params params' extra_decls = function
+    | [] ->
+        (List.rev params', List.rev extra_decls)
+    | p :: ps ->
+        let ty = type_of_param p in
+        let ty_var = argument_conversion env ty 
+        and ty_param = default_argument_conversion env ty in
+        if compatible_types AttrIgnoreTop env ty_var ty_param then begin
+          (* No need for an extra conversion *)
+          let id = Env.fresh_ident p in
+          match_params ((id, ty_var) :: params') extra_decls ps
+        end else begin
+          (* Local variable of type ty_var is to be initialized from
+             the parameter of type ty_param *)
+          let id_param = Env.fresh_ident p in
+          let id_var = Env.fresh_ident p in
+          let init = Init_single { edesc = EVar id_param; etyp = ty_param } in
+          match_params ((id_param, ty_param) :: params')
+                       ((Storage_default, id_var, ty_var, Some init)
+                                                           :: extra_decls)
+                       ps
+        end
+  in
+    match_params [] [] params
+
+(* Function definitions *)
+
 let elab_fundef env spec name defs body loc =
-  let (s, sto, inline, noret, ty, kr_params, env1) = elab_fundef_name env spec name in
+  let (s, sto, inline, noret, ty, kr_params, env1) =
+    elab_fundef_name env spec name in
   if sto = Storage_register then
     fatal_error loc "A function definition cannot have 'register' storage class";
   begin match kr_params, defs with
-  | None, d::_ ->
-    error (get_definitionloc d)
-      "Old-style parameter declaration in a new-style function definition"
+  | None, d :: _ ->
+      error (get_definitionloc d)
+        "Old-style parameter declaration in a new-style function definition"
   | _ -> ()
   end;
-  let (ty, env1) =
+  (* Process the parameters and the K&R declarations, if any, to obtain:
+      - [ty]: the full, prototyped type of the function
+      - [extra_decls]: extra declarations to be inserted at the
+        beginning of the function *)
+  let (ty, extra_decls) =
     match ty, kr_params with
     | TFun(ty_ret, None, vararg, attr), None ->
-      (TFun(ty_ret, Some [], vararg, attr), env1)
+        (TFun(ty_ret, Some [], vararg, attr), [])
     | ty, None ->
-      (ty, env1)
+        (ty, [])
     | TFun(ty_ret, None, false, attr), Some params ->
-      warning loc "Non-prototype, pre-standard function definition.@  Converting to prototype form";
-      (* Check that the parameters have unique names *)
-      List.iter (fun id ->
-        if List.length (List.filter ((=) id) params) > 1 then
-          fatal_error loc "Parameter '%s' appears more than once in function declaration" id)
-        params;
-      (* Check that the declarations only declare parameters *)
-      let extract_name (Init_name(Name(s, dty, attrs, loc') as name, ie)) =
-        if not (List.mem s params) then
-          error loc' "Declaration of '%s' which is not a function parameter" s;
-        if ie <> NO_INIT then
-          error loc' "Illegal initialization of function parameter '%s'" s;
-        name
-      in
-      (* Convert old-style K&R function definition to modern prototyped form *)
-      let elab_kr_param_def env = function
-      | DECDEF((spec', name_init_list), loc') ->
-          let name_list = List.map extract_name name_init_list in
-          let (paramsenv, sto) = elab_name_group loc' env (spec', name_list) in
-          if sto <> Storage_default && sto <> Storage_register then
-            error loc' "'extern' or 'static' storage not supported for function parameter";
-          paramsenv
-      | d ->
-          (* Should never be produced by the parser *)
-          fatal_error (get_definitionloc d)
-                      "Illegal declaration of function parameter" in
-      let (kr_params_defs, env1) = mmap elab_kr_param_def env1 defs in
-      let kr_params_defs = List.concat kr_params_defs in
-      let search_param_type param =
-        match List.filter (fun (p, _) -> p = param) kr_params_defs with
-        | [] ->
-          (* Parameter is not declared, defaults to "int" in ISO C90,
-             is an error in ISO C99.  Just emit a warning. *)
-          warning loc "Type of '%s' defaults to 'int'" param;
-          (Env.fresh_ident param, TInt (IInt, []))
-        | (_,ty)::q ->
-          if q <> [] then error loc "Parameter '%s' defined more than once" param;
-          (Env.fresh_ident param, argument_conversion env1 ty)
-      in
-      let params' = List.map search_param_type params in
-      (TFun(ty_ret, Some params', false, attr), env1)
-    | _, Some params -> assert false
+        warning loc "Non-prototype, pre-standard function definition.@  Converting to prototype form";
+        let (params', extra_decls) =
+          elab_KR_function_parameters env params defs loc in
+        (TFun(ty_ret, Some params', false, attr), extra_decls)
+    | _, Some params ->
+        assert false
   in
-  (* Extract info from type *)
+  (* Extract infos from the type of the function *)
   let (ty_ret, params, vararg, attr) =
     match ty with
     | TFun(ty_ret, Some params, vararg, attr) ->
-         if wrap incomplete_type loc env1 ty_ret && not (is_void_type env ty_ret) then
-           fatal_error loc "return type is an incomplete type";
-        (ty_ret, params, vararg, attr)
-    | _ -> fatal_error loc "wrong type for function definition" in
+         if wrap incomplete_type loc env1 ty_ret
+         && not (is_void_type env ty_ret)
+         then error loc "return type is an incomplete type";
+         (ty_ret, params, vararg, attr)
+    | _ ->
+         fatal_error loc "wrong type for function definition" in
   (* Enter function in the environment, for recursive references *)
   let (fun_id, sto1, env1, _) = enter_or_refine_ident false loc env1 s sto ty in
-  (* Enter parameters in the environment *)
+  (* Enter parameters and extra declarations in the environment *)
   let env2 =
     List.fold_left (fun e (id, ty) -> Env.add_ident e id Storage_default ty)
                    (Env.new_scope env1) params in
+  let env2 =
+    List.fold_left (fun e (sto, id, ty, init) -> Env.add_ident e id sto ty)
+                   env2 extra_decls in
   (* Define "__func__" and enter it in the environment *)
   let (func_ty, func_init) = __func__type_and_init s in
-  let (func_id, _, env3,func_ty) =
+  let (func_id, _, env3, func_ty) =
     enter_or_refine_ident true loc env2 "__func__" Storage_static func_ty in
   emit_elab ~enter:false env3 loc (Gdecl(Storage_static, func_id, func_ty, Some func_init));
   (* Elaborate function body *)
-  let body' = !elab_funbody_f ty_ret env3 body in
+  let body1 = !elab_funbody_f ty_ret env3 body in
   (* Special treatment of the "main" function *)
-  let body'' =
+  let body2 =
     if s = "main" then begin
       match unroll env ty_ret with
       | TInt(IInt, []) ->
           (* Add implicit "return 0;" at end of function body *)
-          sseq no_loc body'
+          sseq no_loc body1
             {sdesc = Sreturn(Some(intconst 0L IInt)); sloc = no_loc}
       | _ ->
           warning loc "return type of 'main' should be 'int'";
-          body'
-    end else body' in
-  if noret && contains_return body' then
+          body1
+    end else body1 in
+  (* Add the extra declarations if any *)
+  let body3 =
+    if extra_decls = [] then body2 else begin
+      let mkdecl d = { sdesc = Sdecl d; sloc = no_loc } in
+      { sdesc = Sblock (List.map mkdecl extra_decls @ [body2]);
+        sloc = no_loc }
+    end in
+  if noret && contains_return body1 then
     warning loc "function '%s' declared 'noreturn' should not return" s;
   (* Build and emit function definition *)
   let fn =
@@ -2014,10 +2079,12 @@ let elab_fundef env spec name defs body loc =
       fd_params = params;
       fd_vararg = vararg;
       fd_locals = [];
-      fd_body = body'' } in
+      fd_body = body3 } in
   emit_elab env1 loc (Gfundef fn);
   env1
 
+(* Definitions *)
+
 let rec elab_definition (local: bool) (env: Env.t) (def: Cabs.definition)
                     : decl list * Env.t =
   match def with
diff --git a/test/regression/Makefile b/test/regression/Makefile
index 6ef44b78..335a136b 100644
--- a/test/regression/Makefile
+++ b/test/regression/Makefile
@@ -18,7 +18,7 @@ TESTS=int32 int64 floats floats-basics \
   funct3 expr5 struct7 struct8 struct11 struct12 casts1 casts2 char1 \
   sizeof1 sizeof2 binops bool for1 switch switch2 compound \
   decl1 interop1 bitfields9 ptrs3 \
-  parsing
+  parsing krfun
 
 # Can run, but only in compiled mode, and have reference output in Results
 
diff --git a/test/regression/Results/krfun b/test/regression/Results/krfun
new file mode 100644
index 00000000..7e2320b2
--- /dev/null
+++ b/test/regression/Results/krfun
@@ -0,0 +1,3 @@
+f(1, "Hello", 2)
+g(1, "World", 0x1.921fb6p+1, 0x1.921fb5452455p+1, -34, 12345678901234567)
+h(6, "warning!", 7)
diff --git a/test/regression/krfun.c b/test/regression/krfun.c
new file mode 100644
index 00000000..e34098b5
--- /dev/null
+++ b/test/regression/krfun.c
@@ -0,0 +1,37 @@
+/* Old-style, K&R function definitions */
+
+#include <stdio.h>
+
+void f(a, b, c)
+     int c, a;
+     char * b;
+{
+  printf("f(%d, \"%s\", %d)\n", a, b, c);
+}
+
+void g(a, b, c, d, e, x)
+     const unsigned char a;
+     char b[64];
+     float c;
+     double d;
+     volatile int e;
+     long long x;
+{
+  printf("g(%d, \"%s\", %a, %a, %d, %lld)\n", a, b, c, d, e, x);
+}
+
+void h(a, b, c)
+     char * b;
+{
+  printf("h(%d, \"%s\", %d)\n", a, b, c);
+}
+
+
+int main()
+{
+  f(1, "Hello", 2);
+  g(257, "World", 3.141592654, 3.141592654, -34, 12345678901234567LL);
+  h(6, "warning!", 7);
+  return 0;
+}
+