Skip to content
Snippets Groups Projects
Commit fbde250c authored by chrg's avatar chrg
Browse files

A semiworking version recovered

parent e501950f
No related branches found
No related tags found
No related merge requests found
Showing
with 772 additions and 438 deletions
--failure-report .hspec-failures
--fail-fast
--rerun
......@@ -5,10 +5,12 @@
module CType where
import Control.Monad
import Data.Function
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe
import GHC.Stack
import Language.C (Pos (posOf))
import qualified Language.C as C
data Params
......@@ -29,6 +31,9 @@ data StructType = StructType
}
deriving (Show, Eq)
fieldLookup :: C.Ident -> StructType -> Maybe Type
fieldLookup i = join . List.lookup i . structTypeFields
data Type
= TNum
| TStruct !StructType
......@@ -66,18 +71,33 @@ typeOf
-> TypeDefLookup
-> [C.CDeclarationSpecifier C.NodeInfo]
-> C.CDeclarator C.NodeInfo
-> Maybe Voidable
typeOf structLookup typeDefLookup spec decl =
baseTypeOf structLookup typeDefLookup spec
>>= extendTypeWith
structLookup
typeDefLookup
decl
extendTypeWith
:: (HasCallStack)
=> StructLookup
-> TypeDefLookup
-> C.CDeclarator C.NodeInfo
-> Voidable
typeOf structLookup typeDefLookup spec (C.CDeclr _ dd _ _ _) =
foldr applyDD (baseTypeOf structLookup typeDefLookup spec) dd
-> Maybe Voidable
extendTypeWith structLookup typeDefLookup (C.CDeclr _ dd _ _ _) t =
foldr applyDD (Just t) dd
where
applyDD :: C.CDerivedDeclarator C.NodeInfo -> Voidable -> Voidable
applyDD :: C.CDerivedDeclarator C.NodeInfo -> Maybe Voidable -> Maybe Voidable
applyDD = \case
C.CPtrDeclr _ _ -> NonVoid . TPointer
C.CArrDeclr{} -> NonVoid . TPointer
C.CPtrDeclr _ _ -> fmap (NonVoid . TPointer)
C.CArrDeclr{} -> fmap (NonVoid . TPointer)
C.CFunDeclr params _ ni -> \c ->
case params of
C.CFunParamsNew params' varadic -> do
NonVoid $ TFun (FunType c (findParams varadic params'))
c' <- c
Just $ NonVoid $ TFun (FunType c' (findParams varadic params'))
b -> notSupportedYet b ni
findParams :: Bool -> [C.CDeclaration C.NodeInfo] -> Params
......@@ -85,9 +105,9 @@ typeOf structLookup typeDefLookup spec (C.CDeclr _ dd _ _ _) =
[C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> VoidParams
rst -> flip Params varadic $ flip map rst \case
C.CDecl spec' [] _ ->
Just . nonVoid $ baseTypeOf structLookup typeDefLookup spec'
nonVoid <$> baseTypeOf structLookup typeDefLookup spec'
C.CDecl spec' [C.CDeclarationItem decl _ _] _ ->
Just . nonVoid $ typeOf structLookup typeDefLookup spec' decl
nonVoid <$> typeOf structLookup typeDefLookup spec' decl
a -> notSupportedYet' a
typeSpecs :: [C.CDeclarationSpecifier a] -> [C.CTypeSpecifier a]
......@@ -100,9 +120,10 @@ baseTypeOf
=> StructLookup
-> TypeDefLookup
-> [C.CDeclarationSpecifier C.NodeInfo]
-> Voidable
-> Maybe Voidable
baseTypeOf structLookup typeDefLookup =
maybe
fmap
( maybe
(error "no type in type-specs")
( \case
(t, []) -> NonEmpty.head t
......@@ -110,25 +131,23 @@ baseTypeOf structLookup typeDefLookup =
)
. List.uncons
. NonEmpty.group
. map \case
C.CVoidType _ -> Void
C.CCharType _ -> NonVoid TNum
C.CShortType _ -> NonVoid TNum
C.CIntType _ -> NonVoid TNum
C.CFloatType _ -> NonVoid TNum
C.CDoubleType _ -> NonVoid TNum
C.CSignedType _ -> NonVoid TNum
C.CUnsigType _ -> NonVoid TNum
C.CBoolType _ -> NonVoid TNum
C.CLongType _ -> NonVoid TNum
C.CInt128Type _ -> NonVoid TNum
C.CFloatNType{} -> NonVoid TNum
C.CSUType c _ -> NonVoid (TStruct $ structTypeOf structLookup typeDefLookup c)
C.CEnumType _ _ -> NonVoid TNum
C.CTypeDef idx _ ->
case typeDefLookup idx of
Just t -> NonVoid t
Nothing -> error ("could not find typedef: " <> show (C.identToString idx))
)
. mapM \case
C.CVoidType _ -> Just Void
C.CSUType c _ -> NonVoid . TStruct <$> structTypeOf structLookup typeDefLookup c
C.CCharType _ -> Just $ NonVoid TNum
C.CShortType _ -> Just $ NonVoid TNum
C.CIntType _ -> Just $ NonVoid TNum
C.CFloatType _ -> Just $ NonVoid TNum
C.CDoubleType _ -> Just $ NonVoid TNum
C.CSignedType _ -> Just $ NonVoid TNum
C.CUnsigType _ -> Just $ NonVoid TNum
C.CBoolType _ -> Just $ NonVoid TNum
C.CLongType _ -> Just $ NonVoid TNum
C.CInt128Type _ -> Just $ NonVoid TNum
C.CFloatNType{} -> Just $ NonVoid TNum
C.CEnumType _ _ -> Just $ NonVoid TNum
C.CTypeDef idx _ -> NonVoid <$> typeDefLookup idx
a -> notSupportedYet (void a) a
. typeSpecs
......@@ -137,29 +156,17 @@ structTypeOf
=> StructLookup
-> TypeDefLookup
-> C.CStructureUnion C.NodeInfo
-> StructType
structTypeOf structLookup typeDefLookup (C.CStruct t mi md _ _) =
-> Maybe StructType
structTypeOf structLookup typeDefLookup (C.CStruct t mi md _ ni) =
case mi of
Just ix ->
case md of
Just p -> do
let p' = concatMap (namesAndTypeOf structLookup typeDefLookup) p
case structLookup ix of
Just s
| structTypeFields s == p' -> s
| otherwise -> error "what?"
Just ix -> structLookup ix
Nothing ->
StructType
{ structTypeTag = t
, structTypeName = mi
, structTypeFields = p'
}
Nothing ->
case structLookup ix of
Just s -> s
Nothing -> error "what!?"
Nothing -> do
let p' = maybe (error "what??") (concatMap (namesAndTypeOf structLookup typeDefLookup)) md
let p' =
maybe
(error $ "invalid struct at" <> show (C.posOf ni))
(concatMap (namesAndTypeOf structLookup typeDefLookup))
md
in Just $
StructType
{ structTypeTag = t
, structTypeName = mi
......@@ -176,7 +183,7 @@ namesAndTypeOf structLookup typeDefLookup = \case
C.CDecl spec items ni ->
flip map items \case
C.CDeclarationItem decl@(C.CDeclr (Just ix) _ _ _ _) _ _ ->
(ix, Just . nonVoid $ typeOf structLookup typeDefLookup spec decl)
(ix, nonVoid <$> typeOf structLookup typeDefLookup spec decl)
a -> notSupportedYet (void a) ni
a -> notSupportedYet' a
......
This diff is collapsed.
static int g_62 = 3L;
static int * g_116 = &g_62;
void main () { }
int *a,b;
int main () {
*a = b;
}
int *a, b;
int main () {
return a == &b;
}
......@@ -10,5 +10,5 @@ int add(int a, int b)
}
int main()
{
return 10;
return 23;
}
......@@ -9,5 +9,5 @@ int add(int a, int b)
}
int main()
{
return 23;
return 10;
}
......@@ -10,5 +10,5 @@ int add(int a)
}
int main()
{
return 10;
return 23;
}
......@@ -9,5 +9,5 @@ int add(int a)
}
int main()
{
return 23;
return 10;
}
......@@ -10,5 +10,5 @@ int add(int b)
}
int main()
{
return add(23);
return add(10);
}
......@@ -10,5 +10,5 @@ int add(int b)
}
int main()
{
return 10;
return 23;
}
......@@ -9,5 +9,5 @@ int add(int b)
}
int main()
{
return 23;
return 10;
}
......@@ -10,5 +10,5 @@ int add()
}
int main()
{
return 10;
return 23;
}
......@@ -9,5 +9,5 @@ int add()
}
int main()
{
return 23;
return 10;
}
......@@ -4,5 +4,5 @@
int main()
{
return 10;
return 23;
}
......@@ -4,5 +4,5 @@
int main()
{
return 23;
return 10;
}
static int g_62 = 3L;
static int * g_116 = &g_62;
void main()
{
}
// 0 inline variable g_62 at ("test/cases/small/addr.c": line 1)
// 0 delete variable at ("test/cases/small/addr.c": line 2)
static int g_62 = 3L;
static int * g_116 = &g_62;
void main()
{
}
// 0 inline variable g_62 at ("test/cases/small/addr.c": line 1)
// 1 delete variable at ("test/cases/small/addr.c": line 2)
static int g_62 = 3L;
void main()
{
}
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment