├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app ├── FindType.hs ├── FindUnit.hs ├── Main.hs ├── Monad │ └── Analysis.hs ├── SymTab.hs ├── Type.hs └── Unit.hs ├── doc └── examples │ ├── bad1.c │ ├── bad2a.c │ ├── bad2b.c │ ├── bad2c.c │ ├── bad3a.c │ ├── bad3b.c │ ├── bad6a.c │ ├── bad6b.c │ ├── bad_arith_1.c │ ├── bad_arith_2.c │ ├── bad_conditional_1.c │ ├── bad_conditional_2.c │ ├── bad_fn_ptr.c │ ├── bad_label.c │ ├── bad_poly_init.c │ ├── bad_redefine_1.c │ ├── bad_redefine_2.c │ ├── bad_redefine_3.c │ ├── bad_switch_case.c │ ├── bad_switch_cases.c │ ├── bad_switch_default.c │ ├── bad_typeof.c │ ├── good1.c │ ├── good2.c │ ├── good3.c │ ├── good4.c │ ├── good5.c │ ├── good6.c │ ├── good8.c │ ├── good_alignof.c │ ├── good_anonymous_struct_union.c │ ├── good_arith.c │ ├── good_array.c │ ├── good_asm.c │ ├── good_assignment_ops.c │ ├── good_bool.c │ ├── good_cast.c │ ├── good_comparisons.c │ ├── good_compound_lit.c │ ├── good_conditional.c │ ├── good_empty_stmt.c │ ├── good_enum.c │ ├── good_fn_ptr.c │ ├── good_for.c │ ├── good_func.c │ ├── good_function_arg.c │ ├── good_gcc_builtins.c │ ├── good_goto.c │ ├── good_indirection.c │ ├── good_initializers.c │ ├── good_math.c │ ├── good_math_builtins.c │ ├── good_member.c │ ├── good_nested_functions.c │ ├── good_nested_struct.c │ ├── good_null.c │ ├── good_posix_headers.c │ ├── good_ptr_arith.c │ ├── good_ptr_fn.c │ ├── good_selfref.c │ ├── good_sizeof.c │ ├── good_sqrt.c │ ├── good_standard_c_headers.c │ ├── good_statement_expession.c │ ├── good_static_assert.c │ ├── good_stdio.c │ ├── good_stdlib.c │ ├── good_switch.c │ ├── good_typedef.c │ ├── good_typeof.c │ ├── good_unistd.c │ ├── good_void_return.c │ ├── good_voidarglist.c │ ├── good_voidstar.c │ ├── good_voidstar_cond.c │ ├── good_voidstar_eq_ne.c │ ├── good_while.c │ └── good_xmmintrin.c ├── stack.yaml ├── testsuite ├── examples.sh └── runtests.sh └── unitc.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | .stack-work 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .virtualenv 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *~ 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Magnus Jonsson 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # unitc 2 | Dimensional analysis for the C programming language. Lets programmers annotate C source code with units such as meters or feet, and have them automatically checked. 3 | 4 | Build: `stack build` 5 | 6 | Example invocation: `stack exec unitc doc/examples/bad1.c` 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/FindType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module FindType where 4 | 5 | import FindUnit 6 | import Monad.Analysis 7 | import qualified SymTab 8 | import Type 9 | import qualified Unit 10 | import Data.List (isPrefixOf) 11 | 12 | import Control.Monad 13 | import Language.C.Pretty 14 | import Language.C.Data.Node 15 | import Language.C.Data.Position 16 | import Language.C.Data.Ident 17 | import Language.C.Syntax.AST 18 | import Language.C.Syntax.Constants 19 | 20 | class FindType a where 21 | findType :: a -> Analysis (Maybe Type) 22 | 23 | instance FindType CExpr where 24 | findType expr = 25 | case expr of 26 | CComma es _ -> liftM last (mapM findType es) 27 | CAssign op e1 e2 _ -> 28 | do mt1 <- findType e1 29 | mt2 <- findType e2 30 | mt1' <- case op of 31 | CAssignOp -> return mt2 32 | CAddAssOp -> combineTypes expr "can't be added" Type.add mt1 mt2 33 | CSubAssOp -> combineTypes expr "can't be subtracted" Type.sub mt1 mt2 34 | CMulAssOp -> combineTypes expr "can't be multiplied" Type.mul mt1 mt2 35 | CDivAssOp -> combineTypes expr "can't be divided" Type.div mt1 mt2 36 | CRmdAssOp -> combineTypes expr "can't be remaindered" Type.rem mt1 mt2 37 | CShlAssOp -> combineTypes expr "can't be shifted" Type.shl mt1 mt2 38 | CShrAssOp -> combineTypes expr "can't be shifted" Type.shr mt1 mt2 39 | COrAssOp -> combineTypes expr "can't be ored" Type.or mt1 mt2 40 | CAndAssOp -> combineTypes expr "can't be anded" Type.and mt1 mt2 41 | CXorAssOp -> combineTypes expr "can't be xored" Type.xor mt1 mt2 42 | case (mt1, mt2, mt1') of 43 | (Just t1, Just t2, Just t1') -> 44 | if Type.assignable t1 t1' then 45 | return () 46 | else 47 | err expr ("Can't assign to type " ++ show t1 ++ " from type " ++ show t1') 48 | _ -> return () 49 | return mt1 50 | CCond e1 (Just e2) e3 _ -> 51 | do t1 <- findType e1 52 | _ <- combineTypes expr "don't match" Type.add t1 (Just Type.one) 53 | t2 <- findType e2 54 | t3 <- findType e3 55 | case (t2, t3) of 56 | (Nothing, _) -> return Nothing 57 | (_, Nothing) -> return Nothing 58 | (Just t2', Just t3') -> 59 | if Type.assignable t2' t3' then 60 | return t2 61 | else if Type.assignable t3' t2' then 62 | return t3 63 | else 64 | err expr ("Types don't match: " ++ show t2' ++ " and " ++ show t3') >> return Nothing 65 | CCond e1 Nothing e3 _ -> err expr "TODO findType CCond" >> return Nothing 66 | CBinary op e1 e2 _ -> 67 | do t1 <- findType e1 68 | t2 <- findType e2 69 | case op of 70 | CEqOp -> do _ <- combineTypes expr "can't be compared" Type.cmp t1 t2; return (Just Type.one) 71 | CNeqOp -> do _ <- combineTypes expr "can't be compared" Type.cmp t1 t2; return (Just Type.one) 72 | CLeOp -> do _ <- combineTypes expr "can't be compared" Type.cmp t1 t2; return (Just Type.one) 73 | CGrOp -> do _ <- combineTypes expr "can't be compared" Type.cmp t1 t2; return (Just Type.one) 74 | CLeqOp -> do _ <- combineTypes expr "can't be compared" Type.cmp t1 t2; return (Just Type.one) 75 | CGeqOp -> do _ <- combineTypes expr "can't be compared" Type.cmp t1 t2; return (Just Type.one) 76 | CAddOp -> combineTypes expr "can't be added" Type.add t1 t2 77 | CSubOp -> combineTypes expr "can't be subtracted" Type.sub t1 t2 78 | CMulOp -> combineTypes expr "can't be multiplied" Type.mul t1 t2 79 | CDivOp -> combineTypes expr "can't be divided" Type.div t1 t2 80 | CRmdOp -> combineTypes expr "can't be used in remainder operation" Type.rem t1 t2 81 | CShlOp -> do _ <- combineTypes expr "can't be unified" Type.shl t2 (Just Type.one); return t1 82 | CShrOp -> do _ <- combineTypes expr "can't be unified" Type.shr t2 (Just Type.one); return t1 83 | COrOp -> combineTypes expr "can't be unified" Type.or t1 t2 84 | CAndOp -> combineTypes expr "can't be unified" Type.and t1 t2 85 | CLorOp -> combineTypes expr "can't be unified" Type.lor t1 t2 86 | CLndOp -> combineTypes expr "can't be unified" Type.land t1 t2 87 | CXorOp -> combineTypes expr "can't be unified" Type.xor t1 t2 88 | CCast (CDecl specs triplets _) e _ -> 89 | do td <- findType specs 90 | te <- findType e 91 | td' <- case triplets of 92 | [] -> return td 93 | [(Just declr, Nothing, Nothing)] -> deriveTypeFromCDeclr td declr 94 | _ -> err expr "TODO findType CCast with strange triplets" >> return Nothing 95 | return (fmap Type.monomorphize td') 96 | CCast (CStaticAssert _ _ _) e _ -> err expr "TODO findType CCast with CStaticAssert" >> return Nothing 97 | CUnary op e _ -> 98 | do t <- findType e 99 | case op of 100 | CPreIncOp -> combineTypes expr "can't be added" Type.add t (Just Type.one) 101 | CPreDecOp -> combineTypes expr "can't be subtracted" Type.add t (Just Type.one) 102 | CPostIncOp -> combineTypes expr "can't be added" Type.add t (Just Type.one) 103 | CPostDecOp -> combineTypes expr "can't be subtracted" Type.add t (Just Type.one) 104 | CAdrOp -> case t of 105 | Nothing -> return Nothing 106 | Just t' -> return (Just (Ptr t')) 107 | CIndOp -> case t of 108 | Nothing -> return Nothing 109 | Just t' -> 110 | case Type.deref t' of 111 | Nothing -> err expr ("Can't dereference non-pointer type: " ++ show t) >> return Nothing 112 | Just t'' -> return (Just t'') 113 | CPlusOp -> combineTypes expr "can't be plus-signed" Type.mul t (Just Type.one) 114 | CMinOp -> combineTypes expr "can't be minus-signed" Type.mul t (Just Type.one) 115 | CCompOp -> combineTypes expr "can't be complemented" Type.xor t (Just Type.one) >> return (Just Type.one) 116 | CNegOp -> case t of 117 | Nothing -> return Nothing 118 | Just t' -> 119 | case Type.neg t' of 120 | Nothing -> err expr ("Type can't be logically negated: " ++ show t') >> return Nothing 121 | Just t'' -> return (Just t'') 122 | CSizeofExpr e _ -> do _ <- findType e 123 | return (Just one) 124 | CSizeofType decl _ -> return (Just one) 125 | CAlignofExpr e _ -> return (Just one) 126 | CAlignofType decl _ -> return (Just one) 127 | CComplexReal e _ -> err expr "TODO findType CComplexReal" >> return Nothing 128 | CComplexImag e _ -> err expr "TODO findType CComplexImag" >> return Nothing 129 | CIndex e1 e2 _ -> do t1 <- findType e1 130 | t2 <- findType e2 131 | case t2 of 132 | Nothing -> return () 133 | Just t2' -> 134 | if Type.assignable Type.one t2' then 135 | return () 136 | else 137 | err expr ("Subscript type is not numeric with unit 1: " ++ show t2) 138 | case t1 of 139 | Nothing -> return Nothing 140 | Just (Arr t1') -> return (Just t1') 141 | Just (Ptr t1') -> return (Just t1') 142 | Just (Numeric _) -> return t1 -- for vectors, since we don't track the __vector_size__ attribute in our type system 143 | Just _ -> err expr ("Not an array or pointer: " ++ show t1) >> return Nothing 144 | CCall (CVar (Ident name _ _) _) [e1] _ | elem name ["fabs", "fabsf", "fabsl", "abs", "labs", "llabs", "imaxabs"] -> 145 | do t1 <- findType e1 146 | case t1 of 147 | Nothing -> return Nothing 148 | Just t1' -> 149 | case Type.abs t1' of 150 | Nothing -> err expr ("Can't take the absolute value of " ++ show t1) >> return Nothing 151 | Just t1'' -> return (Just t1'') 152 | CCall (CVar (Ident name _ _) _) [e1, e2] _ | name == "fmin" || name == "fminf" || name == "fminl" -> 153 | do t1 <- findType e1 154 | t2 <- findType e2 155 | combineTypes expr "can't be taken the min of" Type.min t1 t2 156 | CCall (CVar (Ident name _ _) _) [e1, e2] _ | name == "fmax" || name == "fmaxf" || name == "fmaxl" -> 157 | do t1 <- findType e1 158 | t2 <- findType e2 159 | combineTypes expr "can't be taken the max of" Type.max t1 t2 160 | CCall (CVar (Ident name _ _) _) [e] _ | name == "sqrt" || name == "sqrtf" || name == "sqrtl" -> 161 | do t <- findType e 162 | return (t >>= Type.sqrt) 163 | 164 | CCall e1 es _ -> 165 | do t1 <- findType e1 166 | actuals <- mapM findType es 167 | case t1 of 168 | Nothing -> return Nothing 169 | Just (Fun rt formals acceptsVarArgs) -> 170 | do checkArgs (nodeInfo expr) actuals formals acceptsVarArgs 171 | return (Just rt) 172 | Just (Ptr (Fun rt formals acceptsVarArgs)) -> 173 | do checkArgs (nodeInfo expr) actuals formals acceptsVarArgs 174 | return (Just rt) 175 | Just _ -> 176 | do err expr ("Non-function called as a function: " ++ show (pretty e1)) 177 | return Nothing 178 | CMember e (Ident field _ _) deref _ -> 179 | do ty <- findType e 180 | ty' <- if deref then 181 | case ty of 182 | Nothing -> return Nothing 183 | Just (Ptr t) -> return (Just t) 184 | Just t -> err expr ("Not a pointer: " ++ show t) >> return Nothing 185 | else 186 | return ty 187 | fieldinfo <- getField expr ty' field 188 | case fieldinfo of 189 | Nothing -> return Nothing 190 | Just (index, ty'') -> return (Just ty'') 191 | CVar (Ident name _ _) _ -> do st <- getSymTab 192 | case SymTab.lookupVariable name st of 193 | Nothing -> do unless ("__builtin_" `isPrefixOf` name) $ 194 | err expr ("Variable not in scope: " ++ name) 195 | return Nothing 196 | Just ty -> return (Just ty) 197 | CConst c -> findType c 198 | CCompoundLit (CDecl specs triplets _) initList _ -> 199 | do tspecs <- findType specs 200 | case triplets of 201 | [] -> return () 202 | _ -> err expr "TODO CCompoundLit with triplets" 203 | checkInitList tspecs (Just 0) initList 204 | return tspecs 205 | CCompoundLit (CStaticAssert _ _ _ ) e _ -> err expr "TODO findType CCompoundLit with CStaticAssert" >> return Nothing 206 | CStatExpr stat _ -> findType stat 207 | CLabAddrExpr ident _ -> err expr "TODO findType CLabAddrExpr" >> return Nothing 208 | CBuiltinExpr builtin -> findType builtin 209 | CGenericSelection _ _ _ -> err expr "TODO findType CGenericSelection" >> return Nothing 210 | 211 | instance FindType CBuiltin where 212 | findType builtin = 213 | case builtin of 214 | CBuiltinVaArg e d _ -> err builtin "FindType CBuiltinVaArg" >> return Nothing 215 | CBuiltinOffsetOf _ _ _ -> return (Just Type.one) 216 | CBuiltinTypesCompatible decl1 decl2 _ -> err builtin "FindType CBuiltinTypesCompatible" >> return Nothing 217 | CBuiltinConvertVector _ _ _ -> err builtin "FindType CBuiltinConvertVector" >> return Nothing 218 | 219 | combineTypes :: Pos a => a -> String -> (Type -> Type -> Maybe Type) -> Maybe Type -> Maybe Type -> Analysis (Maybe Type) 220 | combineTypes pos msg f t1 t2 = 221 | case (t1, t2) of 222 | (Just t1', Just t2') -> 223 | case f t1' t2' of 224 | Nothing -> err pos ("type " ++ show t1 ++ " and " ++ show t2 ++ " " ++ msg) >> return Nothing 225 | Just ty -> return (Just ty) 226 | _ -> return Nothing 227 | 228 | checkCompatibility :: Pos a => a -> Type -> Type -> Analysis () 229 | checkCompatibility pos t1 t2 = 230 | if t1 /= t2 then 231 | err pos ("incompatible types: " ++ show t1 ++ ", " ++ show t2) 232 | else 233 | return () 234 | 235 | checkArgs :: NodeInfo -> [Maybe Type] -> [Type] -> Bool -> Analysis () 236 | checkArgs node actuals formals acceptVarArgs = 237 | case (actuals, formals, acceptVarArgs) of 238 | ([], [], _) -> return () 239 | ([], _, _) -> err node "Too few args" 240 | (_, [], True) -> return () 241 | (_, [], False) -> err node "Too many args" 242 | (Nothing : as, f : fs, _) -> 243 | checkArgs node as fs acceptVarArgs 244 | (Just a : as, f : fs, _) -> 245 | do if Type.assignable f a then 246 | return () 247 | else 248 | err node ("Argument type mismatch. Found " ++ show a ++ ", expected " ++ show f ++ ".") 249 | checkArgs node as fs acceptVarArgs 250 | 251 | instance FindType CConst where 252 | findType c = 253 | case c of 254 | CIntConst (CInteger i _ f) _ -> 255 | if i == 0 && f == noFlags then 256 | return (Just Zero) 257 | else 258 | return (Just (Numeric (Just Unit.one))) 259 | CCharConst _ _ -> return (Just (Numeric (Just Unit.one))) 260 | CFloatConst _ _ -> return (Just (Numeric (Just Unit.one))) 261 | CStrConst _ _ -> return (Just (Arr (Numeric (Just Unit.one)))) 262 | 263 | instance FindType CStat where 264 | findType stat = 265 | case stat of 266 | CLabel _ s _ _ -> findType s 267 | CCase e s _ -> findType s 268 | CCases e1 e2 s _ -> findType s 269 | CDefault s _ -> findType s 270 | CExpr Nothing _ -> return (Just Void) 271 | CExpr (Just e) _ -> findType e 272 | CCompound _ blockItems _ -> blockType blockItems 273 | CIf e s1 Nothing _ -> do te <- findType e 274 | t1 <- findType s1 275 | return (Just Void) 276 | CIf e s1 (Just s2) _ -> do te <- findType e 277 | t1 <- findType s1 278 | t2 <- findType s2 279 | return (Just Void) 280 | CSwitch e b _ -> do te <- findType e 281 | case te of 282 | Nothing -> return () 283 | Just te' -> 284 | if Type.assignable (Type.one) te' then 285 | return () 286 | else 287 | err stat "Switch expression must be numeric of unit 1" 288 | tb <- findType b 289 | return (Just Void) 290 | CWhile e b _ _ -> do te <- findType e 291 | tb <- findType b 292 | return (Just Void) 293 | CFor init cond incr body _ -> 294 | do modifySymTab SymTab.openScope 295 | case init of 296 | Left Nothing -> return () 297 | Left (Just expr) -> findType expr >> return () 298 | Right decl -> applyCDecl decl 299 | case cond of 300 | Nothing -> return () 301 | Just cond' -> findType cond' >> return () 302 | case incr of 303 | Nothing -> return () 304 | Just incr' -> findType incr' >> return () 305 | ty <- findType body 306 | modifySymTab SymTab.closeScope 307 | return (Just Void) 308 | CGoto _ _ -> return (Just Void) 309 | CGotoPtr e _ -> err stat "TODO findType CGotoPtr" >> return (Just Void) 310 | CCont _ -> return (Just Void) 311 | CBreak _ -> return (Just Void) 312 | CReturn e _ -> 313 | do ty <- case e of 314 | Nothing -> return (Just Void) 315 | Just e' -> findType e' 316 | st <- getSymTab 317 | case SymTab.returnType st of 318 | Nothing -> err stat "Encountered return statement but not sure what return type is expected!" 319 | Just r -> 320 | case ty of 321 | Nothing -> return () 322 | Just ty' -> 323 | if Type.assignable r ty' then 324 | return () 325 | else 326 | err stat ("Type " ++ show ty ++ " does not agree with return type " ++ show r) 327 | return (Just Void) 328 | CAsm _ _ -> return (Just Void) 329 | 330 | instance FindType CDeclSpec where 331 | findType declSpec = 332 | case declSpec of 333 | CStorageSpec _ -> return Nothing 334 | CTypeSpec typeSpec -> findType typeSpec 335 | CTypeQual typeQual -> findType typeQual 336 | CFunSpec _ -> return Nothing 337 | CAlignSpec _ -> return Nothing 338 | 339 | instance FindType CTypeSpec where 340 | findType typeSpec = 341 | case typeSpec of 342 | CVoidType _ -> return (Just Void) 343 | CCharType _ -> return (Just (Numeric Nothing)) 344 | CShortType _ -> return (Just (Numeric Nothing)) 345 | CIntType _ -> return (Just (Numeric Nothing)) 346 | CLongType _ -> return (Just (Numeric Nothing)) 347 | CFloatType _ -> return (Just (Numeric Nothing)) 348 | CDoubleType _ -> return (Just (Numeric Nothing)) 349 | CSignedType _ -> return (Just (Numeric Nothing)) 350 | CUnsigType _ -> return (Just (Numeric Nothing)) 351 | CBoolType _ -> return (Just (Numeric Nothing)) 352 | CComplexType _ -> return (Just (Numeric Nothing)) 353 | CSUType csu _ -> findType csu 354 | CEnumType ce _ -> findType ce 355 | CTypeDef (Ident name _ _) _ -> 356 | do st <- getSymTab 357 | case SymTab.lookupType name st of 358 | Just ty -> return (Just ty) 359 | Nothing -> do err typeSpec ("Could not find typedef: " ++ name) 360 | return Nothing 361 | CTypeOfExpr e _ -> findType e 362 | CTypeOfType t _ -> 363 | do err typeSpec "CTypeSpec: typeof(type) type specifiers not yet handled" 364 | return Nothing 365 | CInt128Type _ -> return (Just (Numeric Nothing)) 366 | CFloatNType _ _ _ -> return (Just (Numeric Nothing)) 367 | CAtomicType t _ -> 368 | do err typeSpec "CTypeSpec: _Atomic(type) type specifiers not yet handled" 369 | return Nothing 370 | 371 | instance FindType CStructUnion where 372 | findType csu = 373 | do name <- 374 | case csu of 375 | CStruct _ (Just (Ident name _ _)) _ _ _ -> 376 | return name 377 | CStruct _ Nothing _ _ _ -> 378 | gensym 379 | case csu of 380 | CStruct _ _ Nothing _ _ -> return () 381 | CStruct _ _ (Just fields) _ _ -> 382 | do modifySymTab SymTab.openScope 383 | mapM_ applyCDeclInStruct fields 384 | fieldSymTab <- getSymTab 385 | modifySymTab (SymTab.bindTag name (reverse (SymTab.variablesRevList fieldSymTab))) 386 | modifySymTab SymTab.closeScope 387 | return (Just (Struct name)) 388 | 389 | 390 | instance FindType CEnum where 391 | findType enum = 392 | -- we ignore the name of enums. All we care about is that they're numeric. 393 | -- we don't support unit annotations on enums. 394 | case enum of 395 | CEnum _ Nothing _ _ -> return (Just (Numeric Nothing)) 396 | CEnum _ (Just bindings) _ _ -> 397 | do mapM_ applyEnumBinding bindings 398 | return (Just (Numeric (Just Unit.one))) 399 | 400 | applyEnumBinding :: (Ident, Maybe CExpr) -> Analysis () 401 | applyEnumBinding (ident, maybeExpr) = 402 | case ident of 403 | Ident name _ _ -> 404 | do case maybeExpr of 405 | Nothing -> return () 406 | Just e -> do ty <- findType e 407 | case ty of 408 | Nothing -> return () 409 | Just ty' -> 410 | if Type.assignable Type.one ty' then 411 | return () 412 | else 413 | err e ("Expected numeric with unit 1, got " ++ show ty') 414 | modifySymTab (SymTab.bindGlobalVariable name (Numeric (Just Unit.one))) 415 | 416 | instance FindType CTypeQual where 417 | findType typeQual = 418 | case typeQual of 419 | CConstQual _ -> return Nothing 420 | CVolatQual _ -> return Nothing 421 | CRestrQual _ -> return Nothing 422 | CAttrQual attr -> findType attr 423 | CAtomicQual _ -> return Nothing 424 | CNullableQual _ -> return Nothing 425 | CNonnullQual _ -> return Nothing 426 | CClRdOnlyQual _ -> return Nothing 427 | CClWrOnlyQual _ -> return Nothing 428 | 429 | instance FindType CAttr where 430 | findType attr = 431 | do unit <- findUnit attr 432 | case unit of 433 | Nothing -> return Nothing 434 | Just u -> return (Just (Numeric (Just u))) 435 | 436 | instance FindType a => FindType [a] where 437 | findType list = 438 | do ts <- mapM findType list 439 | return (foldl Type.mergeMaybe Nothing ts) 440 | 441 | blockType :: [CBlockItem] -> Analysis (Maybe Type) 442 | blockType items = 443 | do modifySymTab SymTab.openScope 444 | types <- mapM applyBlockItem items 445 | modifySymTab SymTab.closeScope 446 | case types of 447 | [] -> return Nothing 448 | _ -> return (last types) 449 | 450 | applyBlockItem :: CBlockItem -> Analysis (Maybe Type) 451 | applyBlockItem item = 452 | case item of 453 | CBlockStmt stmt -> findType stmt 454 | CBlockDecl decl -> do applyCDecl decl 455 | return (Just Void) 456 | CNestedFunDef f -> do applyCFunDef f 457 | return (Just Void) 458 | 459 | applyCDecl :: CDecl -> Analysis () 460 | applyCDecl decl = 461 | case decl of 462 | CDecl declSpecs triplets _ -> 463 | do ty <- findType declSpecs 464 | typeInitPairs <- mapM (applyTriplet decl ty (isTypeDef declSpecs)) triplets 465 | mapM_ (initTriplet decl) typeInitPairs 466 | CStaticAssert e str _ -> 467 | do ty <- findType e 468 | return () 469 | 470 | applyCDeclInStruct :: CDecl -> Analysis () 471 | applyCDeclInStruct decl = 472 | -- handle any anonymous struct/union specially 473 | case decl of 474 | CDecl declSpecs [] _ -> 475 | let loop [] = applyCDecl decl 476 | loop (CTypeSpec (CSUType (CStruct _ Nothing (Just fields) _ _) _) : _) = mapM_ applyCDeclInStruct fields 477 | loop (_ : rest) = loop rest 478 | in loop declSpecs 479 | _ -> applyCDecl decl 480 | 481 | type Triplet = (Maybe CDeclr, Maybe CInit, Maybe CExpr) 482 | 483 | isTypeDef :: [CDeclSpec] -> Bool 484 | isTypeDef = 485 | any (\ spec -> 486 | case spec of 487 | (CStorageSpec (CTypedef _)) -> True 488 | _ -> False) 489 | 490 | deriveTypeFromCDeclr :: Maybe Type -> CDeclr -> Analysis (Maybe Type) 491 | deriveTypeFromCDeclr declSpecTy (CDeclr _ derivedDeclrs _ attrs pos) = 492 | do attrType <- findType attrs 493 | deriveType derivedDeclrs (Type.mergeMaybe declSpecTy attrType) 494 | 495 | checkInitializer :: Maybe Type -> CInit -> Analysis () 496 | checkInitializer ty initr = 497 | case initr of 498 | CInitExpr e _ -> 499 | do initType <- findType e 500 | case (ty, initType) of 501 | (Just ty', Just initType') -> 502 | if Type.assignable ty' initType' then 503 | return () 504 | else 505 | err e ("Can't initialize " ++ show ty' ++ " from " ++ show initType') 506 | _ -> return () 507 | CInitList initList _ -> checkInitList ty (Just 0) initList 508 | 509 | checkInitList :: Maybe Type -> Maybe Int -> CInitList -> Analysis () 510 | checkInitList ty defaultIndex initList = 511 | case initList of 512 | [] -> return () 513 | (designators, initr) : rest -> 514 | do defaultIndex' <- checkInitListItem ty defaultIndex designators initr 515 | checkInitList ty defaultIndex' rest 516 | 517 | checkInitListItem :: Maybe Type -> Maybe Int -> [CDesignator] -> CInit -> Analysis (Maybe Int) 518 | checkInitListItem ty defaultIndex designators initr = 519 | case designators of 520 | [] -> do ty' <- getIndex initr ty defaultIndex 521 | checkInitializer ty' initr 522 | return (fmap (+1) defaultIndex) 523 | first : rest -> 524 | case first of 525 | CMemberDesig (Ident field _ _) pos -> 526 | do member <- getField pos ty field 527 | case member of 528 | Nothing -> return Nothing 529 | Just (fieldindex, fieldty) -> 530 | do case rest of 531 | [] -> checkInitializer (Just fieldty) initr 532 | _ -> do _ <- checkInitListItem (Just fieldty) (Just 0) rest initr 533 | return () 534 | return (Just (fieldindex + 1)) 535 | CArrDesig index pos -> 536 | do fieldty <- getIndex pos ty defaultIndex 537 | case rest of 538 | [] -> checkInitializer fieldty initr 539 | _ -> do _ <- checkInitListItem fieldty (Just 0) rest initr 540 | return () 541 | return (fmap (+1) defaultIndex) 542 | CRangeDesig _ _ pos -> err pos "TODO checkInitListItem CRangeDesig" >> return Nothing 543 | 544 | getField :: Pos a => a -> Maybe Type -> String -> Analysis (Maybe (Int, Type)) 545 | getField pos ty field = 546 | case ty of 547 | Nothing -> return Nothing 548 | Just (Struct tag) -> 549 | do st <- getSymTab 550 | case SymTab.lookupTag tag st of 551 | Nothing -> err pos ("Struct/union tag not in scope: " ++ tag) >> return Nothing 552 | Just fields -> 553 | case SymTab.lookupFieldByName field fields of 554 | Nothing -> err pos ("No such member in struct/union " ++ tag ++ ": " ++ field ++ ". Available fields: " ++ show fields) >> return Nothing 555 | Just field -> return (Just field) 556 | Just ty' -> err pos ("Not a struct/union " ++ show ty') >> return Nothing 557 | 558 | getIndex :: Pos a => a -> Maybe Type -> Maybe Int -> Analysis (Maybe Type) 559 | getIndex pos ty i = 560 | case ty of 561 | Nothing -> return Nothing 562 | Just ty' -> 563 | case ty' of 564 | Arr ty'' -> return (Just ty'') 565 | Struct tag -> 566 | case i of 567 | Nothing -> err pos "Not clear which member is being referred to" >> return Nothing 568 | Just i' -> 569 | do st <- getSymTab 570 | case SymTab.lookupTag tag st of 571 | Nothing -> err pos ("Struct/union tag not in scope: " ++ tag) >> return Nothing 572 | Just fields -> 573 | case SymTab.lookupFieldByIndex i' fields of 574 | Nothing -> return Nothing 575 | Just (_, fieldty) -> return (Just fieldty) 576 | Numeric _ -> return ty -- For vectors, since we don't track the __vector_size__ attribute in our type system 577 | _ -> err pos ("Not an array/struct/union/vector: " ++ show ty') >> return Nothing 578 | 579 | applyTriplet :: Pos a => a -> Maybe Type -> Bool -> Triplet -> Analysis (Maybe Type, Maybe CInit) 580 | applyTriplet pos declSpecTy isTypeDef (declr, initr, bitFieldSize) = 581 | do ty <- case declr of 582 | Just declr' -> deriveTypeFromCDeclr declSpecTy declr' 583 | Nothing -> return declSpecTy 584 | ty <- if isTypeDef then return ty else return (fmap Type.monomorphize ty) 585 | case declr of 586 | Just declr' -> 587 | case declr' of 588 | CDeclr (Just (Ident name _ _)) _ _ _ _ -> 589 | case ty of 590 | Just ty' -> 591 | (if isTypeDef then bindType else bindVariable) pos name ty' 592 | Nothing -> err declr' ("Could not infer type for " ++ name) 593 | _ -> err pos ("Unhandled CDeclr: " ++ show declr) 594 | Nothing -> return () 595 | return (ty, initr) 596 | 597 | 598 | bindType :: Pos a => a -> String -> Type -> Analysis () 599 | bindType pos name ty = 600 | do st <- getSymTab 601 | case SymTab.lookupType name st of 602 | Nothing -> return () 603 | Just oldTy -> 604 | if ty /= oldTy then 605 | err pos ("Type " ++ name ++ " redefined with different type. Old type is " ++ show oldTy ++ ", new type is " ++ show ty) 606 | else 607 | return () 608 | modifySymTab (SymTab.bindType name ty) 609 | 610 | bindVariable :: Pos a => a -> String -> Type -> Analysis () 611 | bindVariable pos name ty = 612 | do st <- getSymTab 613 | case SymTab.shallowLookupVariable name st of 614 | Nothing -> return () 615 | Just oldTy -> 616 | if ty /= oldTy then 617 | err pos (name ++ " redeclared with different type. Old type is " ++ show oldTy ++ ", new type is " ++ show ty) 618 | else 619 | return () 620 | modifySymTab (SymTab.bindVariable name ty) 621 | 622 | initTriplet :: Pos a => a -> (Maybe Type, Maybe CInit) -> Analysis () 623 | initTriplet pos (ty, initr) = 624 | case initr of 625 | Nothing -> return() 626 | Just initr' -> checkInitializer ty initr' 627 | 628 | deriveType :: [CDerivedDeclr] -> Maybe Type -> Analysis (Maybe Type) 629 | deriveType ds ty = 630 | case ds of 631 | [] -> return ty 632 | (d : dr) -> do ty' <- deriveType dr ty 633 | deriveType1 d ty' 634 | 635 | deriveType1 :: CDerivedDeclr -> Maybe Type -> Analysis (Maybe Type) 636 | deriveType1 d maybeTy = 637 | case maybeTy of 638 | Nothing -> return Nothing 639 | Just ty -> 640 | case d of 641 | CPtrDeclr _ _ -> return (Just (Ptr ty)) 642 | CArrDeclr _ _ _ -> return (Just (Arr ty)) 643 | CFunDeclr (Left _) _ _ -> 644 | do err d "TODO old-style function declaration" 645 | return Nothing 646 | CFunDeclr (Right (decls, varArgs)) attrs _ -> 647 | case decls of 648 | [CDecl [CTypeSpec (CVoidType _)] [] _] -> 649 | return (Just (Fun ty [] varArgs)) 650 | _ -> 651 | do maybeArgs <- mapM argType decls 652 | case sequence maybeArgs of -- maybe monad 653 | Nothing -> return Nothing 654 | Just args -> return (Just (Fun ty args varArgs)) 655 | 656 | argType :: CDecl -> Analysis (Maybe Type) 657 | argType cdecl = 658 | case cdecl of 659 | CDecl specs [] _ -> do ty <- findType specs 660 | case ty of 661 | Just ty' -> return (Just (Type.monomorphize ty')) 662 | Nothing -> return Nothing 663 | CDecl specs [(Just (CDeclr maybeIdent derivedDeclrs _ attrs _), Nothing, Nothing)] _ -> 664 | do specType <- findType specs 665 | attrType <- findType attrs 666 | ty <- deriveType derivedDeclrs (Type.mergeMaybe specType attrType) 667 | return (fmap Type.monomorphize ty) 668 | _ -> do err cdecl "TODO strange arg declaration" 669 | return Nothing 670 | 671 | applyCFunDef :: CFunDef -> Analysis () 672 | applyCFunDef f = 673 | case f of 674 | CFunDef specs (CDeclr ident derivedDeclrs _ attrs _) argDecls body _ -> 675 | do specType <- findType specs 676 | attrType <- findType attrs 677 | ty <- deriveType derivedDeclrs (Type.mergeMaybe specType attrType) 678 | ty <-return (fmap Type.monomorphize ty) 679 | 680 | case (ident, ty) of 681 | (Just (Ident name _ _), Just ty') -> bindVariable f name ty' 682 | (Nothing, _) -> err f "Strange fundef! Function has no name!" 683 | (_, Nothing) -> err f "Could not determine function type" 684 | 685 | -- save symtab before processing args and body 686 | modifySymTab SymTab.openScope 687 | modifySymTab (SymTab.bindVariable "__func__" (Type.Ptr Type.one)) 688 | case ty of 689 | Just (Fun rt argTypes _) -> 690 | case derivedDeclrs of 691 | CFunDeclr (Right (argDecls, varArgs)) attrs _ : _ -> 692 | do modifySymTab (SymTab.setReturnType (Just rt)) 693 | forM_ (zip argDecls argTypes) $ \ (argDecl, argTy) -> 694 | case argDecl of 695 | CDecl _ [(Just (CDeclr (Just (Ident argName _ _)) _ _ _ _), _, _)] _ -> 696 | modifySymTab (SymTab.bindVariable argName argTy) 697 | _ -> err f "Missing argument name" 698 | _ -> err f "Strange FunDef" 699 | _ -> return () 700 | 701 | _ <- findType body 702 | 703 | modifySymTab SymTab.closeScope 704 | -------------------------------------------------------------------------------- /app/FindUnit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module FindUnit where 4 | 5 | import Unit 6 | import Monad.Analysis 7 | import Control.Monad 8 | import Control.Monad.Extra 9 | import Language.C.Pretty 10 | import Language.C.Data.Ident 11 | import Language.C.Data.Position 12 | import Language.C.Syntax.Constants 13 | import Language.C.Syntax.AST 14 | 15 | class FindUnit a where 16 | findUnit :: a -> Analysis (Maybe Unit) 17 | 18 | instance FindUnit Unit where 19 | findUnit u = return (Just u) 20 | 21 | instance FindUnit CDeclr where 22 | findUnit declr = 23 | case declr of 24 | CDeclr _ _ _ attrs _ -> findUnit attrs 25 | 26 | instance FindUnit CAttr where 27 | findUnit attr = 28 | case attr of 29 | CAttr (Ident "unit" _ _) [e] _ -> parseCExprAsUnit e 30 | _ -> return Nothing 31 | 32 | parseCExprAsQ :: CExpr -> Analysis (Maybe Q) 33 | parseCExprAsQ expr = 34 | case expr of 35 | CConst (CIntConst (CInteger i _ _) _) -> return (Just (toRational i)) 36 | CUnary CNegOp e _ -> 37 | do u <- parseCExprAsQ e 38 | return (liftM negate u) 39 | CBinary CAddOp e1 e2 _ -> 40 | do u1 <- parseCExprAsQ e1 41 | u2 <- parseCExprAsQ e2 42 | return (liftM2 (+) u1 u2) 43 | CBinary CSubOp e1 e2 _ -> 44 | do u1 <- parseCExprAsQ e1 45 | u2 <- parseCExprAsQ e2 46 | return (liftM2 (-) u1 u2) 47 | CBinary CMulOp e1 e2 _ -> 48 | do u1 <- parseCExprAsQ e1 49 | u2 <- parseCExprAsQ e2 50 | return (liftM2 (*) u1 u2) 51 | CBinary CDivOp e1 e2 _ -> 52 | do u1 <- parseCExprAsQ e1 53 | u2 <- parseCExprAsQ e2 54 | return (liftM2 (/) u1 u2) 55 | _ -> do err expr ("Can't parse expression as power: " ++ show (pretty expr)) 56 | return Nothing 57 | 58 | parseCExprAsUnit :: CExpr -> Analysis (Maybe Unit) 59 | parseCExprAsUnit expr = 60 | case expr of 61 | CBinary CMulOp e1 e2 _ -> 62 | do u1 <- parseCExprAsUnit e1 63 | u2 <- parseCExprAsUnit e2 64 | return (liftM2 Unit.mul u1 u2) 65 | CBinary CDivOp e1 e2 _ -> 66 | do u1 <- parseCExprAsUnit e1 67 | u2 <- parseCExprAsUnit e2 68 | return (liftM2 Unit.div u1 u2) 69 | CVar (Ident name _ _) _ -> return (Just (Unit.fundamental name)) 70 | CConst (CIntConst (CInteger 1 _ _) _) -> return (Just Unit.one) 71 | CCall (CVar (Ident name _ _) _) [e] _ | elem name ["sqrt", "sqrtf", "sqrtl"] -> 72 | do u <- parseCExprAsUnit e 73 | return (fmap Unit.sqrt u) 74 | _ -> do err expr ("Can't parse expression as unit: " ++ show (pretty expr)) 75 | return Nothing 76 | 77 | instance FindUnit CDeclSpec where 78 | findUnit declSpec = 79 | case declSpec of 80 | CStorageSpec _ -> return Nothing 81 | CTypeSpec typeSpec -> findUnit typeSpec 82 | CTypeQual typeQual -> findUnit typeQual 83 | CFunSpec funSpec -> return Nothing 84 | CAlignSpec alignSpec -> return Nothing 85 | 86 | instance FindUnit CTypeSpec where 87 | findUnit typeSpec = 88 | case typeSpec of 89 | CVoidType _ -> return Nothing 90 | CCharType _ -> return Nothing 91 | CShortType _ -> return Nothing 92 | CIntType _ -> return Nothing 93 | CLongType _ -> return Nothing 94 | CFloatType _ -> return Nothing 95 | CDoubleType _ -> return Nothing 96 | CSignedType _ -> return Nothing 97 | CUnsigType _ -> return Nothing 98 | CBoolType _ -> return Nothing 99 | CComplexType _ -> return Nothing 100 | CSUType _ _ -> return Nothing 101 | CEnumType _ _ -> return Nothing 102 | CTypeDef _ident _ -> 103 | do err typeSpec "typedef type specifiers not yet handled" 104 | return Nothing 105 | CTypeOfExpr _e _ -> 106 | do err typeSpec "typeof(expr) type specifiers not yet handled" 107 | return Nothing 108 | CTypeOfType _t _ -> 109 | do err typeSpec "typeof(type) type specifiers not yet handled" 110 | return Nothing 111 | CInt128Type _ -> return Nothing 112 | CFloatNType _ _ _ -> return Nothing 113 | CAtomicType _ _ -> do err typeSpec "_atomic(type) type specifiers not yet handled" 114 | return Nothing 115 | 116 | instance FindUnit CTypeQual where 117 | findUnit typeQual = 118 | case typeQual of 119 | CConstQual _ -> return Nothing 120 | CVolatQual _ -> return Nothing 121 | CRestrQual _ -> return Nothing 122 | CAttrQual attr -> findUnit attr 123 | CAtomicQual _ -> return Nothing 124 | CNullableQual _ -> return Nothing 125 | CNonnullQual _ -> return Nothing 126 | CClRdOnlyQual _ -> return Nothing 127 | CClWrOnlyQual _ -> return Nothing 128 | 129 | instance FindUnit a => FindUnit (Maybe a) where 130 | findUnit m = 131 | case m of 132 | Just a -> findUnit a 133 | Nothing -> return Nothing 134 | 135 | instance FindUnit a => FindUnit [a] where 136 | findUnit list = 137 | do units <- mapMaybeM findUnit list 138 | case units of 139 | [] -> return Nothing 140 | [u] -> return (Just u) 141 | us -> do err nopos ("Conflicting units: " ++ show us) 142 | return Nothing 143 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | import FindType 2 | import Monad.Analysis 3 | import SymTab 4 | import Type 5 | import Control.Monad 6 | import Language.C as C 7 | import Language.C.System.GCC as GCC 8 | import Language.C.System.Preprocess as Preprocess 9 | import System.IO 10 | import System.Environment (getArgs, lookupEnv) 11 | import System.Exit 12 | import Data.List (isPrefixOf) 13 | import Data.Maybe (fromMaybe) 14 | 15 | argOk :: String -> Bool 16 | argOk arg = 17 | not ("-g" `isPrefixOf` arg) && 18 | not ("-f" `isPrefixOf` arg) 19 | 20 | main :: IO () 21 | main = do 22 | rawArgs <- getArgs 23 | gccExecutable <- fromMaybe "gcc" `fmap` lookupEnv "UNITC_GCC" 24 | let args = filter argOk rawArgs 25 | let cpp = newGCC gccExecutable 26 | case parseCPPArgs cpp args of 27 | Left error -> hPutStrLn stderr error >> exitFailure 28 | Right (cppArgs, _ignoredArgs) -> 29 | do ppResult <- runPreprocessor cpp cppArgs 30 | case ppResult of 31 | Left error -> hPutStrLn stderr ("preprocessor failed with exit code " ++ show error) >> exitFailure 32 | Right inputStream -> 33 | do let ns = newNameSupply 34 | let res = execParser translUnitP inputStream (initPos "") builtinTypeNames ns 35 | case res of 36 | Left error -> hPutStrLn stderr (show error) >> exitFailure 37 | Right (u, _ns') -> 38 | let errors = execAnalysis (addGccBuiltins >> analyzeCTranslUnit u) 39 | in do mapM_ printError errors 40 | case errors of 41 | [] -> exitSuccess 42 | _ -> exitFailure 43 | 44 | 45 | addGccBuiltins :: Analysis () 46 | addGccBuiltins = 47 | do modifySymTab (SymTab.bindType "__builtin_va_list" VaList) 48 | modifySymTab (SymTab.bindVariable "__builtin_bswap32" (Fun one [one] False)) 49 | modifySymTab (SymTab.bindVariable "__builtin_bswap64" (Fun one [one] False)) 50 | modifySymTab (SymTab.bindVariable "__builtin_constant_p" (Fun one [Any] False)) 51 | modifySymTab (SymTab.bindVariable "__builtin_strchr" (Fun (Ptr one) [Ptr one, one] False)) 52 | modifySymTab (SymTab.bindVariable "__builtin_expect" (Fun one [one, one] False)) 53 | modifySymTab (SymTab.bindVariable "__builtin_strlen" (Fun one [Ptr one] False)) 54 | modifySymTab (SymTab.bindVariable "__builtin_strcmp" (Fun one [Ptr one, Ptr one] False)) 55 | modifySymTab (SymTab.bindVariable "__builtin_va_start" (Fun Void [VaList, Any] False)) 56 | modifySymTab (SymTab.bindVariable "__builtin_va_end" (Fun Void [VaList] False)) 57 | modifySymTab (SymTab.bindVariable "__builtin_strcpy" (Fun (Ptr one) [Ptr one, Ptr one] False)) 58 | modifySymTab (SymTab.bindVariable "__builtin_strncpy" (Fun (Ptr one) [Ptr one, Ptr one, one] False)) 59 | modifySymTab (SymTab.bindVariable "__builtin_ctzl" (Fun one [one] False)) 60 | modifySymTab (SymTab.bindVariable "__builtin_prefetch" (Fun Void [Ptr Void] True)) 61 | 62 | printError :: Err -> IO () 63 | printError (Err pos msg) = 64 | hPutStrLn stderr (posFile pos ++ ": " ++ show (posRow pos) ++ ": error: " ++ msg) 65 | 66 | analyzeCTranslUnit :: CTranslUnit -> Analysis () 67 | analyzeCTranslUnit (CTranslUnit decls _) = 68 | forM_ decls analyzeCExtDecl 69 | 70 | analyzeCExtDecl :: CExtDecl -> Analysis () 71 | analyzeCExtDecl extDecl = 72 | case extDecl of 73 | CDeclExt d -> applyCDecl d 74 | CFDefExt f -> applyCFunDef f 75 | CAsmExt _ _ -> return () 76 | -------------------------------------------------------------------------------- /app/Monad/Analysis.hs: -------------------------------------------------------------------------------- 1 | module Monad.Analysis where 2 | 3 | import SymTab 4 | import Control.Monad.Trans.State.Strict 5 | import Control.Monad.Trans.Writer.Strict 6 | import Control.Monad.Trans.Class (lift) 7 | import Language.C.Data.Position 8 | 9 | data Err = Err Position String 10 | 11 | data AnalysisState = AnalysisState { 12 | symTab :: SymTab, 13 | genSymCounter :: Int 14 | } 15 | 16 | initialAnalysisState :: AnalysisState 17 | initialAnalysisState = 18 | AnalysisState { symTab = SymTab.empty, 19 | genSymCounter = 0 } 20 | 21 | type Analysis a = StateT AnalysisState (Writer [Err]) a 22 | 23 | getSymTab :: Analysis SymTab 24 | getSymTab = 25 | do state <- get 26 | return (symTab state) 27 | 28 | setSymTab :: SymTab -> Analysis () 29 | setSymTab st = 30 | do state <- get 31 | put (state { symTab = st }) 32 | 33 | modifySymTab :: (SymTab -> SymTab) -> Analysis () 34 | modifySymTab f = 35 | modify' (\state -> state { symTab = f (symTab state) }) 36 | 37 | gensym :: Analysis String 38 | gensym = 39 | do state <- get 40 | let counter = genSymCounter state 41 | put (state { genSymCounter = counter + 1 }) 42 | return ("") 43 | 44 | err :: Pos a => a -> String -> Analysis () 45 | err node msg = do lift (tell [Err (posOf node) msg]) 46 | 47 | instance Pos Position where 48 | posOf a = a 49 | 50 | execAnalysis :: Analysis () -> [Err] 51 | execAnalysis analysis = execWriter (evalStateT analysis initialAnalysisState) 52 | -------------------------------------------------------------------------------- /app/SymTab.hs: -------------------------------------------------------------------------------- 1 | module SymTab where 2 | 3 | import Type 4 | import qualified Data.Map as Map 5 | import Data.List as List 6 | import Control.Monad (mplus) 7 | 8 | type Fields = [(String, Type)] 9 | 10 | data SymTab = SymTab { 11 | variables :: Map.Map String Type, 12 | variablesRevList :: [(String, Type)], 13 | returnType :: Maybe Type, 14 | types :: Map.Map String Type, 15 | tags :: Map.Map String Fields, 16 | parent :: Maybe SymTab 17 | } deriving Show 18 | 19 | empty :: SymTab 20 | empty = 21 | SymTab { variables = Map.empty, 22 | variablesRevList = [], 23 | returnType = Nothing, 24 | types = Map.empty, 25 | tags = Map.empty, 26 | parent = Nothing 27 | } 28 | 29 | openScope :: SymTab -> SymTab 30 | openScope p = 31 | empty { parent = (Just p), returnType = returnType p } 32 | 33 | closeScope :: SymTab -> SymTab 34 | closeScope p = 35 | case parent p of 36 | Just p' -> p' 37 | Nothing -> error "Unbalanced openScope/closeScope" 38 | 39 | shallowLookupVariable :: String -> SymTab -> Maybe Type 40 | shallowLookupVariable name symtab = 41 | Map.lookup name (variables symtab) 42 | 43 | lookupVariable :: String -> SymTab -> Maybe Type 44 | lookupVariable name symtab = 45 | shallowLookupVariable name symtab `mplus` (parent symtab >>= lookupVariable name) 46 | 47 | bindVariable :: String -> Type -> SymTab -> SymTab 48 | bindVariable name ty st = 49 | st { variables = Map.insert name ty (variables st), 50 | variablesRevList = (name, ty) : variablesRevList st } 51 | 52 | bindVariables :: [(String, Type)] -> SymTab -> SymTab 53 | bindVariables pairs st = 54 | List.foldl' (\acc (name,ty) -> bindVariable name ty acc) st pairs 55 | 56 | bindGlobalVariable :: String -> Type -> SymTab -> SymTab 57 | bindGlobalVariable name ty st = 58 | case parent st of 59 | Nothing -> bindVariable name ty st 60 | Just st' -> st { parent = Just (bindGlobalVariable name ty st') } 61 | 62 | setReturnType :: Maybe Type -> SymTab -> SymTab 63 | setReturnType rt st = 64 | st { returnType = rt } 65 | 66 | lookupType :: String -> SymTab -> Maybe Type 67 | lookupType name symtab = 68 | Map.lookup name (types symtab) `mplus` 69 | do p <- parent symtab 70 | lookupType name p 71 | 72 | bindType :: String -> Type -> SymTab -> SymTab 73 | bindType name ty st = 74 | st { types = Map.insert name ty (types st) } 75 | 76 | lookupTag :: String -> SymTab -> Maybe Fields 77 | lookupTag name symtab = 78 | Map.lookup name (tags symtab) `mplus` 79 | do p <- parent symtab 80 | lookupTag name p 81 | 82 | bindTag :: String -> Fields -> SymTab -> SymTab 83 | bindTag name fields st = 84 | case parent st of 85 | Nothing -> st { tags = Map.insert name fields (tags st) } 86 | Just st' -> st { parent = Just (bindTag name fields st') } 87 | 88 | lookupFieldByName :: String -> Fields -> Maybe (Int, Type) 89 | lookupFieldByName name fields = 90 | case elemIndex name (map fst fields) of 91 | Nothing -> Nothing 92 | Just i -> Just (i, snd (fields !! i)) 93 | 94 | lookupFieldByIndex :: Int -> Fields -> Maybe (String, Type) 95 | lookupFieldByIndex i fields = 96 | case drop i fields of 97 | [] -> Nothing 98 | (name,ty) : _ -> Just (name, ty) 99 | -------------------------------------------------------------------------------- /app/Type.hs: -------------------------------------------------------------------------------- 1 | module Type where 2 | 3 | import Prelude hiding (and, or, div, abs, min, max) 4 | 5 | import qualified Unit 6 | import Control.Monad 7 | import Data.Maybe (isJust) 8 | 9 | data Type = Numeric (Maybe Unit.Unit) -- Must be (Just _) once fully formed 10 | | Fun Type [Type] Bool -- returnType names acceptsVarArgs 11 | | Struct String 12 | | Void 13 | | Any -- Wildcard, useful to bypass type checking for some builtins 14 | | Zero 15 | | Ptr Type 16 | | Arr Type 17 | | VaList 18 | deriving (Show, Eq) 19 | 20 | type Unit = Unit.Unit 21 | 22 | one :: Type 23 | one = Numeric (Just Unit.one) 24 | 25 | add :: Type -> Type -> Maybe Type 26 | add x Zero = add x one 27 | add Zero x = add one x 28 | add (Numeric (Just t1)) (Numeric (Just t2)) | t1 == t2 = Just (Numeric (Just t1)) 29 | --add (Ptr Void) (Numeric _) = Nothing -- disallowed by the standard, but allowed by gcc 30 | --add (Numeric _) (Ptr Void) = Nothing -- disallowed by the standard, but allowed by gcc 31 | add (Arr t) (Numeric u) = if u == Just Unit.one then Just (Ptr t) else Nothing 32 | add (Ptr t) (Numeric u) = if u == Just Unit.one then Just (Ptr t) else Nothing 33 | add (Numeric u) (Arr t) = if u == Just Unit.one then Just (Ptr t) else Nothing 34 | add (Numeric u) (Ptr t) = if u == Just Unit.one then Just (Ptr t) else Nothing 35 | add _ _ = Nothing 36 | 37 | applyMathFn :: (Unit -> Unit) -> Type -> Maybe Type 38 | applyMathFn fn t = 39 | do unit <- case t of 40 | Zero -> Just Unit.one 41 | Numeric (Just unit) -> Just unit 42 | _ -> Nothing 43 | return (Numeric (Just (fn unit))) 44 | 45 | pow :: Type -> Unit.Q -> Maybe Type 46 | pow ty power = applyMathFn (`Unit.pow` power) ty 47 | 48 | sqrt :: Type -> Maybe Type 49 | sqrt ty = applyMathFn Unit.sqrt ty 50 | 51 | sub :: Type -> Type -> Maybe Type 52 | sub x Zero = sub x one 53 | sub Zero x = sub one x 54 | sub (Numeric (Just t1)) (Numeric (Just t2)) | t1 == t2 = Just (Numeric (Just t1)) 55 | --sub (Ptr Void) (Numeric _) = Nothing -- disallowed by the standard, but allwed by gcc 56 | sub (Arr t) (Numeric u) = if u == Just Unit.one then Just (Ptr t) else Nothing 57 | sub (Ptr t) (Numeric u) = if u == Just Unit.one then Just (Ptr t) else Nothing 58 | sub (Ptr t1) (Ptr t2) = if t1 == t2 then Just one else Nothing 59 | sub _ _ = Nothing 60 | 61 | mul :: Type -> Type -> Maybe Type 62 | mul x Zero = mul x one 63 | mul Zero x = mul one x 64 | mul (Numeric (Just t1)) (Numeric (Just t2)) = Just (Numeric (Just (Unit.mul t1 t2))) 65 | mul _ _ = Nothing 66 | 67 | div :: Type -> Type -> Maybe Type 68 | div x Zero = div x one 69 | div Zero x = div one x 70 | div (Numeric (Just t1)) (Numeric (Just t2)) = Just (Numeric (Just (Unit.div t1 t2))) 71 | div _ _ = Nothing 72 | 73 | rem :: Type -> Type -> Maybe Type 74 | rem = sub 75 | 76 | shl :: Type -> Type -> Maybe Type 77 | shl t1 t2 = 78 | if numeric t1 then 79 | case t2 of 80 | Numeric (Just u) -> 81 | if u == Unit.one then 82 | Just t1 83 | else 84 | Nothing 85 | _ -> Nothing 86 | else 87 | Nothing 88 | 89 | shr :: Type -> Type -> Maybe Type 90 | shr = shl 91 | 92 | and :: Type -> Type -> Maybe Type 93 | and = add 94 | 95 | or :: Type -> Type -> Maybe Type 96 | or = and 97 | 98 | xor :: Type -> Type -> Maybe Type 99 | xor = or 100 | 101 | land :: Type -> Type -> Maybe Type 102 | land t1 t2 = 103 | if booleanable t1 && booleanable t2 then 104 | Just one 105 | else 106 | Nothing 107 | 108 | lor :: Type -> Type -> Maybe Type 109 | lor = land 110 | 111 | cmp :: Type -> Type -> Maybe Type 112 | cmp t1 t2 = 113 | case merge t1 t2 of 114 | Nothing -> Nothing 115 | Just t -> Just one 116 | 117 | comp :: Type -> Maybe Type 118 | comp t = 119 | case t of 120 | Zero -> Just one 121 | Numeric (Just u) | u == Unit.one -> Just one 122 | _ -> Nothing 123 | 124 | neg :: Type -> Maybe Type 125 | neg t = 126 | case t of 127 | Zero -> Just one 128 | Numeric _ -> Just one 129 | Ptr _ -> Just one 130 | Arr _ -> Just one 131 | _ -> Nothing 132 | 133 | abs :: Type -> Maybe Type 134 | abs = applyMathFn id 135 | 136 | min :: Type -> Type -> Maybe Type 137 | min t1 t2 = 138 | case (t1, t2) of 139 | (Zero, Zero) -> Just one 140 | (Zero, Numeric u) -> Just t2 141 | (Numeric u, Zero) -> Just t1 142 | (Numeric u1, Numeric u2) | u1 == u2 -> Just t1 143 | _ -> Nothing 144 | 145 | max :: Type -> Type -> Maybe Type 146 | max = min 147 | 148 | assignable :: Type -> Type -> Bool 149 | assignable to from = 150 | case (to, from) of 151 | (Zero, Zero) -> True 152 | (Zero, _) -> False 153 | (Ptr (Fun _ _ _), Fun _ _ _) -> assignable to (Ptr from) 154 | (Ptr Void, Arr from') -> True 155 | (Ptr to', Arr from') -> isJust (merge to' from') 156 | _ -> isJust (merge to from) 157 | 158 | booleanable :: Type -> Bool 159 | booleanable t = 160 | case t of 161 | Numeric _ -> True 162 | Fun _ _ _ -> True 163 | Struct _ -> False 164 | Void -> False 165 | Any -> True 166 | Zero -> True 167 | Ptr _ -> True 168 | Arr _ -> True 169 | VaList -> False 170 | 171 | deref :: Type -> Maybe Type 172 | deref t = 173 | case t of 174 | Ptr t' -> Just t' 175 | Arr t' -> Just t' 176 | Fun _ _ _ -> return t 177 | _ -> Nothing 178 | 179 | numeric :: Type -> Bool 180 | numeric t = 181 | case t of 182 | Zero -> True 183 | Numeric _ -> True 184 | _ -> False 185 | 186 | merge :: Type -> Type -> Maybe Type 187 | merge t1 t2 = 188 | case (t1, t2) of 189 | (Any, _) -> Just t2 190 | (_, Any) -> Just t1 191 | (Void, Void) -> Just Void 192 | (Zero, Zero) -> Just Zero 193 | (Ptr t, Zero) -> Just t1 194 | (Zero, Ptr t) -> Just t2 195 | (Ptr Void, Ptr _) -> Just t2 196 | (Ptr _, Ptr Void) -> Just t1 197 | (Numeric Nothing, Zero) -> Just t1 198 | (Zero, Numeric Nothing) -> Just t2 199 | (Numeric (Just unit), Zero) -> Just t1 200 | (Zero, Numeric (Just unit)) -> Just t2 201 | (Numeric m1, Numeric m2) -> 202 | case (m1, m2) of 203 | (Just u1, Just u2) -> if u1 == u2 then Just (Numeric (Just u1)) else Nothing 204 | (Just u1, Nothing) -> Just (Numeric (Just u1)) 205 | (Nothing, Just u2) -> Just (Numeric (Just u2)) 206 | (Nothing, Nothing) -> Just (Numeric Nothing) 207 | (Fun r1 a1 d1, Fun r2 a2 d2) -> 208 | -- maybe monad 209 | do r <- merge r1 r2 210 | a <- mapM (uncurry merge) (zip a1 a2) 211 | guard (d1 == d2) 212 | return (Fun r a d1) 213 | (Struct n1, Struct n2) -> if n1 == n2 then Just t1 else Nothing 214 | (VaList, VaList) -> Just VaList 215 | (Ptr t1', Ptr t2') -> do t' <- merge t1' t2'; return (Ptr t') 216 | (Arr t1', Arr t2') -> do t' <- merge t1' t2'; return (Arr t') 217 | _ -> Nothing 218 | 219 | mergeMaybe :: Maybe Type -> Maybe Type -> Maybe Type 220 | mergeMaybe m1 m2 = 221 | case (m1, m2) of 222 | (Just t1, Just t2) -> merge t1 t2 223 | (Just t1, Nothing) -> Just t1 224 | (Nothing, Just t2) -> Just t2 225 | (Nothing, Nothing) -> Nothing 226 | 227 | monomorphize :: Type -> Type 228 | monomorphize t = 229 | case t of 230 | Numeric Nothing -> Numeric (Just Unit.one) -- polymorphic unit becomes unit 1 231 | Numeric (Just u) -> t 232 | Void -> Void 233 | Zero -> one 234 | Struct _ -> t 235 | VaList -> VaList 236 | Any -> error "monomorphize any!" 237 | Ptr t' -> Ptr (monomorphize t') 238 | Arr t' -> Arr (monomorphize t') 239 | Fun r a v -> Fun (monomorphize r) (map monomorphize a) v 240 | -------------------------------------------------------------------------------- /app/Unit.hs: -------------------------------------------------------------------------------- 1 | module Unit where 2 | 3 | import Prelude hiding (div, recip) 4 | import Data.Ratio 5 | import Data.List as List 6 | import Data.Map.Strict as Map 7 | 8 | type Q = Ratio Integer 9 | 10 | newtype Unit = Unit (Map String Q) 11 | deriving (Eq) 12 | 13 | nonzero :: Q -> Maybe Q 14 | nonzero 0 = Nothing 15 | nonzero x = Just x 16 | 17 | one :: Unit 18 | one = Unit Map.empty 19 | 20 | fundamental :: String -> Unit 21 | fundamental name = Unit (Map.singleton name 1) 22 | 23 | mul :: Unit -> Unit -> Unit 24 | mul (Unit u1) (Unit u2) = Unit (Map.mergeWithKey (\_k p1 p2 -> nonzero (p1 + p2)) id id u1 u2) 25 | 26 | recip :: Unit -> Unit 27 | recip (Unit u) = Unit (Map.map negate u) 28 | 29 | div :: Unit -> Unit -> Unit 30 | div (Unit u1) (Unit u2) = Unit (Map.mergeWithKey (\_k p1 p2 -> nonzero (p1 - p2)) id (Map.map negate) u1 u2) 31 | 32 | pow :: Unit -> Q -> Unit 33 | pow (Unit u) q = Unit (Map.map (q *) u) 34 | 35 | sqrt :: Unit -> Unit 36 | sqrt u = pow u (1%2) 37 | 38 | instance Show Unit where 39 | show (Unit u) = 40 | let 41 | (positive, negative) = List.partition (\(k,p) -> p >= 0) (Map.toList u) 42 | in 43 | (if List.null positive then 44 | "1" 45 | else 46 | intercalate " * " (List.map (\ (k, p) -> showPower k p) positive) 47 | ) ++ 48 | List.concatMap (\ (k, p) -> " / " ++ showPower k (-p)) negative 49 | 50 | 51 | showPower :: String -> Q -> String 52 | showPower name power = 53 | case (numerator power, denominator power) of 54 | (1, 1) -> name 55 | (n, 1) -> name ++ "**" ++ show n 56 | (n, d) -> name ++ "**(" ++ show n ++ "/" ++ show d ++ ")" 57 | -------------------------------------------------------------------------------- /doc/examples/bad1.c: -------------------------------------------------------------------------------- 1 | #define unit(u) __attribute__((unit(u))) 2 | 3 | int main(int argc, char **argv) { 4 | double v unit(m/s); 5 | double t unit(s); 6 | double a unit(m/s) = v / t; 7 | return 0; 8 | } 9 | -------------------------------------------------------------------------------- /doc/examples/bad2a.c: -------------------------------------------------------------------------------- 1 | #define unit(u) __attribute__((unit(u))) 2 | 3 | double unit(m/s/s) acceleration (double velocity_change unit(m/s), double time unit(s)) { 4 | return velocity_change / time; 5 | } 6 | 7 | int main(int argc, char **argv) { 8 | double v unit(m/s); 9 | double t unit(s); 10 | double a unit(m/s) = acceleration(v, t); 11 | return 0; 12 | } 13 | -------------------------------------------------------------------------------- /doc/examples/bad2b.c: -------------------------------------------------------------------------------- 1 | #define unit(u) __attribute__((unit(u))) 2 | 3 | double unit(m/s) acceleration (double velocity_change unit(m/s), double time unit(s)) { 4 | return velocity_change / time; 5 | } 6 | 7 | int main(int argc, char **argv) { 8 | double v unit(m/s); 9 | double t unit(s); 10 | double a unit(m/s) = acceleration(v, t); 11 | return 0; 12 | } 13 | -------------------------------------------------------------------------------- /doc/examples/bad2c.c: -------------------------------------------------------------------------------- 1 | #define unit(u) __attribute__((unit(u))) 2 | 3 | double unit(m/s/s) acceleration (double velocity_change unit(m/s), double time unit(s)) { 4 | return velocity_change / time; 5 | } 6 | 7 | int main(int argc, char **argv) { 8 | double v unit(m); 9 | double t unit(s); 10 | double a unit(m/s/s) = acceleration(v, t); 11 | return 0; 12 | } 13 | -------------------------------------------------------------------------------- /doc/examples/bad3a.c: -------------------------------------------------------------------------------- 1 | #define unit(u) __attribute__((unit(u))) 2 | 3 | extern double atof(const char *str); 4 | extern int printf(const char *format, ...); 5 | 6 | int main(int argc, char **argv) { 7 | if (argc != 3) { 8 | printf("Usage: example3