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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
implementation module Sil.Parse
import StdBool
import StdChar
from StdFunc import flip, o
import StdInt
import StdList
import StdString
import StdTuple
import Control.Applicative
import Control.Monad
import Data.Error
from Data.Func import $
import Data.Functor
import Data.List
import Data.Maybe
import qualified Text as T
from Text import <+, class Text, instance Text String
import GenEq
import Sil.Parse.Parser
import Sil.Syntax
import Sil.Util
derive gEq Token, Literal
instance == Token where == a b = gEq{|*|} a b
instance toString Token
where
toString TParenOpen = "("
toString TParenClose = ")"
toString TBraceOpen = "{"
toString TBraceClose = "}"
toString TComma = ","
toString TSemicolon = ";"
toString TAssign = ":="
toString TTilde = "~"
toString TPlus = "+"
toString TMinus = "-"
toString TStar = "*"
toString TSlash = "/"
toString TPercent = "%"
toString (TLit l) = toString l
toString TIf = "if"
toString TWhile = "while"
toString TReturn = "return"
toString (TMachineCode s) = "|~ " +++ s
toString (TName s) = s
instance name Token
where
name (TLit _) = "literal"
name (TName _) = "name"
name (TMachineCode _) = "machine code"
name t = toString t
instance toString ParseError
where
toString (Invalid loc sym) = "Invalid token '" <+ sym <+ "' while parsing a " <+ loc <+ "."
toString (Expected s) = "Expected " <+ s <+ "."
toString UnknownError = "Unknown error."
tokenise :: [Char] -> MaybeError ParseError [Token]
tokenise cs = reverse <$> tks cs []
where
tks :: [Char] [Token] -> MaybeError ParseError [Token]
tks [] t = pure t
tks ['(':r] t = tks r [TParenOpen :t]
tks [')':r] t = tks r [TParenClose:t]
tks ['{':r] t = tks r [TBraceOpen :t]
tks ['}':r] t = tks r [TBraceClose:t]
tks [',':r] t = tks r [TComma :t]
tks [';':r] t = tks r [TSemicolon :t]
tks ['~':r] t = tks r [TTilde :t]
tks ['+':r] t = tks r [TPlus :t]
tks ['-':r] t = tks r [TMinus :t]
tks ['*':r] t = tks r [TStar :t]
tks ['/':r] t = tks r [TSlash :t]
tks ['%':r] t = tks r [TPercent :t]
tks [':':'=':r] t = tks r [TAssign :t]
tks ['i':'f' :s:r] t | isSpace s = tks r [TIf :t]
tks ['w':'h':'i':'l':'e' :s:r] t | isSpace s = tks r [TWhile :t]
tks ['r':'e':'t':'u':'r':'n':s:r] t | isSpace s = tks r [TReturn:t]
tks ['T':'r':'u':'e' :s:r] t | isSpace s = tks r [TLit $ BLit True :t]
tks ['F':'a':'l':'s':'e' :s:r] t | isSpace s = tks r [TLit $ BLit False:t]
tks ['|':'~':r] t = tks r` [TMachineCode $ toString c:t]
where (c,r`) = span (not o flip isMember ['\r\n']) r
tks cs=:[h:_] t
| isSpace h = tks (dropWhile isSpace cs) t
| isDigit h = tks numrest [TLit $ ILit $ toInt $ toString num:t]
| not (isNameChar h) = Error $ Invalid "name" h
| otherwise = tks namerest [TName $ toString name:t]
where
(name,namerest) = span isNameChar cs
(num,numrest) = span isDigit cs
isNameChar :: Char -> Bool
isNameChar c = isAlpha c || isMember c ['_\'']
parse :: ([Token] -> MaybeError ParseError Program)
parse = fst o runParser program
program :: Parser Token Program
program = (\fs -> {p_funs=fs}) <$> some function <* eof
function :: Parser Token Function
function =
type >>= \t ->
name >>= \n ->
item TParenOpen *>
seplist TComma arg >>= \args ->
item TParenClose *>
item TBraceOpen *>
codeblock >>= \cb ->
item TBraceClose *> pure
{ f_type = t
, f_name = n
, f_args = args
, f_code = cb
}
codeblock :: Parser Token CodeBlock
codeblock = many initialisation >>= \is ->
many statement >>= \s ->
pure {cb_init=flatten is, cb_content=s}
initialisation :: Parser Token [Initialisation]
initialisation =
type >>= \t ->
seplist TComma name >>= \ns ->
item TSemicolon >>= \_ ->
pure [{init_type=t, init_name=n} \\ n <- ns]
statement :: Parser Token Statement
statement = ((declaration
<|> liftM Application application
<|> return
/* <|> if`
<|> while*/) <* item TSemicolon) <|> machinecode
where
declaration :: Parser Token Statement
declaration = liftM2 Declaration name (item TAssign *> application)
return :: Parser Token Statement
return = liftM Return (item TReturn *> optional application)
machinecode :: Parser Token Statement
machinecode = (\(TMachineCode s) -> MachineStm s) <$> satisfy isMachineCode
where isMachineCode (TMachineCode _) = True; isMachineCode _ = False
application :: Parser Token Application
application
= leftAssoc
( op TPlus Add
<|> op TMinus Sub
)
$ leftAssoc
( op TStar Mul
<|> op TSlash Div
<|> op TPercent Rem
)
$ noInfix
where
op :: Token Op2 -> Parser Token Op2
op token operator = item token *> pure operator
leftAssoc :: (Parser Token Op2) (Parser Token Application) -> Parser Token Application
leftAssoc opp appp = appp >>= \e1 -> many (opp >>= \op -> appp >>= \e -> pure (op,e))
>>= foldM (\e (op,e2) -> pure $ BuiltinApp2 e op e2) e1
noInfix :: Parser Token Application
noInfix
= liftM2 App name (item TParenOpen *> seplist TComma application <* item TParenClose)
<|> liftM (BuiltinApp Neg) (item TTilde *> noInfix)
<|> liftM Literal literal
<|> liftM Name name
name :: Parser Token Name
name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
where
isName (TName _) = True
isName _ = False
arg :: Parser Token Arg
arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name})
<?> Expected "argument"
type :: Parser Token Type
type
= type "Bool" TBool
<|> type "Int" TInt
<|> type "Void" TVoid
<?> Expected "type"
where
type s t = item (TName s) *> pure t
literal :: Parser Token Literal
literal = satisfy isLit >>= \(TLit lit) -> pure lit
where
isLit :: Token -> Bool
isLit (TLit _) = True
isLit _ = False
|
