WIP Dirty: towards handeling complex and tgmath

References #8, References #9

src/cil.ml

@@ -62,7 +62,7 @@ let cilVersionRevision = Cilversion.cilVersionRev
 let msvcMode = ref false              (* Whether the pretty printer should
                                        * print output for the MS VC
                                        * compiler. Default is GCC *)
-let c99Mode = ref false (* True to handle ISO C 99 vs 90 changes.
+let c99Mode = ref true (* True to handle ISO C 99 vs 90 changes. (* TODO: This should be exposed *)
 			   So far only affects integer parsing. *)
 
 (* Set this to true to get old-style handling of gcc's extern inline C extension:
@@ -292,6 +292,9 @@ and fkind =
     FFloat      (** [float] *)
   | FDouble     (** [double] *)
   | FLongDouble (** [long double] *)
+  | FComplexFloat
+  | FComplexDouble
+  | FComplexLongDouble
 
 (** An attribute has a name and some optional parameters *)
 and attribute = Attr of string * attrparam list
@@ -1664,6 +1667,9 @@ let d_fkind () = function
     FFloat -> text "float"
   | FDouble -> text "double"
   | FLongDouble -> text "long double"
+  | FComplexFloat -> text "_Complex float"
+  | FComplexDouble -> text "_Complex double"
+  | FComplexLongDouble -> text "_Complex long double"
 
 let d_storage () = function
     NoStorage -> nil
@@ -1751,7 +1757,10 @@ let d_const () c =
       (match fsize with
          FFloat -> chr 'f'
        | FDouble -> nil
-       | FLongDouble -> chr 'L')
+       | FLongDouble -> chr 'L'
+       | FComplexFloat -> text "iF"
+       | FComplexDouble -> chr 'i'
+       | FComplexLongDouble -> text "iL")
   | CEnum(_, s, ei) -> text s
 
 
@@ -2154,6 +2163,9 @@ let rec alignOf_int t =
     | TFloat(FFloat, _) -> !M.theMachine.M.alignof_float
     | TFloat(FDouble, _) -> !M.theMachine.M.alignof_double
     | TFloat(FLongDouble, _) -> !M.theMachine.M.alignof_longdouble
+    | TFloat(FComplexFloat, _) -> !M.theMachine.M.alignof_float (* TODO! *)
+    | TFloat(FComplexDouble, _) -> !M.theMachine.M.alignof_double (* TODO! *)
+    | TFloat(FComplexLongDouble, _) -> !M.theMachine.M.alignof_longdouble (* TODO! *)
     | TNamed (t, _) -> alignOf_int t.ttype
     | TArray (t, _, _) -> alignOf_int t
     | TPtr _ | TBuiltin_va_list _ -> !M.theMachine.M.alignof_ptr
@@ -2962,6 +2974,9 @@ let initGccBuiltins () : unit =
   H.add h "__builtin_ctzl" (intType, [ ulongType ], false);
   H.add h "__builtin_ctzll" (intType, [ ulongLongType ], false);
 
+  (* Do sth smart here, such as add a spurious cast to void *)
+  (* H.add h "__builtin_classify_type" (intType, [ voidType], false); *)
+
   H.add h "__builtin_exp" (doubleType, [ doubleType ], false);
   H.add h "__builtin_expf" (floatType, [ floatType ], false);
   H.add h "__builtin_expl" (longDoubleType, [ longDoubleType ], false);
@@ -3340,6 +3355,10 @@ class defaultCilPrinterClass : cilPrinter = object (self)
 
   (* variable declaration *)
   method pVDecl () (v:varinfo) =
+    (* These were treated as if they were functions but they are not *)
+    (* if v.vname = "__real__" || v.vname = "__imag__" then
+      nil
+    else *)
     let stom, rest = separateStorageModifiers v.vattr in
     (* First the storage modifiers *)
     text (if v.vinline then "__inline " else "")

src/cil.mli

@@ -293,7 +293,9 @@ and fkind =
     FFloat      (** [float] *)
   | FDouble     (** [double] *)
   | FLongDouble (** [long double] *)
-
+  | FComplexFloat
+  | FComplexDouble
+  | FComplexLongDouble
 
 (** {b Attributes.} *)
 

src/ext/llvm/llvmutils.ml

@@ -143,6 +143,9 @@ and gType (t:typ) : doc = match t with
 | TFloat (FFloat, _) -> text "float"
 | TFloat (FDouble, _) -> text "double"
 | TFloat (FLongDouble, _) -> text "fp128"
+| TFloat (FComplexFloat, _) -> text "float" (* TODO: Incorrect *)
+| TFloat (FComplexDouble, _) -> text "double"  (* TODO: Incorrect *)
+| TFloat (FComplexLongDouble, _) -> text "fp128"  (* TODO: Incorrect *)
 | TPtr (t, _) -> 
     (* LLVM uses "i8 *" for 'void *' *)
     if isVoidType t then text "i8 *"

src/frontc/cabs.ml

@@ -268,6 +268,8 @@ and expression =
   | CONSTANT of constant
   | PAREN of expression
   | VARIABLE of string
+  | REAL of expression
+  | IMAG of expression
   | EXPR_SIZEOF of expression
   | TYPE_SIZEOF of specifier * decl_type
   | EXPR_ALIGNOF of expression
@@ -281,6 +283,7 @@ and expression =
 and constant =
   | CONST_INT of string   (* the textual representation *)
   | CONST_FLOAT of string (* the textual representaton *)
+  | CONST_COMPLEX of string (* the textual representation *)
   | CONST_CHAR of int64 list
   | CONST_WCHAR of int64 list
   | CONST_STRING of string

src/frontc/cabs2cil.ml

@@ -1256,11 +1256,17 @@ let arithmeticConversion    (* c.f. ISO 6.3.1.8 *)
     (t2: typ) : typ =
   match unrollType t1, unrollType t2 with
     TFloat(FLongDouble, _), _ -> t1
+  | TFloat(FComplexLongDouble, _), _ -> t1
   | _, TFloat(FLongDouble, _) -> t2
+  | _, TFloat(FComplexLongDouble, _) -> t2
   | TFloat(FDouble, _), _ -> t1
+  | TFloat(FComplexDouble, _), _ -> t1
   | _, TFloat (FDouble, _) -> t2
+  | _, TFloat (FComplexDouble, _) -> t2
   | TFloat(FFloat, _), _ -> t1
+  | TFloat(FComplexFloat, _), _ -> t1
   | _, TFloat (FFloat, _) -> t2
+  | _, TFloat (FComplexFloat, _) -> t2
   | _, _ -> begin
       let t1' = integralPromotion t1 in
       let t2' = integralPromotion t2 in
@@ -3446,11 +3452,10 @@ and doExp (asconst: bool)   (* This expression is used as a constant *)
         finishExp se lv' field_type
 
     | A.CONSTANT ct -> begin
-        let hasSuffix str =
+        let hasSuffix str suffix =
           let l = String.length str in
-          fun s ->
-            let ls = String.length s in
-            l >= ls && s = String.uppercase_ascii (String.sub str (l - ls) ls)
+          let ls = String.length suffix in
+          l >= ls && String.uppercase_ascii suffix = String.uppercase_ascii (String.sub str (l - ls) ls)
         in
         match ct with
           A.CONST_INT str -> begin
@@ -3533,13 +3538,12 @@ and doExp (asconst: bool)   (* This expression is used as a constant *)
         | A.CONST_FLOAT str -> begin
             (* Maybe it ends in U or UL. Strip those *)
             let l = String.length str in
-            let hasSuffix = hasSuffix str in
             let baseint, kind =
-              if  hasSuffix "L" then
+              if hasSuffix str "L" then
                 String.sub str 0 (l - 1), FLongDouble
-              else if hasSuffix "F" then
+              else if hasSuffix str "F" then
                 String.sub str 0 (l - 1), FFloat
-              else if hasSuffix "D" then
+              else if hasSuffix str "D" then
                 String.sub str 0 (l - 1), FDouble
               else
                 str, FDouble
@@ -3561,6 +3565,36 @@ and doExp (asconst: bool)   (* This expression is used as a constant *)
               finishExp empty res (typeOf res)
             end
         end
+        | A.CONST_COMPLEX str -> begin
+            (* Maybe it ends in U or UL. Strip those *)
+            let l = String.length str in
+            let baseint, kind =
+              if hasSuffix str "iL" then
+                String.sub str 0 (l - 2), FComplexLongDouble
+              else if hasSuffix str "iF" then
+                String.sub str 0 (l - 2), FComplexFloat
+              else if hasSuffix str "iD" then
+                String.sub str 0 (l - 2), FComplexDouble
+              else
+                str, FComplexDouble (* this is not ok *)
+            in
+            if kind = FLongDouble then
+              (* We only have 64-bit values in Ocaml *)
+              E.log "treating long double constant %s as double constant at %a.\n"
+                str d_loc !currentLoc;
+            try
+              finishExp empty
+                (Const(CReal(float_of_string baseint, kind,
+                             Some str)))
+                (TFloat(kind,[]))
+            with e -> begin
+              ignore (E.log "float_of_string_2 %s (%s)\n" baseint
+                        (Printexc.to_string e));
+              E.hadErrors := true;
+              let res = Const(CStr "booo CONS_FLOAT") in
+              finishExp empty res (typeOf res)
+            end
+        end
     end
 
     | A.TYPE_SIZEOF (bt, dt) ->

src/frontc/clexer.mll

@@ -184,7 +184,8 @@ let init_lexicon _ =
       ("__alignof__", fun loc -> ALIGNOF loc);
       ("__volatile__", fun loc -> VOLATILE loc);
       ("__volatile", fun loc -> VOLATILE loc);
-
+      ("__real__", fun loc -> REAL loc);
+      ("__imag__", fun loc -> IMAG loc);
       ("__FUNCTION__", fun loc -> FUNCTION__ loc);
       ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *)
       ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc);
@@ -436,6 +437,9 @@ let hexfloat = hexprefix hexfraction binexponent
 let floatsuffix = ['f' 'F' 'l' 'L']
 let floatnum = (decfloat | hexfloat) floatsuffix?
 
+let complexnum = (decfloat | hexfloat) ['i' 'I'] floatsuffix
+
+
 let ident = (letter|'_'|'$')(letter|decdigit|'_'|'$')*
 let blank = [' ' '\t' '\012' '\r']+
 let escape = '\\' _
@@ -502,6 +506,7 @@ rule initial =
                                                      ("wide string: " ^
                                                       Printexc.to_string e))}
 |		floatnum		{CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())}
+|   complexnum  {CST_COMPLEX (Lexing.lexeme lexbuf, currentLoc ())}
 |		hexnum			{CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
 |		octnum			{CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
 |		intnum			{CST_INT (Lexing.lexeme lexbuf, currentLoc ())}

src/frontc/cparser.mly

@@ -246,6 +246,7 @@ let transformOffsetOf (speclist, dtype) member =
 %token <int64 list * Cabs.cabsloc> CST_WCHAR
 %token <string * Cabs.cabsloc> CST_INT
 %token <string * Cabs.cabsloc> CST_FLOAT
+%token <string * Cabs.cabsloc> CST_COMPLEX
 %token <string * Cabs.cabsloc> NAMED_TYPE
 
 /* Each character is its own list element, and the terminating nul is not
@@ -291,7 +292,7 @@ let transformOffsetOf (speclist, dtype) member =
 %token<Cabs.cabsloc> IF TRY EXCEPT FINALLY
 %token ELSE
 
-%token<Cabs.cabsloc> ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__
+%token<Cabs.cabsloc> ATTRIBUTE INLINE ASM TYPEOF REAL IMAG FUNCTION__ PRETTY_FUNCTION__
 %token LABEL__
 %token<Cabs.cabsloc> BUILTIN_VA_ARG ATTRIBUTE_USED
 %token BUILTIN_VA_LIST
@@ -326,7 +327,7 @@ let transformOffsetOf (speclist, dtype) member =
 %left	INF_INF SUP_SUP
 %left	PLUS MINUS
 %left	STAR SLASH PERCENT CONST RESTRICT VOLATILE COMPLEX HIDDEN
-%right	EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF
+%right	EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF IMAG REAL
 %left 	LBRACKET
 %left	DOT ARROW LPAREN LBRACE
 %right  NAMED_TYPE     /* We'll use this to handle redefinitions of
@@ -527,6 +528,10 @@ unary_expression:   /*(* 6.5.3 *)*/
 		        {EXPR_SIZEOF (fst $2), $1}
 |	 	SIZEOF LPAREN type_name RPAREN
 		        {let b, d = $3 in TYPE_SIZEOF (b, d), $1}
+|	 	REAL cast_expression
+		        {REAL (fst $2), $1}
+|	 	IMAG cast_expression
+		        {IMAG (fst $2), $1}
 |		ALIGNOF unary_expression
 		        {EXPR_ALIGNOF (fst $2), $1}
 |	 	ALIGNOF LPAREN type_name RPAREN
@@ -687,6 +692,7 @@ expression:           /*(* 6.5.17 *)*/
 constant:
     CST_INT				{CONST_INT (fst $1), snd $1}
 |   CST_FLOAT				{CONST_FLOAT (fst $1), snd $1}
+|   CST_COMPLEX     {CONST_COMPLEX (fst $1), snd $1}
 |   CST_CHAR				{CONST_CHAR (fst $1), snd $1}
 |   CST_WCHAR				{CONST_WCHAR (fst $1), snd $1}
 |   string_constant		        {CONST_STRING (fst $1), snd $1}
@@ -1405,7 +1411,9 @@ postfix_attr:
  * that their arguments be expressions, not attributes *)*/
 unary_attr:
     postfix_attr                         { $1 }
-|   SIZEOF unary_expression              {EXPR_SIZEOF (fst $2) }
+|   SIZEOF unary_expression              { EXPR_SIZEOF (fst $2) }
+|   REAL unary_expression                { REAL (fst $2) }
+|   IMAG unary_expression                { IMAG (fst $2) }
 |   SIZEOF LPAREN type_name RPAREN
 		                         {let b, d = $3 in TYPE_SIZEOF (b, d)}
 

src/frontc/cprint.ml

@@ -507,6 +507,7 @@ and print_expression_level (lvl: int) (exp : expression) =
       (match cst with
 	CONST_INT i -> print i
       | CONST_FLOAT r -> print r
+      | CONST_COMPLEX r -> print r
       | CONST_CHAR c -> print ("'" ^ escape_wstring c ^ "'")
       | CONST_WCHAR c -> print ("L'" ^ escape_wstring c ^ "'")
       | CONST_STRING s -> print_string s