PR#11: support sizeof(struct {...}) and _Alignof(struct {...})

This is a partial fix because other cases of struct definitions within type-names are still not handled, e.g. (struct { ... } *) <expr>.  However, error reporting was improved for these cases.

1 files changed, 38 insertions, 25 deletions

diff --git a/cparser/Elab.ml b/cparser/Elab.ml
index 43a72a0e..dd42ae24 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -44,6 +44,10 @@ let wrap fn loc env arg =
   try fn env arg
   with Env.Error msg -> fatal_error loc "%s" (Env.error_message msg)
 
+let wrap2 fn loc env arg1 arg2 =
+  try fn env arg1 arg2
+  with Env.Error msg -> fatal_error loc "%s" (Env.error_message msg)
+
 (* Translation of locations *)
 
 let elab_loc l = (l.filename, l.lineno)
@@ -786,7 +790,7 @@ let elab_type loc env spec decl =
   let (ty, env'') = elab_type_declarator loc env' bty decl in 
   if sto <> Storage_default || inl || tydef then
     error loc "'typedef', 'extern', 'static', 'register' and 'inline' are meaningless in cast";
-  ty
+  (ty, env'')
 
 
 (* Elaboration of initializers. C99 section 6.7.8 *)
@@ -820,8 +824,8 @@ let init_int_array_wstring opt_size s =
   Init_array (add_chars (Int64.pred size) (List.rev s) [])
 
 let check_init_type loc env a ty =
-  if valid_assignment env a ty then ()
-  else if valid_cast env a.etyp ty then
+  if wrap2 valid_assignment loc env a ty then ()
+  else if wrap2 valid_cast loc env a.etyp ty then
     warning loc
       "initializer has type@ %a@ instead of the expected type @ %a"
       Cprint.typ a.etyp Cprint.typ ty
@@ -1309,16 +1313,18 @@ let elab_expr loc env a =
 (* 6.5.4 Cast operators *)
 
   | CAST ((spec, dcl), SINGLE_INIT a1) ->
-      let ty = elab_type loc env spec dcl in
+      let (ty, _) = elab_type loc env spec dcl in
       let b1 = elab a1 in
-      if not (valid_cast env b1.etyp ty) then
+      if not (wrap2 valid_cast loc env b1.etyp ty) then
         err "illegal cast from %a@ to %a" Cprint.typ b1.etyp Cprint.typ ty;
       { edesc = ECast(ty, b1); etyp = ty }
 
 (* 6.5.2.5 Compound literals *)
 
   | CAST ((spec, dcl), ie) ->
-      let ty = elab_type loc env spec dcl in
+      let (ty, _) = elab_type loc env spec dcl in
+      if wrap incomplete_type loc env ty then
+        err "incomplete type %a" Cprint.typ ty;
       begin match elab_initializer loc env "<compound literal>" ty ie with
       | (ty', Some i) -> { edesc = ECompound(ty', i); etyp = ty' }
       | (ty', None)   -> error "ill-formed compound literal"
@@ -1344,8 +1350,8 @@ let elab_expr loc env a =
       { edesc = bdesc; etyp = TInt(size_t_ikind, []) }
 
   | TYPE_SIZEOF (spec, dcl) ->
-      let ty = elab_type loc env spec dcl in
-      if wrap incomplete_type loc env ty then
+      let (ty, env') = elab_type loc env spec dcl in
+      if wrap incomplete_type loc env' ty then
         err "incomplete type %a" Cprint.typ ty;
       { edesc = ESizeof ty; etyp = TInt(size_t_ikind, []) }
 
@@ -1356,8 +1362,8 @@ let elab_expr loc env a =
       { edesc = EAlignof b1.etyp; etyp =  TInt(size_t_ikind, []) }
 
   | TYPE_ALIGNOF (spec, dcl) ->
-      let ty = elab_type loc env spec dcl in
-      if wrap incomplete_type loc env ty then
+      let (ty, env') = elab_type loc env spec dcl in
+      if wrap incomplete_type loc env' ty then
         err "incomplete type %a" Cprint.typ ty;
       { edesc = EAlignof ty; etyp =  TInt(size_t_ikind, []) }
 
@@ -1544,8 +1550,8 @@ let elab_expr loc env a =
         err "left-hand side of assignment has 'const' type";
       if not (is_modifiable_lvalue env b1) then
         err "left-hand side of assignment is not a modifiable l-value";
-      if not (valid_assignment env b2 b1.etyp) then begin
-        if valid_cast env b2.etyp b1.etyp then
+      if not (wrap2 valid_assignment loc env b2 b1.etyp) then begin
+        if wrap2 valid_cast loc env b2.etyp b1.etyp then
           warning "assigning a value of type@ %a@ to a lvalue of type@ %a"
                   Cprint.typ b2.etyp Cprint.typ b1.etyp
         else
@@ -1576,8 +1582,8 @@ let elab_expr loc env a =
             err "left-hand side of assignment has 'const' type";
           if not (is_modifiable_lvalue env b1) then
             err ("left-hand side of assignment is not a modifiable l-value");
-          if not (valid_assignment env b b1.etyp) then begin
-            if valid_cast env ty b1.etyp then
+          if not (wrap2 valid_assignment loc env b b1.etyp) then begin
+            if wrap2 valid_cast loc env ty b1.etyp then
               warning "assigning a value of type@ %a@ to a lvalue of type@ %a"
                       Cprint.typ ty Cprint.typ b1.etyp
             else
@@ -1689,8 +1695,9 @@ let elab_expr loc env a =
         else (err "too many arguments in function call"; args)
     | arg1 :: argl, (_, ty_p) :: paraml ->
         let ty_a = argument_conversion env arg1.etyp in
-        if not (valid_assignment env {arg1 with etyp = ty_a} ty_p) then begin
-          if valid_cast env ty_a ty_p then
+        if not (wrap2 valid_assignment loc env {arg1 with etyp = ty_a} ty_p)
+        then begin
+          if wrap2 valid_cast loc env ty_a ty_p then
             warning
               "argument #%d of function call has type@ %a@ \
                instead of the expected type@ %a"
@@ -1770,13 +1777,18 @@ let enter_decdefs local loc env sto dl =
   if sto <> Storage_default && dl = [] then
     warning loc "Storage class specifier on empty declaration";
   let rec enter_decdef (decls, env) (s, ty, init) =
-    let isfun = is_function_type env ty in
     if sto = Storage_extern && init <> NO_INIT then
       error loc "'extern' declaration cannot have an initializer";
-    if local && isfun && (sto = Storage_static || sto = Storage_register) then
-      error loc "invalid storage class for '%s'" s;
-    (* Local function declarations are always treated as extern *)
-    let sto1 = if local && isfun then Storage_extern else sto in
+    (* Adjust storage for function declarations *)
+    let sto1 =
+      match unroll env ty, sto with
+      | TFun _, Storage_default -> 
+          Storage_extern
+      | TFun _, (Storage_static | Storage_register) ->
+          if local then error loc "invalid storage class for '%s'" s;
+          sto
+      | _, _ ->
+          sto in
     (* enter ident in environment with declared type, because
        initializer can refer to the ident *)
     let (id, sto', env1) = enter_or_refine_ident local loc env s sto1 ty in
@@ -1786,10 +1798,10 @@ let enter_decdefs local loc env sto dl =
     let env2 = Env.add_ident env1 id sto' ty' in
     (* check for incomplete type *)
     if local && sto' <> Storage_extern
-             && not isfun
+             && not (is_function_type env ty')
              && wrap incomplete_type loc env ty' then
       error loc "'%s' has incomplete type" s;
-    if local && not isfun && sto' <> Storage_extern && sto' <> Storage_static then
+    if local && sto' <> Storage_extern && sto' <> Storage_static then
       (* Local definition *)
       ((sto', id, ty', init') :: decls, env2)
     else begin
@@ -2079,8 +2091,9 @@ let rec elab_stmt env ctx s =
             "'return' without a value in a function of return type@ %a"
             Cprint.typ ctx.ctx_return_typ
       | _, Some b ->
-          if not (valid_assignment env b ctx.ctx_return_typ) then begin
-            if valid_cast env b.etyp ctx.ctx_return_typ then
+          if not (wrap2 valid_assignment loc env b ctx.ctx_return_typ)
+          then begin
+            if wrap2 valid_cast loc env b.etyp ctx.ctx_return_typ then
               warning loc
                 "return value has type@ %a@ \
                  instead of the expected type@ %a"