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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
|
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.Syntax
import Sil.Types
import Sil.Util.Parser
import Sil.Util.Printer
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 [TAssign :t]
tks ['=':'=':r] t = tks r [TDoubleEquals :t]
tks ['|':'|':r] t = tks r [TDoubleBar :t]
tks ['&':'&':r] t = tks r [TDoubleAmpersand: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 [TExclamation: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 ['i':'f' :r=:[n:_]] t | isNotNameChar n = tks r [TIf :t]
tks ['e':'l':'s':'e' :r=:[n:_]] t | isNotNameChar n = tks r [TElse :t]
tks ['w':'h':'i':'l':'e' :r=:[n:_]] t | isNotNameChar n = tks r [TWhile :t]
tks ['r':'e':'t':'u':'r':'n':r=:[n:_]] t | isNotNameChar n = tks r [TReturn:t]
tks ['T':'r':'u':'e' :r=:[n:_]] t | isNotNameChar n = tks r [TLit $ BLit True :t]
tks ['F':'a':'l':'s':'e' :r=:[n:_]] t | isNotNameChar n = 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 ['_\'']
isNotNameChar = not o isNameChar
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 $>
{ 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 init >>= \nvs ->
item TSemicolon $>
[{init_type=t, init_name=n, init_value=v} \\ (n,v) <- nvs]
where
init =
name >>= \n ->
optional (item TAssign *> expression) >>= \v ->
pure (n,v)
statement :: Parser Token Statement
statement = declaration
<|> liftM Application (expression <* item TSemicolon)
<|> return
<|> if`
<|> while
<|> machinecode
where
declaration :: Parser Token Statement
declaration = liftM2 Declaration name (item TAssign *> expression <* item TSemicolon)
return :: Parser Token Statement
return = liftM Return (item TReturn *> optional expression <* item TSemicolon)
machinecode :: Parser Token Statement
machinecode = (\(TMachineCode s) -> MachineStm s) <$> satisfy isMachineCode
where isMachineCode (TMachineCode _) = True; isMachineCode _ = False
if` :: Parser Token Statement
if` = item TIf *>
parenthised expression >>= \cond ->
braced codeblock >>= \iftrue ->
many elseif >>= \elseifs ->
optional (item TElse *> braced codeblock) >>= \iffalse ->
pure $ If [(cond,iftrue):elseifs] iffalse
where
elseif = list [TElse, TIf] *>
parenthised expression >>= \cond ->
braced codeblock >>= \block ->
pure (cond, block)
while :: Parser Token Statement
while = item TWhile *>
parenthised expression >>= \cond ->
braced codeblock >>= \do ->
pure $ While cond do
expression :: Parser Token Expression
expression
= rightAssoc (op TDoubleBar LogOr)
$ rightAssoc (op TDoubleAmpersand LogAnd)
$ rightAssoc (op TDoubleEquals Equals)
$ 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 $> operator
rightAssoc :: (Parser Token Op2) (Parser Token Expression) -> Parser Token Expression
rightAssoc opp appp = appp >>= \e1 -> optional (opp >>= \op -> rightAssoc opp appp >>= \e -> pure (op,e))
>>= pure o maybe e1 (\(op,e2) -> BuiltinApp2 e1 op e2)
leftAssoc :: (Parser Token Op2) (Parser Token Expression) -> Parser Token Expression
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 Expression
noInfix
= liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose)
<|> op TTilde Neg
<|> op TExclamation Not
<|> liftM Literal literal
<|> liftM Name name
<|> parenthised expression
where
op :: Token Op1 -> Parser Token Expression
op token operator = liftM (BuiltinApp operator) (item token *> noInfix)
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) $> t
literal :: Parser Token Literal
literal = satisfy isLit >>= \(TLit lit) -> pure lit
where
isLit :: Token -> Bool
isLit (TLit _) = True
isLit _ = False
parenthised :: (Parser Token a) -> Parser Token a
parenthised p = item TParenOpen *> p <* item TParenClose
braced :: (Parser Token a) -> Parser Token a
braced p = item TBraceOpen *> p <* item TBraceClose
|
