tools/pas2c.hs
changeset 6878 0af34406b83d
parent 6875 6528171ce36d
child 6880 34d3bc7bd8b1
equal deleted inserted replaced
6877:b899393c8450 6878:0af34406b83d
   117     toCFiles' p
   117     toCFiles' p
   118     where
   118     where
   119     toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p
   119     toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p
   120     toCFiles' (fn, (Unit unitId interface implementation _ _)) = do
   120     toCFiles' (fn, (Unit unitId interface implementation _ _)) = do
   121         let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState
   121         let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState
   122         writeFile (fn ++ ".h") $ "#pragma once\n\n" ++ (render a)
   122         writeFile (fn ++ ".h") $ "#pragma once\n\n" ++ (render (a $+$ text ""))
   123         writeFile (fn ++ ".c") $ "#include \"pas2c.h\"\n#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation
   123         writeFile (fn ++ ".c") $ "#include \"pas2c.h\"\n#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation
   124     initialState = emptyState ns
   124     initialState = emptyState ns
   125 
   125 
   126     render2C :: RenderState -> State RenderState Doc -> String
   126     render2C :: RenderState -> State RenderState Doc -> String
   127     render2C a = render . flip evalState a
   127     render2C a = render . ($+$ text "") . flip evalState a
   128 
   128 
   129 usesFiles :: PascalUnit -> [String]
   129 usesFiles :: PascalUnit -> [String]
   130 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses
   130 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses
   131 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2
   131 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2
   132 usesFiles (System {}) = []
   132 usesFiles (System {}) = []
   136 pascal2C (Unit _ interface implementation init fin) =
   136 pascal2C (Unit _ interface implementation init fin) =
   137     liftM2 ($+$) (interface2C interface) (implementation2C implementation)
   137     liftM2 ($+$) (interface2C interface) (implementation2C implementation)
   138     
   138     
   139 pascal2C (Program _ implementation mainFunction) = do
   139 pascal2C (Program _ implementation mainFunction) = do
   140     impl <- implementation2C implementation
   140     impl <- implementation2C implementation
   141     main <- tvar2C True 
   141     [main] <- tvar2C True 
   142         (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction)))
   142         (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction)))
   143     return $ impl $+$ main
   143     return $ impl $+$ main
   144 
   144 
   145     
   145     
   146     
   146     
   150 implementation2C :: Implementation -> State RenderState Doc
   150 implementation2C :: Implementation -> State RenderState Doc
   151 implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars)
   151 implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars)
   152 
   152 
   153 
   153 
   154 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc
   154 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc
   155 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts
   155 typesAndVars2C b (TypesAndVars ts) = liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts
   156 
   156 
   157 setBaseType :: BaseType -> Identifier -> Identifier
   157 setBaseType :: BaseType -> Identifier -> Identifier
   158 setBaseType bt (Identifier i _) = Identifier i bt
   158 setBaseType bt (Identifier i _) = Identifier i bt
   159 
   159 
   160 uses2C :: Uses -> State RenderState Doc
   160 uses2C :: Uses -> State RenderState Doc
   265         f t = return t
   265         f t = return t
   266 fromPointer s t = do
   266 fromPointer s t = do
   267     ns <- gets currentScope
   267     ns <- gets currentScope
   268     error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s ++ "\n\n" ++ show (take 100 ns)
   268     error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s ++ "\n\n" ++ show (take 100 ns)
   269 
   269 
   270 
   270     
   271 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc
   271 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params
       
   272 
       
   273 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc]
   272 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do
   274 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do
   273     t <- type2C returnType 
   275     t <- type2C returnType 
   274     t'<- gets lastType
   276     t'<- gets lastType
   275     p <- withState' id $ liftM hcat $ mapM (tvar2C False) params
   277     p <- withState' id $ functionParams2C params
   276     n <- id2C IOInsert $ setBaseType (BTFunction t') name
   278     n <- id2C IOInsert $ setBaseType (BTFunction t') name
   277     return $ t <+> n <> parens p <> text ";"
   279     return [t empty <+> n <> parens p]
   278     
   280     
   279 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
   281 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
   280     t <- type2C returnType
   282     t <- type2C returnType
   281     t'<- gets lastType
   283     t'<- gets lastType
   282     n <- id2C IOInsert $ setBaseType (BTFunction t') name
   284     n <- id2C IOInsert $ setBaseType (BTFunction t') name
   283     (p, ph) <- withState' (\st -> st{currentScope = (lastIdentifier st, (lastIdentifier st ++ "_result", t')) : currentScope st}) $ do
   285     (p, ph) <- withState' (\st -> st{currentScope = (lastIdentifier st, (lastIdentifier st ++ "_result", t')) : currentScope st}) $ do
   284         p <- liftM hcat $ mapM (tvar2C False) params
   286         p <- functionParams2C params
   285         ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
   287         ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
   286         return (p, ph)
   288         return (p, ph)
   287     let res = docToLower $ n <> text "_result"
   289     let res = docToLower $ n <> text "_result"
   288     let phrasesBlock = case returnType of
   290     let phrasesBlock = case returnType of
   289             VoidType -> ph
   291             VoidType -> ph
   290             _ -> t <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
   292             _ -> t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
   291     return $ 
   293     return [ 
   292         t <+> n <> parens p
   294         t empty <+> n <> parens p
   293         $+$
   295         $+$
   294         text "{" 
   296         text "{" 
   295         $+$ 
   297         $+$ 
   296         nest 4 phrasesBlock
   298         nest 4 phrasesBlock
   297         $+$
   299         $+$
   298         text "}"
   300         text "}"]
   299     where
   301     where
   300     phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
   302     phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
   301     phrase2C' p = phrase2C p
   303     phrase2C' p = phrase2C p
   302     
   304     
   303 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
   305 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
   304 
   306 
   305 tvar2C _ td@(TypeDeclaration i' t) = do
   307 tvar2C _ td@(TypeDeclaration i' t) = do
   306     i <- id2CTyped t i'
   308     i <- id2CTyped t i'
   307     tp <- type2C t
   309     tp <- type2C t
   308     return $ text "typedef" <+> tp <+> i <> semi
   310     return [text "typedef" <+> tp i]
   309     
   311     
   310 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do
   312 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do
   311     t' <- type2C t
   313     t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t
   312     i <- mapM (id2CTyped t) ids
       
   313     ie <- initExpr mInitExpr
   314     ie <- initExpr mInitExpr
   314     return $ (if isConst then text "const" else empty)
   315     liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids
   315         <+> t'
       
   316         <+> (hsep . punctuate (char ',') $ i)
       
   317         <+> ie
       
   318         <> text ";"
       
   319     where
   316     where
   320     initExpr Nothing = return $ empty
   317     initExpr Nothing = return $ empty
   321     initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
   318     initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
   322     
   319     
   323 tvar2C f (OperatorDeclaration op i ret params body) = 
   320 tvar2C f (OperatorDeclaration op i ret params body) = 
   343     (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
   340     (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
   344     return $ lbrace $+$ (nest 4 . vcat $ fs) $+$ rbrace
   341     return $ lbrace $+$ (nest 4 . vcat $ fs) $+$ rbrace
   345 initExpr2C (InitArray [value]) = initExpr2C value
   342 initExpr2C (InitArray [value]) = initExpr2C value
   346 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
   343 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
   347 initExpr2C (InitRange (Range i)) = id2C IOLookup i
   344 initExpr2C (InitRange (Range i)) = id2C IOLookup i
       
   345 initExpr2C (InitRange (RangeFromTo (InitNumber "0") (InitNumber a))) = return . text $ show (read a + 1)
   348 initExpr2C (InitRange a) = return $ text "<<range>>"
   346 initExpr2C (InitRange a) = return $ text "<<range>>"
   349 initExpr2C (InitSet []) = return $ text "0"
   347 initExpr2C (InitSet []) = return $ text "0"
   350 initExpr2C (InitSet a) = return $ text "<<set>>"
   348 initExpr2C (InitSet a) = return $ text "<<set>>"
   351 initExpr2C (BuiltInFunction {}) = return $ text "<<built-in function>>"
   349 initExpr2C (BuiltInFunction {}) = return $ text "<<built-in function>>"
   352 initExpr2C a = error $ "initExpr2C: don't know how to render " ++ show a
   350 initExpr2C a = error $ "initExpr2C: don't know how to render " ++ show a
   356 range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
   354 range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
   357 range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
   355 range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
   358     
   356     
   359 range2C a = liftM (flip (:) []) $ initExpr2C a
   357 range2C a = liftM (flip (:) []) $ initExpr2C a
   360 
   358 
   361 type2C :: TypeDecl -> State RenderState Doc
   359 type2C :: TypeDecl -> State RenderState (Doc -> Doc)
   362 type2C (SimpleType i) = id2C IOLookup i
   360 type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
   363 type2C t = do
   361 type2C t = do
   364     r <- type2C' t
   362     r <- type2C' t
   365     rt <- resolveType t
   363     rt <- resolveType t
   366     modify (\st -> st{lastType = rt})
   364     modify (\st -> st{lastType = rt})
   367     return r
   365     return r
   368     where
   366     where
   369     type2C' VoidType = return $ text "void"
   367     type2C' VoidType = return (text "void" <+>)
   370     type2C' (String l) = return $ text $ "string" ++ show l
   368     type2C' (String l) = return (text ("string" ++ show l) <+>)
   371     type2C' (PointerTo (SimpleType i)) = liftM (\i -> text "struct" <+> i <+> text "*") $ id2C IODeferred i
   369     type2C' (PointerTo (SimpleType i)) = liftM (\i a -> text "struct" <+> i <+> text "*" <+> a) $ id2C IODeferred i
   372     type2C' (PointerTo t) = liftM (<> text "*") $ type2C t
   370     type2C' (PointerTo t) = liftM (\t a -> t (text "*" <> a)) $ type2C t
   373     type2C' (RecordType tvs union) = do
   371     type2C' (RecordType tvs union) = do
   374         t <- withState' id $ mapM (tvar2C False) tvs
   372         t <- withState' id $ mapM (tvar2C False) tvs
   375         return $ text "struct" <+> lbrace $+$ (nest 4 . vcat $ t) $+$ rbrace
   373         return $ \i -> text "struct" <+> lbrace $+$ (nest 4 . vcat . map (<> semi) . concat $ t) $+$ rbrace <+> i
   376     type2C' (RangeType r) = return $ text "<<range type>>"
   374     type2C' (RangeType r) = return (text "<<range type>>" <+>)
   377     type2C' (Sequence ids) = do
   375     type2C' (Sequence ids) = do
   378         mapM_ (id2C IOInsert) ids
   376         is <- mapM (id2C IOInsert . setBaseType bt) ids
   379         return $ text "<<sequence type>>"
   377         return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is (iterate (*2) 1)) <+>)
   380     type2C' (ArrayDecl r t) = do
   378         where
       
   379             bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
       
   380     type2C' (ArrayDecl Nothing t) = do
   381         t' <- type2C t
   381         t' <- type2C t
   382         return $ t' <> brackets (text "<<range>>")
   382         return $ \i -> t' i <> brackets empty
   383     type2C' (Set t) = return $ text "<<set>>"
   383     type2C' (ArrayDecl (Just r) t) = do
   384     type2C' (FunctionType returnType params) = return $ text "<<function>>"
   384         t' <- type2C t
   385     type2C' (DeriveType (InitBinOp {})) = return $ text "int"
   385         r' <- initExpr2C (InitRange r)
       
   386         return $ \i -> t' i <> brackets r'
       
   387     type2C' (Set t) = return (text "<<set>>" <+>)
       
   388     type2C' (FunctionType returnType params) = do
       
   389         t <- type2C returnType
       
   390         p <- withState' id $ functionParams2C params
       
   391         return (\i -> t empty <+> i <> parens p)
       
   392     type2C' (DeriveType (InitBinOp {})) = return (text "int" <+>)
   386     type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
   393     type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
   387     type2C' (DeriveType (InitNumber _)) = return $ text "int"
   394     type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
   388     type2C' (DeriveType (InitHexNumber _)) = return $ text "int"
   395     type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
   389     type2C' (DeriveType (InitFloat _)) = return $ text "float"
   396     type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
   390     type2C' (DeriveType (BuiltInFunction {})) = return $ text "int"
   397     type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
   391     type2C' (DeriveType (InitString {})) = return $ text "string255"
   398     type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
   392     type2C' (DeriveType (InitReference {})) = return $ text "<<some type>>"
   399     type2C' (DeriveType (InitReference {})) = return (text "<<some type>>" <+>)
   393     type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
   400     type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
   394 
   401 
   395 phrase2C :: Phrase -> State RenderState Doc
   402 phrase2C :: Phrase -> State RenderState Doc
   396 phrase2C (Phrases p) = do
   403 phrase2C (Phrases p) = do
   397     ps <- mapM phrase2C p
   404     ps <- mapM phrase2C p