73 extractTVs (System tv) = tv |
73 extractTVs (System tv) = tv |
74 extractTVs (Program {}) = [] |
74 extractTVs (Program {}) = [] |
75 extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv |
75 extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv |
76 |
76 |
77 tv2id :: TypeVarDeclaration -> [Record] |
77 tv2id :: TypeVarDeclaration -> [Record] |
78 tv2id (TypeDeclaration i t@(Sequence ids)) = map (\(Identifier i _) -> fi i (type2BaseType t)) $ i : ids |
78 tv2id (TypeDeclaration i t@(Sequence ids)) = map (\(Identifier i _) -> fi i BTUnknown) $ i : ids |
79 tv2id (TypeDeclaration (Identifier i _) t) = [(map toLower i, (i, type2BaseType t))] |
79 tv2id (TypeDeclaration (Identifier i _) t) = [(map toLower i, (i, BTUnknown))] |
80 tv2id (VarDeclaration _ (ids, t) _) = map (\(Identifier i _) -> fi i (type2BaseType t)) ids |
80 tv2id (VarDeclaration _ (ids, t) _) = map (\(Identifier i _) -> fi i BTUnknown) ids |
81 tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i BTUnknown] |
81 tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i BTUnknown] |
82 tv2id (OperatorDeclaration i _ _ _ _) = [fi i BTUnknown] |
82 tv2id (OperatorDeclaration i _ _ _ _) = [fi i BTUnknown] |
83 fi i t = (map toLower i, (i, t)) |
83 fi i t = (map toLower i, (i, t)) |
84 |
84 |
85 |
85 |
155 error $ "Not defined: '" ++ i' ++ "'"-- ++ show ns |
155 error $ "Not defined: '" ++ i' ++ "'"-- ++ show ns |
156 else |
156 else |
157 return . text . fst . snd . fromJust $ v |
157 return . text . fst . snd . fromJust $ v |
158 |
158 |
159 id2CTyped :: BaseType -> Identifier -> State RenderState Doc |
159 id2CTyped :: BaseType -> Identifier -> State RenderState Doc |
160 id2CTyped BTUnknown i = error $ show i |
160 id2CTyped BTUnknown i = do |
|
161 ns <- gets currentScope |
|
162 error $ show i ++ "\n" ++ show ns |
161 id2CTyped bt (Identifier i _) = id2C True (Identifier i bt) |
163 id2CTyped bt (Identifier i _) = id2C True (Identifier i bt) |
|
164 |
|
165 |
|
166 resolveType :: TypeDecl -> State RenderState BaseType |
|
167 resolveType st@(SimpleType (Identifier i _)) = do |
|
168 let i' = map toLower i |
|
169 v <- gets $ find (\(a, _) -> a == i') . currentScope |
|
170 if isJust v then return . snd . snd $ fromJust v else return $ f i' |
|
171 where |
|
172 f "integer" = BTInt |
|
173 f "pointer" = BTPointerTo BTVoid |
|
174 f _ = error $ show st |
|
175 resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t |
|
176 resolveType (RecordType tv mtvs) = do |
|
177 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
|
178 return . BTRecord . concat $ tvs |
|
179 where |
|
180 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
|
181 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
|
182 resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t |
|
183 resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
|
184 resolveType (FunctionType _ _) = return BTFunction |
|
185 resolveType (DeriveType _) = return BTInt |
|
186 --resolveType UnknownType = return BTUnknown |
|
187 resolveType a = error $ "resolveType: " ++ show a |
|
188 |
162 |
189 |
163 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
190 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
164 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
191 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
165 t <- type2C returnType |
192 t <- type2C returnType |
166 p <- liftM hcat $ mapM (tvar2C False) params |
193 p <- liftM hcat $ mapM (tvar2C False) params |
186 |
213 |
187 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
214 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
188 |
215 |
189 tvar2C _ td@(TypeDeclaration i' t) = do |
216 tvar2C _ td@(TypeDeclaration i' t) = do |
190 tp <- type2C t |
217 tp <- type2C t |
191 i <- id2CTyped (type2BaseType t) i' |
218 tb <- resolveType t |
|
219 i <- id2CTyped tb i' |
192 return $ text "type" <+> i <+> tp <> text ";" |
220 return $ text "type" <+> i <+> tp <> text ";" |
193 |
221 |
194 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
222 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
195 t' <- type2C t |
223 t' <- type2C t |
196 i <- mapM (id2CTyped (type2BaseType t)) ids |
224 tb <- resolveType t |
|
225 i <- mapM (id2CTyped tb) ids |
197 ie <- initExpr mInitExpr |
226 ie <- initExpr mInitExpr |
198 return $ if isConst then text "const" else empty |
227 return $ if isConst then text "const" else empty |
199 <+> t' |
228 <+> t' |
200 <+> (hsep . punctuate (char ',') $ i) |
229 <+> (hsep . punctuate (char ',') $ i) |
201 <+> ie |
230 <+> ie |
236 mapM_ (id2C True) ids |
265 mapM_ (id2C True) ids |
237 return $ text "<<sequence type>>" |
266 return $ text "<<sequence type>>" |
238 type2C (ArrayDecl r t) = return $ text "<<array type>>" |
267 type2C (ArrayDecl r t) = return $ text "<<array type>>" |
239 type2C (Set t) = return $ text "<<set>>" |
268 type2C (Set t) = return $ text "<<set>>" |
240 type2C (FunctionType returnType params) = return $ text "<<function>>" |
269 type2C (FunctionType returnType params) = return $ text "<<function>>" |
|
270 type2C (DeriveType _) = return $ text "<<type derived from constant literal>>" |
241 |
271 |
242 phrase2C :: Phrase -> State RenderState Doc |
272 phrase2C :: Phrase -> State RenderState Doc |
243 phrase2C (Phrases p) = do |
273 phrase2C (Phrases p) = do |
244 ps <- mapM phrase2C p |
274 ps <- mapM phrase2C p |
245 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
275 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |