forked from ppedemon/hava
-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathClassParser.hs
278 lines (203 loc) · 8.97 KB
/
ClassParser.hs
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
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
module ClassParser(parseClass) where
import VMErr
import BitUtils
import ClassRep
{----------------------------------------------------------------
This module implements the Java class parser. Kind of ugly,
the class file format is plenty of pointers, and akin stuff.
----------------------------------------------------------------}
type VMParse = Either Class VMErr
-----------------------------------------------------------------
-- The java class parser starts here
-----------------------------------------------------------------
parseClass :: String -> [Int] -> VMParse
parseClass = checkFmt
checkFmt :: String -> [Int] -> VMParse
checkFmt name cls =
case cls of
(0xCA:0xFE:0xBA:0xBE:cs) -> checkVersion name cs
_ -> Right (clsFormatErr name)
checkVersion :: String -> [Int] -> VMParse
checkVersion name cls =
case cls of
(0x00:0x03:0x00:0x2D:cs) -> parse cs
_ -> Right (unsupportedClsVersionErr name)
parse :: [Int] -> VMParse
parse cs =
let (cp,cs1) = parseCP cs
(flags,cs2) = parseInt16 cs1
(this,cs3) = parseInt16 cs2
(super,cs4) = parseInt16 cs3
(ints,cs5) = parseInterfaces cs4
(fields,cs6) = parseFields cs5 cp
(methods,cs7) = parseMethods cs6 cp
this_name = getClsName cp this
super_name = getClsName cp super
interfaces = map (getClsName cp) ints
in Left (newClass this_name super_name flags interfaces cp fields methods)
parseInt16 :: [Int] -> (Int,[Int])
parseInt16 (hi:lo:cs) = (getInt16 hi lo, cs)
getClsName :: CP -> CPIx -> String
getClsName _ 0 = ""
getClsName cp ix =
let CPClass ix' = cp <@> ix
CPUtf8 name = cp <@> ix'
in name
-----------------------------------------------------------------
-- Parse the java class Constant Pool (CP)
-----------------------------------------------------------------
parseCP :: [Int] -> (CP,[Int])
parseCP (cphi:cplo:cs) = parseCPEntries cs (getInt16 cphi cplo)
parseCPEntries :: [Int] -> Int -> (CP,[Int])
parseCPEntries cls 1 = (newCP,cls)
parseCPEntries (tag:es) n =
case tag of
0x7 -> parseClassName es n
0x9 -> parseFieldRef es n
0xA -> parseMethodRef es n
0xB -> parseInterfaceMethodRef es n
0xC -> parseNameAndType es n
0x8 -> parseString es n
0x3 -> parseInteger es n
0x4 -> parseFloat es n
0x5 -> parseLong es n
0x6 -> parseDouble es n
0x1 -> parseUtf8 es n
parseClassName :: [Int] -> Int -> (CP,[Int])
parseClassName (hi:lo:es) n =
let (cp,rest) = parseCPEntries es (n-1)
in (CPClass (getInt16 hi lo) <+> cp, rest)
parseFieldRef :: [Int] -> Int -> (CP,[Int])
parseFieldRef (hi:lo:hi1:lo1:es) n =
let (cp,rest) = parseCPEntries es (n-1)
in (CPField (getInt16 hi lo, getInt16 hi1 lo1) <+> cp, rest)
parseMethodRef :: [Int] -> Int -> (CP,[Int])
parseMethodRef (hi:lo:hi1:lo1:es) n =
let (cp,rest) = parseCPEntries es (n-1)
in (CPMethod (getInt16 hi lo, getInt16 hi1 lo1) <+> cp, rest)
parseInterfaceMethodRef :: [Int] -> Int -> (CP,[Int])
parseInterfaceMethodRef (hi:lo:hi1:lo1:es) n =
let (cp,rest) = parseCPEntries es (n-1)
in (CPIMethod (getInt16 hi lo, getInt16 hi1 lo1) <+> cp, rest)
parseNameAndType :: [Int] -> Int -> (CP,[Int])
parseNameAndType (hi:lo:hi1:lo1:es) n =
let (cp,rest) = parseCPEntries es (n-1)
in (CPNameType (getInt16 hi lo, getInt16 hi1 lo1) <+> cp, rest)
parseString :: [Int] -> Int -> (CP,[Int])
parseString (hi:lo:es) n =
let (cp,rest) = parseCPEntries es (n-1)
in (CPStr (getInt16 hi lo) <+> cp, rest)
parseInteger :: [Int] -> Int -> (CP,[Int])
parseInteger (i4:i3:i2:i1:es) n =
let (cp,rest) = parseCPEntries es (n-1)
in (CPInt (getInt32 i4 i3 i2 i1) <+> cp, rest)
parseFloat :: [Int] -> Int -> (CP,[Int])
parseFloat (i4:i3:i2:i1:es) n =
let (cp,rest) = parseCPEntries es (n-1)
in (CPFloat (getFloat i4 i3 i2 i1) <+> cp, rest)
parseLong :: [Int] -> Int -> (CP,[Int])
parseLong (i8:i7:i6:i5:i4:i3:i2:i1:es) n =
let (cp,rest) = parseCPEntries es (n-2)
in (CPLong (getInt64 i8 i7 i6 i5 i4 i3 i2 i1) <+> CPPad <+> cp, rest)
parseDouble :: [Int] -> Int -> (CP,[Int])
parseDouble (i8:i7:i6:i5:i4:i3:i2:i1:es) n =
let (cp,rest) = parseCPEntries es (n-2)
in (CPDouble (getDouble i8 i7 i6 i5 i4 i3 i2 i1) <+> CPPad <+> cp, rest)
parseUtf8 :: [Int] -> Int -> (CP,[Int])
parseUtf8 (hi:lo:es) n =
let (bytes,es') = splitAt (getInt16 hi lo) es
(cp,rest) = parseCPEntries es' (n-1)
in (CPUtf8 (getUtf8 bytes) <+> cp, rest)
-----------------------------------------------------------------
-- Get the interfaces implemented by the class being parsed
-----------------------------------------------------------------
parseInterfaces :: [Int] -> ([CPIx],[Int])
parseInterfaces (ichi:iclo:is) =
let (ints,cs) = splitAt (getInt16 ichi iclo * 2) is
in (getInts ints, cs)
getInts :: [Int] -> [Int]
getInts cs = if null cs
then []
else let (n,rs) = parseInt16 cs
in n : getInts rs
-----------------------------------------------------------------
-- Get the class fields (both static and instance fields)
-----------------------------------------------------------------
parseFields :: [Int] -> CP -> ([FInfo],[Int])
parseFields (hi:lo:cs) cp = parseNFields cs cp (getInt16 hi lo)
parseNFields :: [Int] -> CP -> Int -> ([FInfo],[Int])
parseNFields cs _ 0 = ([],cs)
parseNFields (fhi:flo:nhi:nlo:dhi:dlo:ahi:alo:cs) cp n =
let flgs = getInt16 fhi flo
CPUtf8 name = cp <@> getInt16 nhi nlo
CPUtf8 desc = cp <@> getInt16 dhi dlo
(ix,rs1) = parseFieldAttrs cs cp (getInt16 ahi alo)
(fs,rs2) = parseNFields rs1 cp (n-1)
in (newField flgs name desc ix : fs, rs2)
parseFieldAttrs :: [Int] -> CP -> Int -> (Maybe CPIx,[Int])
parseFieldAttrs cs _ 0 = (Nothing,cs)
parseFieldAttrs (hi:lo:cs) cp n =
let CPUtf8 str = cp <@> getInt16 hi lo
in case str of
"ConstantValue" -> getConstant cs cp n
_ -> parseFieldAttrs (snd (splitAt 4 cs)) cp (n-1)
getConstant :: [Int] -> CP -> Int -> (Maybe CPIx,[Int])
getConstant (_:_:_:_:hi:lo:cs) cp n =
(Just (getInt16 hi lo), snd (splitAt ((n-1) * 6) cs))
-----------------------------------------------------------------
-- Get the class methods. This is quite a mess, as methods have
-- a lot of attributes:
--
-- 1 The exceptions thrown by the method
-- 2 The code, who has itself two nested attributes:
-- 2.1 The bytedcode stream
-- 2.2 The exception table
-- 3 Local variable table, Line number table, and deprecated.
-- These attributes are silently ignored
-----------------------------------------------------------------
data Attr = Attr [CPIx] [Int] [EInfo]
parseMethods :: [Int] -> CP -> ([MInfo],[Int])
parseMethods (mhi:mlo:cs) cp =
parseNMethods cs cp (getInt16 mhi mlo)
parseNMethods :: [Int] -> CP -> Int -> ([MInfo],[Int])
parseNMethods cs _ 0 = ([],cs)
parseNMethods (fhi:flo:nhi:nlo:dhi:dlo:ahi:alo:cs) cp n =
let flgs = getInt16 fhi flo
CPUtf8 name = cp <@> getInt16 nhi nlo
CPUtf8 desc = cp <@> getInt16 dhi dlo
acount = getInt16 ahi alo
(Attr ex c etbl,rs) = parseMethodAttrs cs cp acount (Attr [] [] [])
(ms,ss) = parseNMethods rs cp (n-1)
in (newMethod flgs name desc ex c etbl : ms, ss)
parseMethodAttrs :: [Int] -> CP -> Int -> Attr -> (Attr, [Int])
parseMethodAttrs cs _ 0 m = (m,cs)
parseMethodAttrs (nhi:nlo:lhh:lhl:llh:lll:cs) cp n (Attr e c tbl) =
let CPUtf8 name = cp <@> getInt16 nhi nlo
(rs,ss) = splitAt (getInt32 lhh lhl llh lll) cs
in case name of
"Code" -> let (code,etbl) = parseCodeAttr rs
in parseMethodAttrs ss cp (n-1) (Attr e code etbl)
"Exceptions" -> let e = parseExceptionsAttr rs
in parseMethodAttrs ss cp (n-1) (Attr e c tbl)
_ -> parseMethodAttrs ss cp (n-1) (Attr e c tbl)
parseCodeAttr :: [Int] -> ([Int],[EInfo])
parseCodeAttr (_:_:_:_:lhh:lhl:llh:lll:cs) =
let ccount = getInt32 lhh lhl llh lll
(code,rs) = splitAt ccount cs
etbl = let (ehi:elo:ss) = rs
in parseETbl ss (getInt16 ehi elo)
in (code,etbl)
parseETbl :: [Int] -> Int -> [EInfo]
parseETbl _ 0 = []
parseETbl (shi:slo:ehi:elo:hhi:hlo:ihi:ilo:cs) n =
let spc = getInt16 shi slo
epc = getInt16 ehi elo
hpc = getInt16 hhi hlo
ix = getInt16 ihi ilo
in EInfo spc epc hpc ix : parseETbl cs (n-1)
parseExceptionsAttr :: [Int] -> [CPIx]
parseExceptionsAttr (_:_:cs) = parseExceptionsAttr' cs
parseExceptionsAttr' :: [Int] -> [Int]
parseExceptionsAttr' [] = []
parseExceptionsAttr' (hi:lo:cs) =
getInt16 hi lo : parseExceptionsAttr' cs