suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added better error messages for problems with C types in the backend

Browse Source
This commit is contained in:
Neil Brown 2009-05-19 12:58:22 +00:00
parent 2c7fc86533
commit 703bfe1afe
2 changed files with 9 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
backends/GenerateC.hs
View File

@ -701,7 +701,8 @@ cgenVariableWithAM checkValid v am fct
ct <- call getCType m t am >>* fct ct <- call getCType m t am >>* fct
-- Temporary, for debugging: -- Temporary, for debugging:
-- tell ["/* ", show (snd iv), " , trying to get: ", show ct, " */"] -- tell ["/* ", show (snd iv), " , trying to get: ", show ct, " */"]
dressUp m iv ct vtext <- showCode v
dressUp (m, "for variable: " ++ vtext) iv ct
where where
m = findMeta v m = findMeta v
@ -724,13 +725,15 @@ cgenVariableWithAM checkValid v am fct
return (do tell ["("] return (do tell ["("]
cast cast
tell ["(("] tell ["(("]
dressUp m (cg, ct) (Pointer $ Plain "mt_array_t") vtext <- showCode v
dressUp (m, "for variable: " ++ vtext) (cg, ct) (Pointer $ Plain "mt_array_t")
tell [")->data))"] tell [")->data))"]
, Pointer $ innerCT) , Pointer $ innerCT)
_ -> inner v _ -> inner v
inner wholeV@(A.DirectedVariable m dir v) inner wholeV@(A.DirectedVariable m dir v)
= do (cg, ctInner) <- inner v = do (cg, ctInner) <- inner v
let cg' = dressUp m (cg, ctInner) (stripPointers ctInner) vtext <- showCode v
let cg' = dressUp (m, "for variable: " ++ vtext) (cg, ctInner) (stripPointers ctInner)
t <- astTypeOf v t <- astTypeOf v
wholeT <- astTypeOf wholeV wholeT <- astTypeOf wholeV
ct <- call getCType m wholeT A.Original ct <- call getCType m wholeT A.Original

6
backends/GenerateCBased.hs
View File

@ -319,7 +319,7 @@ closeEnough _ _ = False
-- Given some code to generate, and its type, and the type that you actually want, -- Given some code to generate, and its type, and the type that you actually want,
-- adds the required decorators. Only pass it simplified types! -- adds the required decorators. Only pass it simplified types!
dressUp :: Meta -> (CGen (), CType) -> CType -> CGen () dressUp :: (Meta, String) -> (CGen (), CType) -> CType -> CGen ()
dressUp _ (gen, t) t' | t `closeEnough` t' = gen dressUp _ (gen, t) t' | t `closeEnough` t' = gen
--Every line after here is not close enough, so we know equality fails: --Every line after here is not close enough, so we know equality fails:
dressUp m (gen, Pointer t) (Pointer t') dressUp m (gen, Pointer t) (Pointer t')
@ -332,8 +332,8 @@ dressUp m (gen, t) (Pointer t')
= dressUp m (tell ["&"] >> gen, t) t' = dressUp m (tell ["&"] >> gen, t) t'
dressUp m (gen, Pointer t) t' dressUp m (gen, Pointer t) t'
= dressUp m (tell ["*"] >> gen, t) t' = dressUp m (tell ["*"] >> gen, t) t'
dressUp m (gen, t) t' dressUp (m, s) (gen, t) t'
= dieP m $ "Types cannot be brought together: " ++ show t ++ " and " ++ show t' = dieP m $ "Types cannot be brought together (" ++ s ++ "): " ++ show t ++ " and " ++ show t'
genType :: A.Type -> CGen () genType :: A.Type -> CGen ()
genType t = do ct <- call getCType emptyMeta t A.Original genType t = do ct <- call getCType emptyMeta t A.Original