74 |
74 |
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) |
|
80 writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
79 mapM_ (toCFiles nss) u |
81 mapM_ (toCFiles nss) u |
80 where |
82 where |
81 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
83 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
82 toNamespace nss (System tvs) = |
84 toNamespace nss (System tvs) = |
83 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
85 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
156 mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds |
158 mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds |
157 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
159 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
158 where |
160 where |
159 injectNamespace (Identifier i _) = do |
161 injectNamespace (Identifier i _) = do |
160 getNS <- gets (flip Map.lookup . namespaces) |
162 getNS <- gets (flip Map.lookup . namespaces) |
161 let f = flip (foldl (\a b -> b:a)) (fromMaybe [] (getNS i)) |
163 let f = flip (foldl (flip (:))) (fromMaybe [] (getNS i)) |
162 modify (\s -> s{currentScope = f $ currentScope s}) |
164 modify (\s -> s{currentScope = f $ currentScope s}) |
163 |
165 |
164 uses2List :: Uses -> [String] |
166 uses2List :: Uses -> [String] |
165 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
167 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
166 |
168 |
167 |
169 |
168 id2C :: InsertOption -> Identifier -> State RenderState Doc |
170 id2C :: InsertOption -> Identifier -> State RenderState Doc |
169 id2C IOInsert (Identifier i t) = do |
171 id2C IOInsert (Identifier i t) = do |
|
172 ns <- gets currentScope |
|
173 {-- case t of |
|
174 BTUnknown -> do |
|
175 ns <- gets currentScope |
|
176 error $ "id2C IOInsert: type BTUnknown for " ++ show i ++ "\nnamespace: " ++ show (take 100 ns) |
|
177 _ -> do --} |
170 modify (\s -> s{currentScope = (n, (i, t)) : currentScope s, lastIdentifier = n}) |
178 modify (\s -> s{currentScope = (n, (i, t)) : currentScope s, lastIdentifier = n}) |
171 return $ text i |
179 return $ text i |
172 where |
180 where |
173 n = map toLower i |
181 n = map toLower i |
174 id2C IOLookup (Identifier i t) = do |
182 id2C IOLookup (Identifier i t) = do |
175 let i' = map toLower i |
183 let i' = map toLower i |
176 v <- gets $ find (\(a, _) -> a == i') . currentScope |
184 v <- gets $ find (\(a, _) -> a == i') . currentScope |
177 ns <- gets currentScope |
185 ns <- gets currentScope |
178 if isNothing v then |
186 if isNothing v then |
179 error $ "Not defined: '" ++ i' ++ "'\n" -- ++ show ns |
187 error $ "Not defined: '" ++ i' ++ "'\n" ++ show (take 100 ns) |
180 else |
188 else |
181 let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
189 let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
182 id2C IODeferred (Identifier i t) = do |
190 id2C IODeferred (Identifier i t) = do |
183 let i' = map toLower i |
191 let i' = map toLower i |
184 v <- gets $ find (\(a, _) -> a == i') . currentScope |
192 v <- gets $ find (\(a, _) -> a == i') . currentScope |
185 if (isNothing v) then |
193 if (isNothing v) then |
186 do |
|
187 modify (\s -> s{currentScope = (i', (i, t)) : currentScope s}) |
|
188 return $ text i |
194 return $ text i |
189 else |
195 else |
190 return . text . fst . snd . fromJust $ v |
196 return . text . fst . snd . fromJust $ v |
191 |
197 |
192 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
198 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
195 ns <- gets currentScope |
201 ns <- gets currentScope |
196 case tb of |
202 case tb of |
197 BTUnknown -> do |
203 BTUnknown -> do |
198 ns <- gets currentScope |
204 ns <- gets currentScope |
199 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " ++ show (take 100 ns) |
205 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " ++ show (take 100 ns) |
200 _ -> id2C IOInsert (Identifier i tb) |
206 _ -> return () |
|
207 id2C IOInsert (Identifier i tb) |
201 |
208 |
202 |
209 |
203 resolveType :: TypeDecl -> State RenderState BaseType |
210 resolveType :: TypeDecl -> State RenderState BaseType |
204 resolveType st@(SimpleType (Identifier i _)) = do |
211 resolveType st@(SimpleType (Identifier i _)) = do |
205 let i' = map toLower i |
212 let i' = map toLower i |
234 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type |
241 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type |
235 resolveType (DeriveType _) = return BTUnknown |
242 resolveType (DeriveType _) = return BTUnknown |
236 resolveType (String _) = return BTString |
243 resolveType (String _) = return BTString |
237 resolveType VoidType = return BTVoid |
244 resolveType VoidType = return BTVoid |
238 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
245 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
239 resolveType (RangeType _) = return $ BTUnknown |
246 resolveType (RangeType _) = return $ BTVoid |
240 resolveType (Set t) = liftM BTSet $ resolveType t |
247 resolveType (Set t) = liftM BTSet $ resolveType t |
241 --resolveType UnknownType = return BTUnknown |
248 |
242 resolveType a = error $ "resolveType: " ++ show a |
|
243 |
|
244 |
249 |
245 fromPointer :: BaseType -> State RenderState BaseType |
250 fromPointer :: BaseType -> State RenderState BaseType |
246 fromPointer (BTPointerTo t) = f t |
251 fromPointer (BTPointerTo t) = f t |
247 where |
252 where |
248 f (BTUnresolved s) = do |
253 f (BTUnresolved s) = do |
250 if isJust v then |
255 if isJust v then |
251 f . snd . snd . fromJust $ v |
256 f . snd . snd . fromJust $ v |
252 else |
257 else |
253 error $ "Unknown type " ++ show t |
258 error $ "Unknown type " ++ show t |
254 f t = return t |
259 f t = return t |
255 fromPointer t = error $ "Dereferencing from non-pointer type " ++ show t |
260 fromPointer t = do |
|
261 ns <- gets currentScope |
|
262 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n\n" ++ show (take 100 ns) |
256 |
263 |
257 |
264 |
258 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
265 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
259 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
266 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
260 t <- type2C returnType |
267 t <- type2C returnType |
335 type2C' VoidType = return $ text "void" |
342 type2C' VoidType = return $ text "void" |
336 type2C' (String l) = return $ text $ "string" ++ show l |
343 type2C' (String l) = return $ text $ "string" ++ show l |
337 type2C' (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i |
344 type2C' (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i |
338 type2C' (PointerTo t) = liftM (<> text "*") $ type2C t |
345 type2C' (PointerTo t) = liftM (<> text "*") $ type2C t |
339 type2C' (RecordType tvs union) = do |
346 type2C' (RecordType tvs union) = do |
340 t <- mapM (tvar2C False) tvs |
347 t <- withState' id $ mapM (tvar2C False) tvs |
341 return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}" |
348 return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}" |
342 type2C' (RangeType r) = return $ text "<<range type>>" |
349 type2C' (RangeType r) = return $ text "<<range type>>" |
343 type2C' (Sequence ids) = do |
350 type2C' (Sequence ids) = do |
344 mapM_ (id2C IOInsert) ids |
351 mapM_ (id2C IOInsert) ids |
345 return $ text "<<sequence type>>" |
352 return $ text "<<sequence type>>" |
387 ph <- phrase2C p |
394 ph <- phrase2C p |
388 return $ |
395 return $ |
389 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
396 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
390 phrase2C (WithBlock ref p) = do |
397 phrase2C (WithBlock ref p) = do |
391 r <- ref2C ref |
398 r <- ref2C ref |
392 ph <- phrase2C $ wrapPhrase p |
399 (BTRecord rs) <- gets lastType |
|
400 ph <- withRecordNamespace rs $ phrase2C $ wrapPhrase p |
393 return $ text "namespace" <> parens r $$ ph |
401 return $ text "namespace" <> parens r $$ ph |
394 phrase2C (ForCycle i' e1' e2' p) = do |
402 phrase2C (ForCycle i' e1' e2' p) = do |
395 i <- id2C IOLookup i' |
403 i <- id2C IOLookup i' |
396 e1 <- expr2C e1' |
404 e1 <- expr2C e1' |
397 e2 <- expr2C e2' |
405 e2 <- expr2C e2' |
444 (BTArray _ t') -> modify (\st -> st{lastType = t'}) |
452 (BTArray _ t') -> modify (\st -> st{lastType = t'}) |
445 (BTString) -> modify (\st -> st{lastType = BTChar}) |
453 (BTString) -> modify (\st -> st{lastType = BTChar}) |
446 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
454 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
447 return $ r <> (brackets . hcat) (punctuate comma es) |
455 return $ r <> (brackets . hcat) (punctuate comma es) |
448 ref2C (SimpleReference name) = id2C IOLookup name |
456 ref2C (SimpleReference name) = id2C IOLookup name |
449 ref2C (RecordField (Dereference ref1) ref2) = do |
457 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
450 r1 <- ref2C ref1 |
458 r1 <- ref2C ref1 |
451 r2 <- ref2C ref2 |
459 t <- fromPointer =<< gets lastType |
|
460 ns <- gets currentScope |
|
461 r2 <- case t of |
|
462 BTRecord rs -> withRecordNamespace rs $ ref2C ref2 |
|
463 BTUnit -> withLastIdNamespace $ ref2C ref2 |
|
464 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
452 return $ |
465 return $ |
453 r1 <> text "->" <> r2 |
466 r1 <> text "->" <> r2 |
454 ref2C rf@(RecordField ref1 ref2) = do |
467 ref2C rf@(RecordField ref1 ref2) = do |
455 r1 <- ref2C ref1 |
468 r1 <- ref2C ref1 |
456 t <- gets lastType |
469 t <- gets lastType |