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 {}) = [] |
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 |