1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
module Compiler where
import qualified Ast as A
import Control.Monad.State
import Data.List (sort)
import qualified Data.Map as Map
import Data.Maybe (isJust)
import System.Environment (getEnv, getEnvironment)
import Text.Parsec (ParseError, SourcePos)
import Text.Read (Lexeme (String))
data Error = Error String SourcePos deriving (Eq)
instance Show Error where
show (Error message pos) =
"error: " ++ show pos ++ ":\n" ++ message
instance Ord Error where
compare (Error _ pos1) (Error _ pos2) = compare pos1 pos2
showErrorList :: [Error] -> String
showErrorList errs = unlines $ map show (sort errs)
type Sym = (A.Ident, A.Type, SourcePos)
type SymMap = Map.Map A.Ident Sym
data Env = Env SymMap (Maybe Env) deriving (Show)
-- first parameter tells if we look on the local environment
-- or if we should check also in the parent(s)
getSymB :: Bool -> Env -> A.Ident -> Maybe Sym
getSymB local (Env m parent) id =
case (local, Map.lookup id m) of
(False, Nothing) -> do
p <- parent
getSym p id
(_, s) -> s
-- get symbol
getSym :: Env -> A.Ident -> Maybe Sym
getSym = getSymB False
-- get symbol local
getSyml :: Env -> A.Ident -> Maybe Sym
getSyml = getSymB True
-- if a symbol exists
existsSym :: Env -> A.Ident -> Bool
existsSym env sym = isJust $ getSym env sym
-- if a local symbol exists
existsSyml :: Env -> A.Ident -> Bool
existsSyml env sym = isJust $ getSyml env sym
-- add symbol
addSym :: Env -> Sym -> Env
addSym (Env m parent) (id, typ, pos) = case getSym env id of
Nothing -> Env (Map.insert id sym m) parent
Just s -> Env (Map.singleton id sym) $ Just env
where
env = (Env m parent)
sym = (id, typ, pos)
-- adds a new local environment
addEnv :: Env -> Env
addEnv env = Env Map.empty $ Just env
-- add a local symbol if it doesn't exist
addSymUniq :: Env -> Sym -> Either Error Env
addSymUniq ev (id, typ, pos) = case getSyml ev id of
Nothing -> Right $ addSym ev sym
Just (_, _, p) -> Left $ Error ("\"" ++ id ++ "\" already defined in " ++ show p) pos
where
sym = (id, typ, pos)
toFuncType :: [A.FuncParam] -> Maybe A.Type -> A.Type
toFuncType params rtyp =
A.FuncType (map (\(_, t, _) -> t) params) rtyp
type CompState = (Env, [Error])
type CompResult = Either [Error] ()
startState :: CompState
startState = (Env Map.empty Nothing, [])
compile :: [A.Expr] -> State CompState CompResult
compile (x : xs) = do
case x of
(A.Module name pos) -> return $ Right ()
(A.BinOp _ a b) -> compile [a, b]
(A.Func ident params ret body priv pos) -> do
-- current env
(ev, errs) <- get
-- with function and parameters
(nev, nerrs) <-
return $ case addSymUniq ev (ident, toFuncType params ret, pos) of
Left e -> (ev, e : errs)
Right fev ->
foldl
( \(ev, errs) (id, typ, pos) -> case addSymUniq ev (id, typ, pos) of
Right ev -> (ev, errs)
Left nerr -> (ev, nerr : errs)
)
(addEnv fev, errs)
params
put (nev, nerrs)
r <- compile body
(_, errs) <- get
put (ev, errs)
return r
(A.Call ident args pos) -> do
id <- compile [ident]
return $ Right ()
(A.Return value pos) -> case value of
Nothing -> return $ Right ()
Just v -> compile [v]
(A.Var ident pos) -> do
(ev, errs) <- get
if existsSym ev ident
then return $ Right ()
else do
put (ev, Error ("undefined variable \"" ++ ident ++ "\"") pos : errs)
return $ Right ()
_ -> compile []
compile xs
compile [] = do
(_, errs) <- get
case errs of
[] -> return $ Right ()
_ -> return $ Left errs
|
