75 renderCFiles :: Map.Map String PascalUnit -> IO () |
75 renderCFiles :: Map.Map String PascalUnit -> IO () |
76 renderCFiles units = do |
76 renderCFiles units = do |
77 let u = Map.toList units |
77 let u = Map.toList units |
78 let nss = Map.map (toNamespace nss) units |
78 let nss = Map.map (toNamespace nss) units |
79 hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . null) $ nss) |
79 hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . null) $ nss) |
80 writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
80 --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
81 mapM_ (toCFiles nss) u |
81 mapM_ (toCFiles nss) u |
82 where |
82 where |
83 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
83 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
84 toNamespace nss (System tvs) = |
84 toNamespace nss (System tvs) = |
85 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
85 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
86 toNamespace _ (Program {}) = [] |
86 toNamespace _ (Program {}) = [] |
87 toNamespace nss (Unit _ interface _ _ _) = |
87 toNamespace nss (Unit _ interface _ _ _) = |
88 currentScope $ execState (interface2C interface) (emptyState nss) |
88 currentScope $ execState (interface2C interface) (emptyState nss) |
89 |
89 |
90 |
90 |
91 withState' :: (a -> a) -> State a b -> State a b |
91 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
92 withState' f s = do |
92 withState' f sf = do |
93 st <- liftM f get |
93 st <- liftM f get |
94 return $ evalState s st |
94 let (a, s) = runState sf st |
|
95 modify(\st -> st{lastType = lastType s}) |
|
96 return a |
95 |
97 |
96 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
98 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
97 withLastIdNamespace f = do |
99 withLastIdNamespace f = do |
98 li <- gets lastIdentifier |
100 li <- gets lastIdentifier |
99 nss <- gets namespaces |
101 nss <- gets namespaces |
100 withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
102 withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
101 |
103 |
102 withRecordNamespace :: [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
104 withRecordNamespace :: [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
|
105 withRecordNamespace [] = error "withRecordNamespace: empty record" |
103 withRecordNamespace recs = withState' f |
106 withRecordNamespace recs = withState' f |
104 where |
107 where |
105 f st = st{currentScope = records ++ currentScope st} |
108 f st = st{currentScope = records ++ currentScope st} |
106 records = map (\(a, b) -> (map toLower a, (a, b))) recs |
109 records = map (\(a, b) -> (map toLower a, (a, b))) recs |
107 |
110 |
181 n = map toLower i |
184 n = map toLower i |
182 id2C IOLookup (Identifier i t) = do |
185 id2C IOLookup (Identifier i t) = do |
183 let i' = map toLower i |
186 let i' = map toLower i |
184 v <- gets $ find (\(a, _) -> a == i') . currentScope |
187 v <- gets $ find (\(a, _) -> a == i') . currentScope |
185 ns <- gets currentScope |
188 ns <- gets currentScope |
|
189 lt <- gets lastType |
186 if isNothing v then |
190 if isNothing v then |
187 error $ "Not defined: '" ++ i' ++ "'\n" ++ show (take 100 ns) |
191 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\n" ++ show (take 100 ns) |
188 else |
192 else |
189 let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
193 let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
190 id2C IODeferred (Identifier i t) = do |
194 id2C IODeferred (Identifier i t) = do |
191 let i' = map toLower i |
195 let i' = map toLower i |
192 v <- gets $ find (\(a, _) -> a == i') . currentScope |
196 v <- gets $ find (\(a, _) -> a == i') . currentScope |
453 t <- gets lastType |
457 t <- gets lastType |
454 ns <- gets currentScope |
458 ns <- gets currentScope |
455 case t of |
459 case t of |
456 (BTArray _ ta@(BTArray _ t')) |
460 (BTArray _ ta@(BTArray _ t')) |
457 | length exprs == 2 -> modify (\st -> st{lastType = t'}) |
461 | length exprs == 2 -> modify (\st -> st{lastType = t'}) |
458 | otherwise -> modify (\st -> st{lastType = ta}) |
462 | length exprs == 1 -> modify (\st -> st{lastType = ta}) |
|
463 | otherwise -> error $ "Array has more than two dimensions" |
459 (BTArray _ t') -> modify (\st -> st{lastType = t'}) |
464 (BTArray _ t') -> modify (\st -> st{lastType = t'}) |
460 (BTString) -> modify (\st -> st{lastType = BTChar}) |
465 (BTString) -> modify (\st -> st{lastType = BTChar}) |
461 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
466 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
462 return $ r <> (brackets . hcat) (punctuate comma es) |
467 return $ r <> (brackets . hcat) (punctuate comma es) |
463 ref2C (SimpleReference name) = id2C IOLookup name |
468 ref2C (SimpleReference name) = id2C IOLookup name |