« back to all changes in this revision
Viewing changes to haxe/genswf9.ml
- browse files at revision 3
- compare with another revision
- download diff
- download tarball
- view history from revision 3
- Committer: Bazaar Package Importer
- Author(s): Jens Peter Secher
- Date: 2008-06-15 11:04:09 UTC
- mfrom: (2.1.6 intrepid)
- Revision ID: james.westby@ubuntu.com-20080615110409-7pyykgwmk5v0cues
Tags: 1:1.19-3
* Remove bashism in script.
(Closes: #484390)
* Upgrade to Policy 3.8.0 by including a README.source explaining how to
use dpatch.
(Closes: #484390)
* Upgrade to Policy 3.8.0 by including a README.source explaining how to
use dpatch.
- files added:
- debian/README.source
- haxe/std/haxe/rtti
- haxe/std/mtwin/net
- haxe/std/neko/net
- haxe/std/neko/vm
- haxe/std/tools/hxinst
- haxe/tests
- haxe/tests/benchs
- ocaml/extc/zlib
- ocaml/xml-light
- files removed:
- haxe/std/haxe/Proxy.hx
- files modified:
- debian/changelog
added
removed
haxe/genswf9.ml
19
19
open Ast
20
20
open Type
21
21
open As3
22
23
type ('a,'b) gen_lookup = {
24
h : ('a,'b) Hashtbl.t;
25
a : 'a DynArray.t;
26
c : int -> 'b;
27
}
28
29
type 'a lookup = ('a,'a index) gen_lookup
30
type 'a lookup_nz = ('a,'a index_nz) gen_lookup
22
open As3hl
31
23
32
24
type read = Read
33
25
type write = Unused__ | Write
34
26
27
type tkind =
28
| KInt
29
| KUInt
30
| KFloat
31
| KBool
32
| KType of hl_name
33
| KDynamic
34
| KNone
35
36
type register = {
37
rid : int;
38
rtype : tkind;
39
mutable rused : bool;
40
mutable rinit : bool;
41
mutable rcond : bool;
42
}
43
35
44
type 'a access =
36
| VReg of reg
37
| VId of type_index
38
| VGlobal of type_index * bool
45
| VReg of register
46
| VId of hl_name
47
| VCast of hl_name * tkind
48
| VGlobal of hl_name
39
49
| VArray
40
| VScope of int
50
| VScope of hl_slot
41
51
42
52
type local =
43
| LReg of reg
44
| LScope of int
45
| LGlobal of type_index
53
| LReg of register
54
| LScope of hl_slot
55
| LGlobal of hl_name
46
56
47
57
type code_infos = {
48
mutable iregs : int;
49
mutable imaxregs : int;
58
mutable iregs : register DynArray.t;
50
59
mutable ipos : int;
51
60
mutable istack : int;
52
61
mutable imax : int;
53
62
mutable iscopes : int;
54
63
mutable imaxscopes : int;
55
64
mutable iloop : int;
65
mutable icond : bool;
56
66
}
57
67
58
68
type try_infos = {
64
74
65
75
type context = {
66
76
(* globals *)
67
strings : string lookup;
68
ints : int32 lookup;
69
floats : float lookup;
70
brights : as3_base_right lookup;
71
rights : as3_rights lookup;
72
types : as3_type lookup;
73
mtypes : as3_method_type lookup_nz;
74
mutable classes : as3_class list;
75
mutable statics : as3_static list;
76
functions : as3_function lookup;
77
rpublic : as3_base_right index;
78
gpublic : as3_rights index;
79
77
debug : bool;
80
78
mutable last_line : int;
81
79
mutable last_file : string;
80
boot : string;
82
81
(* per-function *)
83
82
mutable locals : (string,local) PMap.t;
84
mutable code : as3_opcode DynArray.t;
83
mutable code : hl_opcode DynArray.t;
85
84
mutable infos : code_infos;
86
85
mutable trys : try_infos list;
87
86
mutable breaks : (unit -> unit) list;
88
87
mutable continues : (int -> unit) list;
89
88
mutable in_static : bool;
90
89
mutable curblock : texpr list;
91
mutable block_vars : (int * string) list;
92
mutable try_scope_reg : int option;
90
mutable block_vars : (hl_slot * string * t) list;
91
mutable try_scope_reg : register option;
92
mutable for_call : bool;
93
93
}
94
94
95
95
let error p = Typer.error "Invalid expression" p
96
96
let stack_error p = Typer.error "Stack error" p
97
97
98
let stack_delta = function
99
| A3Throw -> -1
100
| A3GetSuper _ -> 1
101
| A3SetSuper _ -> -1
102
| A3RegReset _ -> 0
103
| A3Nop -> 0
104
| A3Jump (cond,_) ->
105
(match cond with
106
| J3Always -> 0
107
| J3True
108
| J3False -> -1
109
| _ -> -2)
110
| A3Switch _ -> -1
111
| A3PopScope -> 0
112
| A3XmlOp3 -> assert false
113
| A3ForIn | A3ForEach -> -1
114
| A3Null
115
| A3Undefined
116
| A3SmallInt _
117
| A3Int _
118
| A3True
119
| A3False
120
| A3String _
121
| A3IntRef _
122
| A3Function _
123
| A3Float _
124
| A3NaN -> 1
125
| A3Pop -> -1
126
| A3Dup -> 1
127
| A3CatchDone -> assert false
128
| A3Scope -> -1
129
| A3Next _ -> 1
130
| A3StackCall n -> -(n + 1)
131
| A3StackNew n -> -n
132
| A3SuperCall (_,n) -> -n
133
| A3Call (_,n) -> -n
134
| A3RetVoid -> 0
135
| A3Ret -> -1
136
| A3SuperConstr n -> -(n + 1)
137
| A3New (_,n) -> -n
138
| A3SuperCallUnknown (_,n) -> -(n + 1)
139
| A3CallUnknown (_,n) -> -(n + 1)
140
| A3Object n -> -(n * 2) + 1
141
| A3Array n -> -n + 1
142
| A3NewBlock -> 1
143
| A3ClassDef _ -> 0
144
| A3XmlOp1 _ -> assert false
145
| A3Catch _ -> assert false
146
| A3GetInf _ -> 1
147
| A3SetInf _ -> 1
148
| A3GetProp _ -> 1
149
| A3SetProp _ -> -2
150
| A3Reg _ -> 1
151
| A3SetReg _ -> -1
152
| A3GetScope0 | A3GetScope _ -> 1
153
| A3Get _ -> 0
154
| A3Set _ -> -2
155
| A3Delete _ -> -1
156
| A3GetSlot _ -> 0
157
| A3SetSlot _ -> -2
158
| A3ToXml
159
| A3ToInt
160
| A3ToUInt
161
| A3ToNumber
162
| A3ToObject
163
| A3ToString
164
| A3ToBool -> 0
165
| A3XmlOp2 -> assert false
166
| A3Cast _ -> 0
167
| A3Typeof -> 0
168
| A3InstanceOf -> -1
169
| A3IncrReg _ -> 0
170
| A3This -> 1
171
| A3DebugReg _
172
| A3DebugLine _
173
| A3DebugFile _ -> 0
174
| A3Op op ->
175
(match op with
176
| A3ONeg | A3OIncr | A3ODecr | A3ONot | A3OBitNot | A3OIIncr | A3OIDecr -> 0
177
| _ -> -1)
178
| A3Unk _ -> assert false
179
180
98
let index_int (x : int) : 'a index = Obj.magic (x + 1)
181
99
let index_nz_int (x : int) : 'a index_nz = Obj.magic x
182
100
let tid (x : 'a index) : int = Obj.magic x
183
101
184
let new_lookup() = { h = Hashtbl.create 0; a = DynArray.create(); c = index_int }
185
let new_lookup_nz() = { h = Hashtbl.create 0; a = DynArray.create(); c = index_nz_int }
186
187
let construct_string = "__skip__constructor__"
188
let jsize = As3code.length (A3Jump (J3Always,0))
189
190
let lookup i w =
191
try
192
Hashtbl.find w.h i
193
with
194
Not_found ->
195
let id = w.c (DynArray.length w.a) in
196
Hashtbl.add w.h i id;
197
DynArray.add w.a i;
198
id
199
200
let add i w =
201
let id = w.c (DynArray.length w.a) in
202
DynArray.add w.a i;
203
id
204
205
let lookup_array w = DynArray.to_array w.a
206
207
let string ctx i = lookup i ctx.strings
102
let ethis = mk (TConst TThis) (mk_mono()) null_pos
103
let dynamic_prop = HMMultiNameLate [HNPublic (Some "")]
104
105
let t_void = TEnum ({
106
e_path = [],"Void";
107
e_pos = null_pos;
108
e_doc = None;
109
e_private = false;
110
e_extern = false;
111
e_types = [];
112
e_constrs = PMap.empty;
113
e_names = [];
114
},[])
115
116
let t_string = TInst (mk_class ([],"String") null_pos None false,[])
117
let t_int = TInst (mk_class ([],"Int") null_pos None false,[])
208
118
209
119
let write ctx op =
210
120
DynArray.add ctx.code op;
211
ctx.infos.ipos <- As3code.length op + ctx.infos.ipos;
212
let s = ctx.infos.istack + stack_delta op in
121
ctx.infos.ipos <- ctx.infos.ipos + 1;
122
let s = ctx.infos.istack + As3hlparse.stack_delta op in
213
123
ctx.infos.istack <- s;
214
124
if s > ctx.infos.imax then ctx.infos.imax <- s;
215
125
match op with
216
| A3Scope ->
126
| HScope ->
217
127
let n = ctx.infos.iscopes + 1 in
218
128
ctx.infos.iscopes <- n;
219
129
if n > ctx.infos.imaxscopes then ctx.infos.imaxscopes <- n
220
| A3PopScope ->
130
| HPopScope ->
221
131
ctx.infos.iscopes <- ctx.infos.iscopes - 1
222
132
| _ ->
223
133
()
224
134
225
135
let jump ctx cond =
226
136
let op = DynArray.length ctx.code in
227
write ctx (A3Jump (cond,-4));
228
137
let p = ctx.infos.ipos in
138
write ctx (HJump (cond,0));
229
139
(fun () ->
230
140
let delta = ctx.infos.ipos - p in
231
DynArray.set ctx.code op (A3Jump (cond,delta))
141
DynArray.set ctx.code op (HJump (cond,delta))
232
142
)
233
143
234
144
let jump_back ctx =
235
let j = jump ctx J3Always in
236
145
let p = ctx.infos.ipos in
237
write ctx A3Nop;
238
j , (fun cond ->
239
let delta = p + -(ctx.infos.ipos + jsize) in
240
write ctx (A3Jump (cond,delta))
146
write ctx HLabel;
147
(fun cond ->
148
let delta = p - ctx.infos.ipos in
149
write ctx (HJump (cond,delta))
241
150
)
242
151
243
let type_path ctx ?(getclass=false) (pack,name) =
244
let pid = string ctx (String.concat "." pack) in
245
let nameid = string ctx name in
246
let pid = lookup (A3RPublic (Some pid)) ctx.brights in
247
let tid = lookup (if getclass then A3TClassInterface (Some nameid,lookup [pid] ctx.rights) else A3TMethodVar (nameid,pid)) ctx.types in
248
tid
249
250
let fake_type_path ctx ?(getclass=false) path =
251
type_path ctx ~getclass (match path with
152
let type_path ctx path =
153
let pack, name = (match path with
252
154
| [] , "Int" -> [] , "int"
155
| [] , "UInt" -> [] , "uint"
253
156
| [] , "Float" -> [] , "Number"
254
157
| [] , "Bool" -> [] , "Boolean"
255
| _ -> path)
256
257
let ident ctx i = type_path ctx ([],i)
158
| [] , "Enum" -> [] , "Class"
159
| ["flash";"xml"], "XML" -> [], "XML"
160
| ["flash";"xml"], "XMLList" -> [], "XMLList"
161
| ["flash"] , "FlashXml__" -> [] , "Xml"
162
| ["flash"] , "Boot" -> [] , ctx.boot
163
| _ -> path
164
) in
165
HMPath (pack,name)
166
167
let rec follow_basic t =
168
match t with
169
| TMono r ->
170
(match !r with
171
| Some t -> follow_basic t
172
| _ -> t)
173
| TLazy f ->
174
follow_basic (!f())
175
| TType (t,tl) when t.t_path <> ([],"Null") && t.t_path <> ([],"UInt") ->
176
follow_basic (apply_params t.t_types tl t.t_type)
177
| _ -> t
178
179
let type_id ctx t =
180
match follow_basic t with
181
| TEnum ({ e_path = path; e_extern = false },_) ->
182
type_path ctx path
183
| TInst (c,_) ->
184
(match c.cl_kind with
185
| KTypeParameter ->
186
(match c.cl_implements with
187
| [csup,_] -> type_path ctx csup.cl_path
188
| _ -> type_path ctx ([],"Object"))
189
| KExtension (c,_) ->
190
type_path ctx c.cl_path
191
| _ ->
192
type_path ctx c.cl_path)
193
| TFun _ ->
194
type_path ctx ([],"Function")
195
| TEnum ({ e_path = ([],"Class") as path },_)
196
| TEnum ({ e_path = ([],"Bool") as path },_)
197
| TType ({ t_path = ([],"UInt") as path },_) ->
198
type_path ctx path
199
| _ ->
200
HMPath ([],"Object")
201
202
let type_opt ctx t =
203
match follow t with
204
| TDynamic _ -> None
205
| _ -> Some (type_id ctx t)
206
207
let type_void ctx t =
208
match follow t with
209
| TEnum ({ e_path = [],"Void" },_) -> Some (HMPath ([],"void"))
210
| _ -> type_opt ctx t
211
212
let classify ctx t =
213
match follow_basic t with
214
| TInst ({ cl_path = [],"Int" },_) ->
215
KInt
216
| TInst ({ cl_path = [],"Float" },_) ->
217
KFloat
218
| TEnum ({ e_path = [],"Bool" },_) ->
219
KBool
220
| TEnum _
221
| TInst _ ->
222
KType (type_id ctx t)
223
| TType ({ t_path = [],"UInt" },_) ->
224
KUInt
225
| TFun _ ->
226
KType (HMPath ([],"Function"))
227
| TAnon a ->
228
(match !(a.a_status) with
229
| Statics _ -> KNone
230
| _ -> KDynamic)
231
| TMono _
232
| TType _
233
| TDynamic _ ->
234
KDynamic
235
| TLazy _ ->
236
assert false
237
238
let ident i = HMPath ([],i)
239
240
let as3 p =
241
HMName (p,HNNamespace "http://adobe.com/AS3/2006/builtin")
242
243
let property p t =
244
match follow t with
245
| TInst ({ cl_path = [],"Array" },_) ->
246
(match p with
247
| "length" -> ident p, Some KInt, false (* UInt in the spec *)
248
| "copy" | "insert" | "remove" | "iterator" | "toString" -> ident p , None, true
249
| _ -> as3 p, None, false);
250
| TInst ({ cl_path = [],"String" },_) ->
251
(match p with
252
| "length" (* Int in AS3/haXe *) -> ident p, None, false
253
| "charCodeAt" (* use haXe version *) -> ident p, None, true
254
| _ -> as3 p, None, false);
255
| TAnon a ->
256
(match !(a.a_status) with
257
| Statics { cl_path = [], "Math" } ->
258
(match p with
259
| "POSITIVE_INFINITY" | "NEGATIVE_INFINITY" | "NaN" -> ident p, Some KFloat, false
260
| _ -> ident p, None, false)
261
| _ -> ident p, None, false)
262
| _ ->
263
ident p, None, false
258
264
259
265
let default_infos() =
260
{ ipos = 0; istack = 0; imax = 0; iregs = 0; imaxregs = 0; iscopes = 0; imaxscopes = 0; iloop = -1 }
261
262
let alloc_reg ctx =
263
let r = ctx.infos.iregs + 1 in
264
ctx.infos.iregs <- r;
265
if ctx.infos.imaxregs < r then ctx.infos.imaxregs <- r;
266
r
266
{
267
ipos = 0;
268
istack = 0;
269
imax = 0;
270
iregs = DynArray.create();
271
iscopes = 0;
272
imaxscopes = 0;
273
iloop = -1;
274
icond = false;
275
}
276
277
let alloc_reg ctx k =
278
let regs = ctx.infos.iregs in
279
try
280
let p = DynArray.index_of (fun r -> not r.rused && k = r.rtype) regs in
281
let r = DynArray.unsafe_get regs p in
282
r.rused <- true;
283
r.rinit <- false;
284
r
285
with
286
Not_found ->
287
let r = {
288
rid = DynArray.length regs + 1;
289
rused = true;
290
rinit = false;
291
rtype = k;
292
rcond = false;
293
} in
294
DynArray.add regs r;
295
r
296
297
let coerce ctx t =
298
(* it would be useful to know if we don't already have
299
this type on the stack (as detected by the bytecode verifier)...
300
maybe this get removed at JIT, so it's only useful to reduce codesize
301
*)
302
if t <> KNone then
303
write ctx (match t with
304
| KInt -> HToInt
305
| KUInt -> HToUInt
306
| KFloat -> HToNumber
307
| KBool -> HToBool
308
| KType t -> HCast t
309
| KDynamic -> HAsAny
310
| KNone -> assert false
311
)
312
313
let set_reg ctx r =
314
if not r.rinit then begin
315
r.rinit <- true;
316
if ctx.infos.icond then r.rcond <- true;
317
end;
318
coerce ctx r.rtype;
319
write ctx (HSetReg r.rid)
267
320
268
321
let free_reg ctx r =
269
if ctx.infos.iregs <> r then assert false;
270
ctx.infos.iregs <- r - 1
322
r.rused <- false
271
323
272
324
let pop ctx n =
273
325
let rec loop n =
274
326
if n > 0 then begin
275
write ctx A3Pop;
327
write ctx HPop;
276
328
loop (n - 1)
277
329
end
278
330
in
281
333
loop n;
282
334
ctx.infos.istack <- old
283
335
284
let define_local ctx name el =
336
let define_local ctx ?(init=false) name t el =
285
337
let l = (if List.exists (Transform.local_find false name) el then begin
286
338
let pos = (try
287
fst (List.find (fun (_,x) -> name = x) ctx.block_vars)
339
let slot , _ , _ = (List.find (fun (_,x,_) -> name = x) ctx.block_vars) in
340
slot
288
341
with
289
342
Not_found ->
290
343
let n = List.length ctx.block_vars + 1 in
291
ctx.block_vars <- (n,name) :: ctx.block_vars;
344
ctx.block_vars <- (n,name,t) :: ctx.block_vars;
292
345
n
293
346
) in
294
347
LScope pos
295
348
end else
296
LReg (alloc_reg ctx)
349
let r = alloc_reg ctx (classify ctx t) in
350
if ctx.debug then write ctx (HDebugReg (name, r.rid, ctx.last_line));
351
r.rinit <- init;
352
LReg r
297
353
) in
298
354
ctx.locals <- PMap.add name l ctx.locals
299
355
301
357
302
358
let gen_local_access ctx name p (forset : 'a) : 'a access =
303
359
match (try PMap.find name ctx.locals with Not_found -> Typer.error ("Unbound variable " ^ name) p) with
304
| LReg r -> VReg r
305
| LScope n -> write ctx (A3GetScope 1); VScope n
306
| LGlobal id ->
307
if is_set forset then write ctx (A3SetInf id);
308
VGlobal (id,false)
360
| LReg r ->
361
VReg r
362
| LScope n ->
363
write ctx (HGetScope 1);
364
VScope n
365
| LGlobal p ->
366
if is_set forset then write ctx (HFindProp p);
367
VGlobal p
309
368
310
369
let rec setvar ctx (acc : write access) retval =
311
370
match acc with
312
371
| VReg r ->
313
if retval then write ctx A3Dup;
314
write ctx (A3SetReg r);
315
| VGlobal (g,_) ->
316
if retval then write ctx A3Dup;
317
write ctx (A3SetProp g);
318
| VId _ | VArray | VScope _ when retval ->
319
let r = alloc_reg ctx in
320
write ctx A3Dup;
321
write ctx (A3SetReg r);
372
if retval then write ctx HDup;
373
set_reg ctx r;
374
| VGlobal g ->
375
if retval then write ctx HDup;
376
write ctx (HSetProp g);
377
| VId _ | VCast _ | VArray | VScope _ when retval ->
378
let r = alloc_reg ctx KDynamic in
379
write ctx HDup;
380
set_reg ctx r;
322
381
setvar ctx acc false;
323
write ctx (A3Reg r);
382
write ctx (HReg r.rid);
324
383
free_reg ctx r
325
| VId id ->
326
write ctx (A3Set id)
384
| VId id | VCast (id,_) ->
385
write ctx (HInitProp id)
327
386
| VArray ->
328
let id_aset = lookup (A3TArrayAccess ctx.gpublic) ctx.types in
329
write ctx (A3Set id_aset);
387
write ctx (HSetProp dynamic_prop);
330
388
ctx.infos.istack <- ctx.infos.istack - 1
331
389
| VScope n ->
332
write ctx (A3SetSlot n)
390
write ctx (HSetSlot n)
333
391
334
392
let getvar ctx (acc : read access) =
335
393
match acc with
336
394
| VReg r ->
337
write ctx (A3Reg r)
395
if not r.rinit then begin
396
r.rinit <- true;
397
r.rcond <- true;
398
end;
399
write ctx (HReg r.rid)
338
400
| VId id ->
339
write ctx (A3Get id)
340
| VGlobal (g,flag) ->
341
write ctx (A3GetProp g);
342
if flag then write ctx A3ToObject
401
write ctx (HGetProp id)
402
| VCast (id,t) ->
403
write ctx (HGetProp id);
404
coerce ctx t
405
| VGlobal g ->
406
write ctx (HGetLex g);
343
407
| VArray ->
344
let id_aget = lookup (A3TArrayAccess ctx.gpublic) ctx.types in
345
write ctx (A3Get id_aget);
408
write ctx (HGetProp dynamic_prop);
346
409
ctx.infos.istack <- ctx.infos.istack - 1
347
410
| VScope n ->
348
write ctx (A3GetSlot n)
411
write ctx (HGetSlot n)
349
412
350
413
let open_block ctx el retval =
351
414
let old_stack = ctx.infos.istack in
352
let old_regs = ctx.infos.iregs in
415
let old_regs = DynArray.map (fun r -> r.rused) ctx.infos.iregs in
353
416
let old_locals = ctx.locals in
354
417
let old_block = ctx.curblock in
355
418
ctx.curblock <- el;
356
419
(fun() ->
357
420
if ctx.infos.istack <> old_stack + (if retval then 1 else 0) then assert false;
358
ctx.infos.iregs <- old_regs;
421
let rcount = DynArray.length old_regs + 1 in
422
DynArray.iter (fun r ->
423
if r.rid < rcount then
424
r.rused <- DynArray.unsafe_get old_regs (r.rid - 1)
425
else
426
r.rused <- false
427
) ctx.infos.iregs;
359
428
ctx.locals <- old_locals;
360
429
ctx.curblock <- old_block;
361
430
)
362
431
432
let begin_branch ctx =
433
if ctx.infos.icond then
434
(fun() -> ())
435
else begin
436
ctx.infos.icond <- true;
437
(fun() -> ctx.infos.icond <- false)
438
end
439
440
let begin_switch ctx =
441
let branch = begin_branch ctx in
442
let switch_index = DynArray.length ctx.code in
443
let switch_pos = ctx.infos.ipos in
444
write ctx (HSwitch (0,[]));
445
let constructs = ref [] in
446
let max = ref 0 in
447
let ftag tag =
448
if tag > !max then max := tag;
449
constructs := (tag,ctx.infos.ipos) :: !constructs;
450
in
451
let fend() =
452
let cases = Array.create (!max + 1) 1 in
453
List.iter (fun (tag,pos) -> Array.set cases tag (pos - switch_pos)) !constructs;
454
DynArray.set ctx.code switch_index (HSwitch (1,Array.to_list cases));
455
branch();
456
in
457
fend, ftag
458
459
363
460
let debug ctx p =
364
461
let line = Lexer.get_error_line p in
462
if ctx.last_file <> p.pfile then begin
463
write ctx (HDebugFile p.pfile);
464
ctx.last_file <- p.pfile;
465
ctx.last_line <- -1;
466
end;
365
467
if ctx.last_line <> line then begin
366
write ctx (A3DebugLine line);
468
write ctx (HDebugLine line);
367
469
ctx.last_line <- line;
368
470
end
369
471
370
let begin_fun ctx ?(varargs=false) args el stat =
472
let begin_fun ctx args tret el stat p =
371
473
let old_locals = ctx.locals in
372
474
let old_code = ctx.code in
373
475
let old_infos = ctx.infos in
382
484
ctx.block_vars <- [];
383
485
ctx.in_static <- stat;
384
486
ctx.last_line <- -1;
385
(match el with
386
| [] -> ()
387
| e :: _ ->
388
if ctx.debug then begin
389
write ctx (A3DebugFile (lookup e.epos.pfile ctx.strings));
390
debug ctx e.epos
391
end);
487
ctx.last_file <- "";
488
if ctx.debug then debug ctx p;
489
let rec find_this e =
490
match e.eexpr with
491
| TFunction _ -> ()
492
| TConst TThis | TConst TSuper -> raise Exit
493
| _ -> Transform.iter find_this e
494
in
495
let this_reg = try List.iter find_this el; false with Exit -> true in
392
496
ctx.locals <- PMap.foldi (fun name l acc ->
393
497
match l with
394
498
| LReg _ -> acc
395
| LScope _ -> PMap.add name (LGlobal (type_path ctx ~getclass:true ([],name))) acc
499
| LScope _ -> PMap.add name (LGlobal (ident name)) acc
396
500
| LGlobal _ -> PMap.add name l acc
397
501
) ctx.locals PMap.empty;
398
List.iter (fun (name,_) ->
399
define_local ctx name el;
502
List.iter (fun (name,_,t) ->
503
define_local ctx name ~init:true t el;
400
504
match gen_local_access ctx name null_pos Write with
401
505
| VReg _ -> ()
402
506
| acc ->
403
write ctx (A3Reg (alloc_reg ctx));
507
let r = alloc_reg ctx (classify ctx t) in
508
write ctx (HReg r.rid);
404
509
setvar ctx acc false
405
510
) args;
511
let args, varargs = (match args with
512
| ["__arguments__",_,_] -> [], true
513
| _ -> args, false
514
) in
406
515
let rec loop_try e =
407
516
match e.eexpr with
408
517
| TFunction _ -> ()
409
518
| TTry _ -> raise Exit
410
| _ -> Type.iter loop_try e
519
| _ -> Type.iter loop_try e
411
520
in
412
ctx.try_scope_reg <- (try List.iter loop_try el; None with Exit -> Some (alloc_reg ctx));
521
ctx.try_scope_reg <- (try List.iter loop_try el; None with Exit -> Some (alloc_reg ctx KDynamic));
413
522
(fun () ->
414
523
let hasblock = ctx.block_vars <> [] || ctx.trys <> [] in
415
524
let dparams = ref None in
416
List.iter (fun (_,opt) ->
525
List.iter (fun (_,opt,t) ->
417
526
match !dparams with
418
| None -> if opt then dparams := Some [A3VNull]
419
| Some l -> dparams := Some (A3VNull :: l)
527
| None -> if opt then dparams := Some [HVNone]
528
| Some l -> dparams := Some (HVNone :: l)
420
529
) args;
421
let mt = {
422
mt3_ret = None;
423
mt3_args = List.map (fun _ -> None) args;
424
mt3_native = false;
425
mt3_var_args = varargs;
426
mt3_debug_name = None;
427
mt3_dparams = !dparams;
428
mt3_pnames = None;
429
mt3_new_block = hasblock;
430
mt3_unk_flags = (false,false,false);
431
} in
432
530
let code = DynArray.to_list ctx.code in
433
let code , delta = (
531
let extra = (
434
532
if hasblock then begin
435
let scope, delta = (match ctx.try_scope_reg with
436
| None -> A3Scope :: code , 4
437
| Some r -> A3Dup :: A3SetReg r :: A3Scope :: code, 5 + As3code.length (A3SetReg r)
533
let scope = (match ctx.try_scope_reg with
534
| None -> [HScope]
535
| Some r -> [HDup; HSetReg r.rid; HScope]
438
536
) in
439
A3This :: A3Scope :: A3NewBlock :: scope, delta
440
end else if not stat then
441
A3This :: A3Scope :: code , 2
537
HThis :: HScope :: HNewBlock :: scope
538
end else if this_reg then
539
[HThis; HScope]
442
540
else
443
code , 0
541
[]
444
542
) in
543
(* add dummy registers initialization *)
544
let extra = extra @ List.concat (List.map (fun r ->
545
if not r.rcond then
546
[]
547
else
548
let s = [HSetReg r.rid] in
549
match r.rtype with
550
| KInt -> HSmallInt 0 :: s
551
| KUInt -> HSmallInt 0 :: HToUInt :: s
552
| KFloat -> HNaN :: s
553
| KBool -> HFalse :: s
554
| KType t -> HNull :: HAsType t :: s
555
| KDynamic -> HNull :: HAsAny :: s
556
| KNone -> HNull :: s
557
) (DynArray.to_list ctx.infos.iregs)) in
558
let delta = List.length extra in
445
559
let f = {
446
fun3_id = add mt ctx.mtypes;
447
fun3_stack_size = (if ctx.infos.imax = 0 && (hasblock || not stat) then 1 else ctx.infos.imax);
448
fun3_nregs = ctx.infos.imaxregs + 1;
449
fun3_unk3 = 1;
450
fun3_max_scope = ctx.infos.imaxscopes + 1 + (if hasblock then 2 else if not stat then 1 else 0);
451
fun3_code = code;
452
fun3_trys = Array.of_list (List.map (fun t ->
560
hlf_stack_size = (if ctx.infos.imax = 0 && (hasblock || this_reg) then 1 else ctx.infos.imax);
561
hlf_nregs = DynArray.length ctx.infos.iregs + 1;
562
hlf_init_scope = 1;
563
hlf_max_scope = ctx.infos.imaxscopes + 1 + (if hasblock then 2 else if this_reg then 1 else 0);
564
hlf_code = Array.of_list (extra @ code);
565
hlf_trys = Array.of_list (List.map (fun t ->
453
566
{
454
tc3_start = t.tr_pos + delta;
455
tc3_end = t.tr_end + delta;
456
tc3_handle = t.tr_catch_pos + delta;
457
tc3_type = (match follow t.tr_type with
458
| TInst (c,_) -> Some (fake_type_path ctx c.cl_path)
459
| TEnum (e,_) -> Some (fake_type_path ctx e.e_path)
460
| TDynamic _ -> None
461
| _ -> assert false);
462
tc3_name = None;
567
hltc_start = t.tr_pos + delta;
568
hltc_end = t.tr_end + delta;
569
hltc_handle = t.tr_catch_pos + delta;
570
hltc_type = type_opt ctx t.tr_type;
571
hltc_name = None;
463
572
}
464
573
) (List.rev ctx.trys));
465
fun3_locals = Array.of_list (List.map (fun (id,name) ->
466
{
467
f3_name = ident ctx name;
468
f3_slot = id;
469
f3_kind = A3FVar { v3_type = None; v3_value = A3VNone; v3_const = false };
470
f3_metas = None;
471
}
472
) ctx.block_vars);
473
} in
474
ignore(add f ctx.functions);
574
hlf_locals = Array.of_list (List.map (fun (id,name,t) -> ident name, type_opt ctx t, id) ctx.block_vars);
575
} in
576
let mt = {
577
hlmt_mark = As3hlparse.alloc_mark();
578
hlmt_ret = type_void ctx tret;
579
hlmt_args = List.map (fun (_,_,t) -> type_opt ctx t) args;
580
hlmt_native = false;
581
hlmt_var_args = varargs;
582
hlmt_debug_name = None;
583
hlmt_dparams = !dparams;
584
hlmt_pnames = None;
585
hlmt_new_block = hasblock;
586
hlmt_unused_flag = false;
587
hlmt_arguments_defined = false;
588
hlmt_uses_dxns = false;
589
hlmt_function = Some f;
590
} in
475
591
ctx.locals <- old_locals;
476
592
ctx.code <- old_code;
477
593
ctx.infos <- old_infos;
480
596
ctx.in_static <- old_static;
481
597
ctx.last_line <- last_line;
482
598
ctx.try_scope_reg <- old_treg;
483
f.fun3_id
599
mt
484
600
)
485
601
486
let empty_method ctx =
487
let f = begin_fun ctx [] [] true in
488
write ctx A3RetVoid;
602
let empty_method ctx p =
603
let f = begin_fun ctx [] t_void [] true p in
604
write ctx HRetVoid;
489
605
f()
490
606
491
607
let begin_loop ctx =
493
609
let old_breaks = ctx.breaks in
494
610
let old_conts = ctx.continues in
495
611
ctx.infos.iloop <- ctx.infos.istack;
612
ctx.breaks <- [];
613
ctx.continues <- [];
496
614
(fun cont_pos ->
497
615
if ctx.infos.istack <> ctx.infos.iloop then assert false;
498
616
List.iter (fun j -> j()) ctx.breaks;
502
620
ctx.continues <- old_conts;
503
621
)
504
622
505
let gen_constant ctx c =
623
let gen_constant ctx c t p =
506
624
match c with
507
625
| TInt i ->
508
626
if Int32.compare i (-128l) > 0 && Int32.compare i 128l < 0 then
509
write ctx (A3SmallInt (Int32.to_int i))
627
write ctx (HSmallInt (Int32.to_int i))
510
628
else
511
write ctx (A3IntRef (lookup i ctx.ints));
512
write ctx A3ToObject
629
write ctx (HIntRef i);
513
630
| TFloat f ->
514
631
let f = float_of_string f in
515
write ctx (A3Float (lookup f ctx.floats));
516
write ctx A3ToObject
632
write ctx (HFloat f);
517
633
| TString s ->
518
write ctx (A3String (lookup s ctx.strings));
519
write ctx A3ToObject
634
write ctx (HString s);
520
635
| TBool b ->
521
write ctx (if b then A3True else A3False);
522
write ctx A3ToObject
636
write ctx (if b then HTrue else HFalse);
523
637
| TNull ->
524
write ctx A3Null;
525
write ctx A3ToObject
638
write ctx HNull;
639
(match classify ctx t with
640
| KInt | KBool | KUInt | KFloat ->
641
Typer.error ("In Flash9, null can't be used as basic type " ^ s_type (print_context()) t) p
642
| x -> coerce ctx x)
526
643
| TThis ->
527
write ctx A3This;
528
write ctx A3ToObject
644
write ctx HThis
529
645
| TSuper ->
530
646
assert false
531
647
541
657
match e.eexpr with
542
658
| TLocal i ->
543
659
gen_local_access ctx i e.epos forset
544
| TField ({ eexpr = TLocal "__native__" },f) ->
545
let nameid = string ctx f in
546
let adobeid = string ctx "http://adobe.com/AS3/2006/builtin" in
547
let pid = lookup (A3RUnknown1 adobeid) ctx.brights in
548
let id = lookup (A3TMethodVar (nameid,pid)) ctx.types in
549
write ctx (A3GetInf id);
550
VId id
551
| TField (e,f) ->
552
let id = ident ctx f in
553
(match e.eexpr with
554
| TConst TThis when not ctx.in_static -> write ctx (A3GetInf id)
555
| _ -> gen_expr ctx true e);
556
VId id
660
| TField (e1,f) ->
661
let id, k, closure = property f e1.etype in
662
if closure && not ctx.for_call then Typer.error "In Flash9, this method cannot be accessed this way : please define a local function" e1.epos;
663
(match e1.eexpr with
664
| TConst TThis when not ctx.in_static -> write ctx (HFindPropStrict id)
665
| _ -> gen_expr ctx true e1);
666
(match k with
667
| Some t -> VCast (id,t)
668
| None ->
669
match follow e1.etype with
670
| TEnum _ -> VId id
671
| TInst (_,tl) ->
672
let et = follow e.etype in
673
(* if the return type is one of the type-parameters, then we need to cast it *)
674
if List.exists (fun t -> follow t == et) tl then
675
VCast (id, classify ctx et)
676
else
677
VId id
678
| TAnon a when (match !(a.a_status) with Statics _ | EnumStatics _ -> true | _ -> false) -> VId id
679
| _ -> VCast (id,classify ctx e.etype))
557
680
| TArray ({ eexpr = TLocal "__global__" },{ eexpr = TConst (TString s) }) ->
558
681
let path = (match List.rev (ExtString.String.nsplit s ".") with [] -> assert false | x :: l -> List.rev l, x) in
559
682
let id = type_path ctx path in
560
if is_set forset then write ctx A3GetScope0;
561
VGlobal (id,false)
683
if is_set forset then write ctx HGetGlobalScope;
684
VGlobal id
562
685
| TArray (e,eindex) ->
563
686
gen_expr ctx true e;
564
687
gen_expr ctx true eindex;
565
688
VArray
566
689
| TTypeExpr t ->
567
let id = type_path ctx ~getclass:true (t_path t) in
568
if is_set forset then write ctx A3GetScope0;
569
VGlobal (id,true)
690
let id = type_path ctx (t_path t) in
691
if is_set forset then write ctx HGetGlobalScope;
692
VGlobal id
570
693
| _ ->
571
694
error e.epos
572
695
573
696
let rec gen_expr_content ctx retval e =
574
697
match e.eexpr with
575
698
| TConst c ->
576
gen_constant ctx c
699
gen_constant ctx c e.etype e.epos
577
700
| TThrow e ->
578
701
gen_expr ctx true e;
579
write ctx A3Throw;
702
write ctx HThrow;
580
703
no_value ctx retval;
581
704
| TParenthesis e ->
582
705
gen_expr ctx retval e
583
706
| TEnumField (e,s) ->
584
write ctx A3GetScope0;
585
write ctx (A3Get (type_path ctx e.e_path));
586
write ctx (A3Get (ident ctx s));
707
let id = type_path ctx e.e_path in
708
write ctx (HGetLex id);
709
write ctx (HGetProp (ident s));
587
710
| TObjectDecl fl ->
588
711
List.iter (fun (name,e) ->
589
write ctx (A3String (lookup name ctx.strings));
712
write ctx (HString name);
590
713
gen_expr ctx true e
591
714
) fl;
592
write ctx (A3Object (List.length fl))
715
write ctx (HObject (List.length fl))
593
716
| TArrayDecl el ->
594
717
List.iter (gen_expr ctx true) el;
595
write ctx (A3Array (List.length el));
596
write ctx A3ToObject
718
write ctx (HArray (List.length el))
597
719
| TBlock el ->
598
720
let rec loop = function
599
721
| [] ->
600
if retval then write ctx A3Null
722
if retval then write ctx HNull
601
723
| [e] ->
602
724
ctx.curblock <- [];
603
725
gen_expr ctx retval e
610
732
loop el;
611
733
b();
612
734
| TVars vl ->
613
List.iter (fun (v,_,ei) ->
614
define_local ctx v ctx.curblock;
735
List.iter (fun (v,t,ei) ->
736
define_local ctx v t ctx.curblock;
615
737
(match ei with
616
738
| None -> ()
617
739
| Some e ->
618
740
let acc = gen_local_access ctx v e.epos Write in
619
gen_expr_obj ctx true e;
741
gen_expr ctx true e;
620
742
setvar ctx acc false)
621
743
) vl
622
744
| TReturn None ->
623
write ctx A3RetVoid;
745
write ctx HRetVoid;
624
746
no_value ctx retval
625
747
| TReturn (Some e) ->
626
748
gen_expr ctx true e;
627
write ctx A3Ret;
749
write ctx HRet;
628
750
no_value ctx retval
629
751
| TField _
630
752
| TLocal _
631
| TTypeExpr _
753
| TTypeExpr _ ->
754
getvar ctx (gen_access ctx e Read)
632
755
| TArray _ ->
633
getvar ctx (gen_access ctx e Read)
756
getvar ctx (gen_access ctx e Read);
757
coerce ctx (classify ctx e.etype)
634
758
| TBinop (op,e1,e2) ->
635
gen_binop ctx retval op e1 e2
759
gen_binop ctx retval op e1 e2 e.etype
636
760
| TCall (e,el) ->
637
gen_call ctx e el
761
gen_call ctx retval e el
762
| TNew ({ cl_path = [],"Array" },_,[]) ->
763
(* it seems that [] is 4 time faster than new Array() *)
764
write ctx (HArray 0)
638
765
| TNew (c,_,pl) ->
639
766
let id = type_path ctx c.cl_path in
640
write ctx (A3GetInf id);
767
write ctx (HFindPropStrict id);
641
768
List.iter (gen_expr ctx true) pl;
642
write ctx (A3New (id,List.length pl));
643
write ctx A3ToObject
769
write ctx (HConstructProperty (id,List.length pl))
644
770
| TFunction f ->
645
write ctx (A3Function (generate_function ctx f true))
646
| TIf (e,e1,e2) ->
647
gen_expr ctx true e;
648
let j = jump ctx J3False in
649
gen_expr_obj ctx retval e1;
771
write ctx (HFunction (generate_function ctx f true))
772
| TIf (e0,e1,e2) ->
773
let j = jump_expr ctx e0 false in
774
let branch = begin_branch ctx in
775
gen_expr ctx retval e1;
776
let t = classify ctx e.etype in
777
if retval && classify ctx e1.etype <> t then coerce ctx t;
650
778
(match e2 with
651
779
| None -> j()
652
780
| Some e ->
654
782
if retval then ctx.infos.istack <- ctx.infos.istack - 1;
655
783
let jend = jump ctx J3Always in
656
784
j();
657
gen_expr_obj ctx retval e;
658
jend())
785
gen_expr ctx retval e;
786
if retval && classify ctx e.etype <> t then coerce ctx t;
787
jend());
788
branch();
659
789
| TWhile (econd,e,flag) ->
660
let jstart = (match flag with NormalWhile -> (fun()->()) | DoWhile -> jump ctx J3Always) in
790
let jstart = jump ctx J3Always in
661
791
let end_loop = begin_loop ctx in
662
let continue_pos = ctx.infos.ipos + jsize in
663
let here, loop = jump_back ctx in
664
here();
665
gen_expr ctx true econd;
666
let jend = jump ctx J3False in
667
jstart();
792
let branch = begin_branch ctx in
793
let loop = jump_back ctx in
794
if flag = DoWhile then jstart();
668
795
gen_expr ctx false e;
669
loop J3Always;
670
jend();
796
if flag = NormalWhile then jstart();
797
let continue_pos = ctx.infos.ipos in
798
let _ = jump_expr_gen ctx econd true (fun j -> loop j; (fun() -> ())) in
799
branch();
671
800
end_loop continue_pos;
672
if retval then write ctx A3Null
801
if retval then write ctx HNull
673
802
| TUnop (op,flag,e) ->
674
803
gen_unop ctx retval op flag e
675
804
| TTry (e2,cases) ->
676
805
if ctx.infos.istack <> 0 then Typer.error "Cannot compile try/catch as a right-side expression in Flash9" e.epos;
806
let branch = begin_branch ctx in
677
807
let p = ctx.infos.ipos in
678
gen_expr_obj ctx retval e2;
808
gen_expr ctx retval e2;
679
809
let pend = ctx.infos.ipos in
680
810
let jend = jump ctx J3Always in
681
811
let rec loop ncases = function
690
820
} :: ctx.trys;
691
821
ctx.infos.istack <- ctx.infos.istack + 1;
692
822
if ctx.infos.imax < ctx.infos.istack then ctx.infos.imax <- ctx.infos.istack;
693
write ctx A3This;
694
write ctx A3Scope;
695
write ctx (A3Reg (match ctx.try_scope_reg with None -> assert false | Some r -> r));
696
write ctx A3Scope;
697
(match follow t with TDynamic _ -> () | _ -> write ctx A3ToObject);
698
define_local ctx ename [e];
699
let isreg , r = (try match PMap.find ename ctx.locals with LReg _ -> true, alloc_reg ctx | _ -> false, 0 with Not_found -> assert false) in
700
if not isreg then write ctx (A3SetReg r);
823
write ctx HThis;
824
write ctx HScope;
825
write ctx (HReg (match ctx.try_scope_reg with None -> assert false | Some r -> r.rid));
826
write ctx HScope;
827
define_local ctx ename t [e];
828
let r = (try match PMap.find ename ctx.locals with LReg r -> Some (alloc_reg ctx r.rtype) | _ -> None with Not_found -> assert false) in
829
(match r with None -> () | Some r -> set_reg ctx r);
701
830
let acc = gen_local_access ctx ename e.epos Write in
702
if not isreg then write ctx (A3Reg r);
831
(match r with None -> () | Some r -> write ctx (HReg r.rid));
703
832
setvar ctx acc false;
704
gen_expr_obj ctx retval e;
833
gen_expr ctx retval e;
705
834
b();
706
835
if retval then ctx.infos.istack <- ctx.infos.istack - 1;
707
836
match l with
712
841
in
713
842
let loops = loop (List.length ctx.trys) cases in
714
843
List.iter (fun j -> j()) loops;
844
branch();
715
845
jend()
716
| TFor (v,it,e) ->
846
| TFor (v,t,it,e) ->
717
847
gen_expr ctx true it;
718
let r = alloc_reg ctx in
719
write ctx (A3SetReg r);
848
let r = alloc_reg ctx KDynamic in
849
set_reg ctx r;
850
let branch = begin_branch ctx in
720
851
let b = open_block ctx [e] retval in
721
define_local ctx v [e];
852
define_local ctx v t [e];
722
853
let end_loop = begin_loop ctx in
723
let continue_pos = ctx.infos.ipos + jsize in
724
let here, start = jump_back ctx in
725
here();
726
write ctx (A3Reg r);
727
write ctx (A3Call (ident ctx "hasNext",0));
854
let continue_pos = ctx.infos.ipos in
855
let start = jump_back ctx in
856
write ctx (HReg r.rid);
857
write ctx (HCallProperty (ident "hasNext",0));
728
858
let jend = jump ctx J3False in
729
859
let acc = gen_local_access ctx v e.epos Write in
730
write ctx (A3Reg r);
731
write ctx (A3Call (ident ctx "next",0));
860
write ctx (HReg r.rid);
861
write ctx (HCallProperty (ident "next",0));
732
862
setvar ctx acc false;
733
863
gen_expr ctx false e;
734
735
864
start J3Always;
736
865
end_loop continue_pos;
737
866
jend();
738
867
if retval then getvar ctx (gen_local_access ctx v e.epos Read);
739
868
b();
869
branch();
740
870
free_reg ctx r;
741
871
| TBreak ->
742
872
pop ctx (ctx.infos.istack - ctx.infos.iloop);
745
875
| TContinue ->
746
876
pop ctx (ctx.infos.istack - ctx.infos.iloop);
747
877
let op = DynArray.length ctx.code in
748
write ctx (A3Jump (J3Always,-4));
749
878
let p = ctx.infos.ipos in
750
ctx.continues <- (fun target -> DynArray.set ctx.code op (A3Jump (J3Always,target - p))) :: ctx.continues;
879
write ctx (HJump (J3Always,0));
880
ctx.continues <- (fun target -> DynArray.set ctx.code op (HJump (J3Always,target - p))) :: ctx.continues;
751
881
no_value ctx retval
752
| TSwitch (e,el,eo) ->
753
let r = alloc_reg ctx in
754
gen_expr ctx true e;
755
write ctx (A3SetReg r);
882
| TSwitch (e0,el,eo) ->
883
let t = classify ctx e.etype in
884
(try
885
(* generate optimized int switch *)
886
if t <> KInt && t <> KUInt then raise Exit;
887
let rec get_int e =
888
match e.eexpr with
889
| TConst (TInt n) -> Int32.to_int n
890
| TParenthesis e | TBlock [e] -> get_int e
891
| _ -> raise Not_found
892
in
893
List.iter (fun (vl,_) -> List.iter (fun v ->
894
let n = (try get_int v with _ -> raise Exit) in
895
if n < 0 || n > 512 then raise Exit;
896
) vl) el;
897
gen_expr ctx true e0;
898
let switch, case = begin_switch ctx in
899
(match eo with
900
| None ->
901
if retval then begin
902
write ctx HNull;
903
coerce ctx t;
904
end;
905
| Some e ->
906
gen_expr ctx retval e;
907
if retval && classify ctx e.etype <> t then coerce ctx t);
908
let jends = List.map (fun (vl,e) ->
909
let j = jump ctx J3Always in
910
List.iter (fun v -> case (get_int v)) vl;
911
gen_expr ctx retval e;
912
if retval then begin
913
ctx.infos.istack <- ctx.infos.istack - 1;
914
if classify ctx e.etype <> t then coerce ctx t;
915
end;
916
j
917
) el in
918
List.iter (fun j -> j()) jends;
919
switch();
920
with Exit ->
921
let r = alloc_reg ctx (classify ctx e0.etype) in
922
gen_expr ctx true e0;
923
set_reg ctx r;
924
let branch = begin_branch ctx in
756
925
let prev = ref (fun () -> ()) in
757
let jend = List.map (fun (v,e) ->
926
let jend = List.map (fun (vl,e) ->
758
927
(!prev)();
759
write ctx (A3Reg r);
760
gen_expr ctx true v;
761
prev := jump ctx J3Neq;
762
gen_expr_obj ctx retval e;
763
if retval then ctx.infos.istack <- ctx.infos.istack - 1;
928
let rec loop = function
929
| [] ->
930
assert false
931
| [v] ->
932
write ctx (HReg r.rid);
933
gen_expr ctx true v;
934
prev := jump ctx J3Neq;
935
| v :: l ->
936
write ctx (HReg r.rid);
937
gen_expr ctx true v;
938
let j = jump ctx J3Eq in
939
loop l;
940
j()
941
in
942
loop vl;
943
gen_expr ctx retval e;
944
if retval then begin
945
if classify ctx e.etype <> t then coerce ctx t;
946
ctx.infos.istack <- ctx.infos.istack - 1;
947
end;
764
948
jump ctx J3Always
765
949
) el in
766
950
(!prev)();
767
951
free_reg ctx r;
768
952
(match eo with
769
| None -> if retval then begin write ctx A3Null; write ctx A3ToObject; end
770
| Some e -> gen_expr_obj ctx retval e);
953
| None ->
954
if retval then begin
955
write ctx HNull;
956
coerce ctx t;
957
end;
958
| Some e ->
959
gen_expr ctx retval e;
960
if retval && classify ctx e.etype <> t then coerce ctx t;
961
);
771
962
List.iter (fun j -> j()) jend;
772
| TMatch (e,_,cases,def) ->
773
let rparams = alloc_reg ctx in
774
let rtag = alloc_reg ctx in
775
gen_expr ctx true e;
776
write ctx A3Dup;
777
write ctx (A3Get (ident ctx "tag"));
778
write ctx (A3SetReg rtag);
779
write ctx (A3Get (ident ctx "params"));
780
write ctx (A3SetReg rparams);
781
let prev = ref (fun () -> ()) in
782
let jend = List.map (fun (tag,params,e) ->
783
(!prev)();
784
write ctx (A3Reg rtag);
785
write ctx (A3String (lookup tag ctx.strings));
786
prev := jump ctx J3Neq;
963
branch());
964
| TMatch (e0,_,cases,def) ->
965
let t = classify ctx e.etype in
966
let rparams = alloc_reg ctx (KType (type_path ctx ([],"Array"))) in
967
let has_params = List.exists (fun (_,p,_) -> p <> None) cases in
968
gen_expr ctx true e0;
969
if has_params then begin
970
write ctx HDup;
971
write ctx (HGetProp (ident "params"));
972
set_reg ctx rparams;
973
end;
974
write ctx (HGetProp (ident "index"));
975
write ctx HToInt;
976
let switch,case = begin_switch ctx in
977
(match def with
978
| None ->
979
if retval then begin
980
write ctx HNull;
981
coerce ctx t;
982
end;
983
| Some e ->
984
gen_expr ctx retval e;
985
if retval && classify ctx e.etype <> t then coerce ctx t);
986
let jends = List.map (fun (cl,params,e) ->
987
let j = jump ctx J3Always in
988
List.iter case cl;
787
989
let b = open_block ctx [e] retval in
788
990
(match params with
789
991
| None -> ()
790
992
| Some l ->
791
993
let p = ref (-1) in
792
List.iter (fun (name,_) ->
994
List.iter (fun (name,t) ->
793
995
incr p;
794
996
match name with
795
997
| None -> ()
796
998
| Some v ->
797
define_local ctx v [e];
999
define_local ctx v t [e];
798
1000
let acc = gen_local_access ctx v e.epos Write in
799
write ctx (A3Reg rparams);
800
write ctx (A3SmallInt !p);
1001
write ctx (HReg rparams.rid);
1002
write ctx (HSmallInt !p);
801
1003
getvar ctx VArray;
802
1004
setvar ctx acc false
803
1005
) l
804
1006
);
805
gen_expr_obj ctx retval e;
1007
gen_expr ctx retval e;
806
1008
b();
807
if retval then ctx.infos.istack <- ctx.infos.istack - 1;
808
jump ctx J3Always;
1009
if retval then begin
1010
ctx.infos.istack <- ctx.infos.istack - 1;
1011
if classify ctx e.etype <> t then coerce ctx t;
1012
end;
1013
j
809
1014
) cases in
810
(!prev)();
811
(match def with
812
| None -> if retval then begin write ctx A3Null; write ctx A3ToObject; end
813
| Some e -> gen_expr_obj ctx retval e);
814
List.iter (fun j -> j()) jend;
815
free_reg ctx rtag;
1015
switch();
1016
List.iter (fun j -> j()) jends;
816
1017
free_reg ctx rparams
817
1018
818
and gen_call ctx e el =
1019
and gen_call ctx retval e el =
819
1020
match e.eexpr , el with
820
1021
| TLocal "__is__" , [e;t] ->
821
1022
gen_expr ctx true e;
822
1023
gen_expr ctx true t;
823
write ctx (A3Op A3OIs)
824
| TLocal "__keys__" , [e] ->
825
let racc = alloc_reg ctx in
826
let rcounter = alloc_reg ctx in
827
let rtmp = alloc_reg ctx in
828
write ctx (A3SmallInt 0);
829
write ctx (A3SetReg rcounter);
830
write ctx (A3Array 0);
831
write ctx (A3SetReg racc);
832
gen_expr ctx true e;
833
write ctx (A3SetReg rtmp);
834
let start, loop = jump_back ctx in
835
write ctx (A3Reg racc);
836
write ctx (A3Reg rtmp);
837
write ctx (A3Reg rcounter);
838
write ctx A3ForIn;
839
write ctx (A3Call (ident ctx "push",1));
840
write ctx A3Pop;
1024
write ctx (HOp A3OIs)
1025
| TLocal "__as__" , [e;t] ->
1026
gen_expr ctx true e;
1027
gen_expr ctx true t;
1028
write ctx (HOp A3OAs)
1029
| TLocal "__int__", [e] ->
1030
gen_expr ctx true e;
1031
write ctx HToInt
1032
| TLocal "__float__", [e] ->
1033
gen_expr ctx true e;
1034
write ctx HToNumber
1035
| TLocal "__hkeys__" , [e2]
1036
| TLocal "__keys__" , [e2] ->
1037
let racc = alloc_reg ctx (KType (type_path ctx ([],"Array"))) in
1038
let rcounter = alloc_reg ctx KInt in
1039
let rtmp = alloc_reg ctx KDynamic in
1040
write ctx (HSmallInt 0);
1041
set_reg ctx rcounter;
1042
write ctx (HArray 0);
1043
set_reg ctx racc;
1044
gen_expr ctx true e2;
1045
set_reg ctx rtmp;
1046
let start = jump ctx J3Always in
1047
let loop = jump_back ctx in
1048
write ctx (HReg racc.rid);
1049
write ctx (HReg rtmp.rid);
1050
write ctx (HReg rcounter.rid);
1051
write ctx HForIn;
1052
if e.eexpr = TLocal "__hkeys__" then begin
1053
write ctx (HSmallInt 1);
1054
write ctx (HCallProperty (as3 "substr",1));
1055
end;
1056
write ctx (HCallPropVoid (as3 "push",1));
841
1057
start();
842
write ctx (A3Next (rtmp,rcounter));
1058
write ctx (HNext (rtmp.rid,rcounter.rid));
843
1059
loop J3True;
844
write ctx (A3Reg racc);
1060
write ctx (HReg racc.rid);
845
1061
free_reg ctx rtmp;
846
1062
free_reg ctx rcounter;
847
1063
free_reg ctx racc;
848
1064
| TLocal "__new__" , e :: el ->
849
1065
gen_expr ctx true e;
850
1066
List.iter (gen_expr ctx true) el;
851
write ctx (A3StackNew (List.length el))
1067
write ctx (HConstruct (List.length el))
852
1068
| TLocal "__delete__" , [o;f] ->
853
1069
gen_expr ctx true o;
854
1070
gen_expr ctx true f;
855
write ctx (A3Delete (lookup (A3TArrayAccess ctx.gpublic) ctx.types))
1071
write ctx (HDeleteProp dynamic_prop);
856
1072
| TLocal "__unprotect__" , [e] ->
857
1073
gen_expr ctx true e
858
1074
| TLocal "__typeof__", [e] ->
859
1075
gen_expr ctx true e;
860
write ctx A3Typeof
1076
write ctx HTypeof
861
1077
| TLocal "__in__", [e; f] ->
862
1078
gen_expr ctx true e;
863
1079
gen_expr ctx true f;
864
write ctx (A3Op A3OIn)
1080
write ctx (HOp A3OIn)
1081
| TArray ({ eexpr = TLocal "__global__" },{ eexpr = TConst (TString s) }), _ ->
1082
(match gen_access ctx e Read with
1083
| VGlobal id ->
1084
write ctx (HFindPropStrict id);
1085
List.iter (gen_expr ctx true) el;
1086
write ctx (HCallProperty (id,List.length el));
1087
| _ -> assert false)
865
1088
| TConst TSuper , _ ->
866
write ctx A3This;
1089
write ctx HThis;
867
1090
List.iter (gen_expr ctx true) el;
868
write ctx (A3SuperConstr (List.length el));
1091
write ctx (HConstructSuper (List.length el));
869
1092
| TField ({ eexpr = TConst TSuper },f) , _ ->
870
let id = ident ctx f in
871
write ctx (A3GetInf id);
1093
let id = ident f in
1094
write ctx (HFindPropStrict id);
872
1095
List.iter (gen_expr ctx true) el;
873
write ctx (A3SuperCall (id,List.length el));
1096
write ctx (HCallSuper (id,List.length el));
874
1097
| TField ({ eexpr = TConst TThis },f) , _ when not ctx.in_static ->
875
let id = ident ctx f in
876
write ctx (A3GetInf id);
877
List.iter (gen_expr ctx true) el;
878
write ctx (A3Call (id,List.length el));
879
| TField (e,f) , _ ->
880
gen_expr ctx true e;
881
List.iter (gen_expr ctx true) el;
882
write ctx (A3Call (ident ctx f,List.length el));
1098
let id = ident f in
1099
write ctx (HFindPropStrict id);
1100
List.iter (gen_expr ctx true) el;
1101
write ctx (if retval then HCallProperty (id,List.length el) else HCallPropVoid (id,List.length el));
1102
| TField (e1,f) , _ ->
1103
let old = ctx.for_call in
1104
ctx.for_call <- true;
1105
gen_expr ctx true e1;
1106
ctx.for_call <- old;
1107
List.iter (gen_expr ctx true) el;
1108
let id , _, _ = property f e1.etype in
1109
if not retval then
1110
write ctx (HCallPropVoid (id,List.length el))
1111
else
1112
let coerce() =
1113
match follow e.etype with
1114
| TFun (_,r) -> coerce ctx (classify ctx r)
1115
| _ -> ()
1116
in
1117
write ctx (HCallProperty (id,List.length el));
1118
(match follow e1.etype with
1119
| TInst ({ cl_path = [],"Array" },_) ->
1120
(match f with
1121
| "copy" | "remove" -> coerce()
1122
| _ -> ())
1123
| TInst ({ cl_path = [],"Date" },_) ->
1124
coerce() (* all date methods are typed as Number in AS3 and Int in haXe *)
1125
| TAnon a ->
1126
(match !(a.a_status) with
1127
| Statics { cl_path = ([],"Date") } ->
1128
(match f with
1129
| "now" | "fromString" | "fromTime" -> coerce()
1130
| _ -> ())
1131
| Statics { cl_path = ([],"Math") } ->
1132
(match f with
1133
| "isFinite" | "isNaN" -> coerce()
1134
| "floor" | "ceil" | "round" -> coerce() (* AS3 state Number, while Int in haXe *)
1135
| _ -> ())
1136
| _ -> ())
1137
| _ -> ())
1138
| TEnumField (e,f) , _ ->
1139
let id = type_path ctx e.e_path in
1140
write ctx (HGetLex id);
1141
List.iter (gen_expr ctx true) el;
1142
write ctx (HCallProperty (ident f,List.length el));
883
1143
| _ ->
884
1144
gen_expr ctx true e;
885
write ctx A3GetScope0;
1145
write ctx HGetGlobalScope;
886
1146
List.iter (gen_expr ctx true) el;
887
write ctx (A3StackCall (List.length el))
1147
write ctx (HCallStack (List.length el))
888
1148
889
1149
and gen_unop ctx retval op flag e =
1150
let k = classify ctx e.etype in
890
1151
match op with
891
1152
| Not ->
892
1153
gen_expr ctx true e;
893
write ctx (A3Op A3ONot);
1154
write ctx (HOp A3ONot);
894
1155
| Neg ->
895
1156
gen_expr ctx true e;
896
write ctx (A3Op A3ONeg);
1157
write ctx (HOp (if k = KInt then A3OINeg else A3ONeg));
897
1158
| NegBits ->
898
1159
gen_expr ctx true e;
899
write ctx (A3Op A3OBitNot);
1160
write ctx (HOp A3OBitNot);
900
1161
| Increment
901
1162
| Decrement ->
902
1163
let incr = (op = Increment) in
903
1164
let acc = gen_access ctx e Write in (* for set *)
1165
match acc with
1166
| VReg r when r.rtype = KInt ->
1167
if not r.rinit then r.rcond <- true;
1168
if retval && flag = Postfix then getvar ctx (gen_access ctx e Read);
1169
write ctx (if incr then HIncrIReg r.rid else HDecrIReg r.rid);
1170
if retval && flag = Prefix then getvar ctx (gen_access ctx e Read);
1171
| _ ->
904
1172
getvar ctx (gen_access ctx e Read);
905
1173
match flag with
906
1174
| Postfix when retval ->
907
let r = alloc_reg ctx in
908
write ctx A3Dup;
909
write ctx (A3SetReg r);
910
write ctx (A3Op (if incr then A3OIncr else A3ODecr));
911
write ctx A3ToObject;
1175
let r = alloc_reg ctx k in
1176
write ctx HDup;
1177
set_reg ctx r;
1178
write ctx (HOp (if incr then A3OIncr else A3ODecr));
912
1179
setvar ctx acc false;
913
write ctx (A3Reg r);
1180
write ctx (HReg r.rid);
914
1181
free_reg ctx r
915
1182
| Postfix | Prefix ->
916
write ctx (A3Op (if incr then A3OIncr else A3ODecr));
917
write ctx A3ToObject;
1183
write ctx (HOp (if incr then A3OIncr else A3ODecr));
918
1184
setvar ctx acc retval
919
1185
920
and gen_binop ctx retval op e1 e2 =
921
let gen_op o =
1186
and gen_binop ctx retval op e1 e2 t =
1187
let gen_op ?iop o =
922
1188
gen_expr ctx true e1;
923
1189
gen_expr ctx true e2;
924
write ctx (A3Op o)
1190
match iop with
1191
| Some iop ->
1192
let k1 = classify ctx e1.etype in
1193
let k2 = classify ctx e2.etype in
1194
if k1 = KInt && k2 = KInt then
1195
write ctx (HOp iop)
1196
else begin
1197
write ctx (HOp o);
1198
if o = A3OAdd then coerce ctx (classify ctx t);
1199
end;
1200
| _ ->
1201
write ctx (HOp o)
925
1202
in
926
1203
match op with
927
1204
| OpAssign ->
928
1205
let acc = gen_access ctx e1 Write in
929
gen_expr_obj ctx true e2;
1206
gen_expr ctx true e2;
930
1207
setvar ctx acc retval
931
1208
| OpBoolAnd ->
932
gen_expr_obj ctx true e1;
933
write ctx A3Dup;
934
let j = jump ctx J3False in
935
write ctx A3Pop;
936
gen_expr_obj ctx true e2;
1209
write ctx HFalse;
1210
let j = jump_expr ctx e1 false in
1211
let b = begin_branch ctx in
1212
write ctx HPop;
1213
gen_expr ctx true e2;
1214
coerce ctx KBool;
937
1215
j();
1216
b();
938
1217
| OpBoolOr ->
939
gen_expr_obj ctx true e1;
940
write ctx A3Dup;
941
let j = jump ctx J3True in
942
write ctx A3Pop;
943
gen_expr_obj ctx true e2;
1218
write ctx HTrue;
1219
let j = jump_expr ctx e1 true in
1220
let b = begin_branch ctx in
1221
write ctx HPop;
1222
gen_expr ctx true e2;
1223
coerce ctx KBool;
944
1224
j();
1225
b();
945
1226
| OpAssignOp op ->
946
1227
let acc = gen_access ctx e1 Write in
947
gen_binop ctx true op e1 e2;
948
(match DynArray.last ctx.code with A3ToObject -> () | _ -> write ctx A3ToObject);
1228
gen_binop ctx true op e1 e2 t;
949
1229
setvar ctx acc retval
950
1230
| OpAdd ->
951
gen_op A3OAdd
1231
gen_op ~iop:A3OIAdd A3OAdd
952
1232
| OpMult ->
953
gen_op A3OMul
1233
gen_op ~iop:A3OIMul A3OMul
954
1234
| OpDiv ->
955
1235
gen_op A3ODiv
956
1236
| OpSub ->
957
gen_op A3OSub
1237
gen_op ~iop:A3OISub A3OSub
958
1238
| OpEq ->
959
1239
gen_op A3OEq
960
1240
| OpPhysEq ->
961
1241
gen_op A3OPhysEq
962
1242
| OpNotEq ->
963
1243
gen_op A3OEq;
964
write ctx (A3Op A3ONot)
1244
write ctx (HOp A3ONot)
965
1245
| OpPhysNotEq ->
966
1246
gen_op A3OPhysEq;
967
write ctx (A3Op A3ONot)
1247
write ctx (HOp A3ONot)
968
1248
| OpGt ->
969
1249
gen_op A3OGt
970
1250
| OpGte ->
986
1266
| OpUShr ->
987
1267
gen_op A3OUShr
988
1268
| OpMod ->
989
gen_op A3OMod
1269
gen_op A3OMod;
1270
if classify ctx e1.etype = KInt && classify ctx e2.etype = KInt then coerce ctx (classify ctx t);
990
1271
| OpInterval ->
991
1272
assert false
992
1273
993
and gen_expr_obj ctx retval e =
994
gen_expr ctx retval e;
995
if retval then match DynArray.last ctx.code with A3ToObject -> () | _ -> write ctx A3ToObject
996
997
1274
and gen_expr ctx retval e =
998
1275
let old = ctx.infos.istack in
999
1276
if ctx.debug then debug ctx e.epos;
1000
1277
gen_expr_content ctx retval e;
1001
1278
if old <> ctx.infos.istack then begin
1002
1279
if old + 1 <> ctx.infos.istack then stack_error e.epos;
1003
if not retval then write ctx A3Pop;
1280
if not retval then write ctx HPop;
1004
1281
end else if retval then stack_error e.epos
1005
1282
1006
1283
and generate_function ctx fdata stat =
1007
let f = begin_fun ctx (List.map (fun (name,opt,_) -> name,opt) fdata.tf_args) [fdata.tf_expr] stat in
1284
let f = begin_fun ctx fdata.tf_args fdata.tf_type [fdata.tf_expr] stat fdata.tf_expr.epos in
1008
1285
gen_expr ctx false fdata.tf_expr;
1009
write ctx A3RetVoid;
1286
(match follow fdata.tf_type with
1287
| TEnum ({ e_path = [],"Void" },[]) -> write ctx HRetVoid
1288
| _ ->
1289
(* check that we have a return that can be accepted by Flash9 VM *)
1290
let rec loop e =
1291
match e.eexpr with
1292
| TBlock [] -> false
1293
| TBlock l -> loop (List.hd (List.rev l))
1294
| TReturn None -> true
1295
| TReturn (Some e) ->
1296
let rec inner_loop e =
1297
match e.eexpr with
1298
| TSwitch _ | TMatch _ | TFor _ | TWhile _ | TTry _ -> false
1299
| TIf _ -> loop e
1300
| TParenthesis e -> inner_loop e
1301
| _ -> true
1302
in
1303
inner_loop e
1304
| TIf (_,e1,Some e2) -> loop e1 && loop e2
1305
| TSwitch (_,_,Some e) -> loop e
1306
| TParenthesis e -> loop e
1307
| _ -> false
1308
in
1309
if not (loop fdata.tf_expr) then write ctx HRetVoid;
1310
);
1010
1311
f()
1011
1312
1012
let generate_construct ctx fdata cfields =
1013
let args = List.map (fun (name,opt,_) -> name,opt) fdata.tf_args in
1014
let args = (match args with [] -> ["__p",true] | _ -> args) in
1015
let f = begin_fun ctx args [fdata.tf_expr] false in
1016
write ctx (A3Reg 1);
1017
write ctx (A3String (string ctx construct_string));
1018
let j = jump ctx J3PhysNeq in
1019
write ctx A3RetVoid;
1020
j();
1313
and jump_expr_gen ctx e jif jfun =
1314
match e.eexpr with
1315
| TParenthesis e -> jump_expr_gen ctx e jif jfun
1316
| TBinop (op,e1,e2) ->
1317
let j t f =
1318
gen_expr ctx true e1;
1319
gen_expr ctx true e2;
1320
jfun (if jif then t else f)
1321
in
1322
(match op with
1323
| OpEq -> j J3Eq J3Neq
1324
| OpNotEq -> j J3Neq J3Eq
1325
| OpPhysEq -> j J3PhysEq J3PhysNeq
1326
| OpPhysNotEq -> j J3PhysNeq J3PhysEq
1327
| OpGt -> j J3Gt J3NotGt
1328
| OpGte -> j J3Gte J3NotGte
1329
| OpLt -> j J3Lt J3NotLt
1330
| OpLte -> j J3Lte J3NotLte
1331
| _ ->
1332
gen_expr ctx true e;
1333
jfun (if jif then J3True else J3False))
1334
| _ ->
1335
gen_expr ctx true e;
1336
jfun (if jif then J3True else J3False)
1337
1338
and jump_expr ctx e jif =
1339
jump_expr_gen ctx e jif (jump ctx)
1340
1341
let generate_method ctx fdata stat =
1342
generate_function ctx { fdata with tf_expr = Transform.block_vars fdata.tf_expr } stat
1343
1344
let generate_construct ctx fdata c =
1345
(* make all args optional to allow no-param constructor *)
1346
let f = begin_fun ctx (List.map (fun (a,o,t) -> a,true,t) fdata.tf_args) fdata.tf_type [ethis;fdata.tf_expr] false fdata.tf_expr.epos in
1347
(* if skip_constructor, then returns immediatly *)
1348
(match c.cl_kind with
1349
| KGenericInstance _ -> ()
1350
| _ ->
1351
let id = ident "skip_constructor" in
1352
getvar ctx (VGlobal (type_path ctx ([],ctx.boot)));
1353
getvar ctx (VId id);
1354
let j = jump ctx J3False in
1355
write ctx HRetVoid;
1356
j());
1357
(* --- *)
1021
1358
PMap.iter (fun _ f ->
1022
1359
match f.cf_expr with
1023
1360
| Some { eexpr = TFunction fdata } when f.cf_set = NormalAccess ->
1024
let id = ident ctx f.cf_name in
1025
write ctx (A3SetInf id);
1026
write ctx (A3Function (generate_function ctx fdata false));
1027
write ctx (A3Set id);
1361
let id = ident f.cf_name in
1362
write ctx (HFindProp id);
1363
write ctx (HFunction (generate_method ctx fdata false));
1364
write ctx (HInitProp id);
1028
1365
| _ -> ()
1029
) cfields;
1030
gen_expr ctx false fdata.tf_expr;
1031
write ctx A3RetVoid;
1032
f() , List.length args
1033
1034
let generate_reflect_construct ctx cid nargs =
1035
(* generate
1036
function __construct__(args) {
1037
return if( args == null )
1038
new Class("__skip__constructor__",null,null,....);
1039
else
1040
new Class(args[0],args[1],....);
1041
}
1042
*)
1043
let f = begin_fun ctx ["args",false] [] true in
1044
write ctx (A3GetInf cid);
1045
write ctx (A3Reg 1);
1046
write ctx A3Null;
1047
write ctx A3ToObject;
1048
let j = jump ctx J3PhysNeq in
1049
write ctx (A3String (string ctx construct_string));
1050
write ctx A3ToObject;
1051
for i = 2 to nargs do
1052
write ctx A3Null;
1053
write ctx A3ToObject;
1054
done;
1055
let jend = jump ctx J3Always in
1056
j();
1057
for i = 1 to nargs do
1058
write ctx (A3Reg 0);
1059
write ctx (A3SmallInt i);
1060
getvar ctx VArray;
1061
done;
1062
jend();
1063
write ctx (A3New (cid,nargs));
1064
write ctx A3Ret;
1065
{
1066
f3_name = ident ctx "__construct__";
1067
f3_slot = 1;
1068
f3_kind = A3FMethod {
1069
m3_type = f();
1070
m3_final = false;
1071
m3_override = false;
1072
m3_kind = MK3Normal;
1073
};
1074
f3_metas = None;
1075
}
1076
1077
let generate_class_init ctx c slot =
1078
write ctx A3GetScope0;
1366
) c.cl_fields;
1367
gen_expr ctx false (Transform.block_vars fdata.tf_expr);
1368
write ctx HRetVoid;
1369
f() , List.length fdata.tf_args
1370
1371
let generate_class_init ctx c hc =
1372
write ctx HGetGlobalScope;
1079
1373
if c.cl_interface then
1080
write ctx A3Null
1374
write ctx HNull
1081
1375
else begin
1082
1376
let path = (match c.cl_super with None -> ([],"Object") | Some (sup,_) -> sup.cl_path) in
1083
write ctx (A3GetProp (type_path ctx path));
1084
write ctx A3Scope;
1085
write ctx (A3GetProp (type_path ctx ~getclass:true path));
1377
write ctx (HGetLex (type_path ctx path));
1378
write ctx HScope;
1379
write ctx (HGetLex (type_path ctx path));
1086
1380
end;
1087
write ctx (A3ClassDef slot);
1381
write ctx (HClassDef hc);
1088
1382
List.iter (fun f ->
1089
1383
match f.cf_expr with
1090
1384
| Some { eexpr = TFunction fdata } when f.cf_set = NormalAccess ->
1091
write ctx A3Dup;
1092
write ctx (A3Function (generate_function ctx fdata true));
1093
write ctx (A3Set (ident ctx f.cf_name));
1385
write ctx HDup;
1386
write ctx (HFunction (generate_method ctx fdata true));
1387
write ctx (HInitProp (ident f.cf_name));
1094
1388
| _ -> ()
1095
1389
) c.cl_ordered_statics;
1096
if not c.cl_interface then write ctx A3PopScope;
1097
write ctx (A3Set (type_path ctx c.cl_path))
1390
if not c.cl_interface then write ctx HPopScope;
1391
write ctx (HInitProp (type_path ctx c.cl_path))
1098
1392
1099
1393
let generate_class_statics ctx c =
1100
let r = alloc_reg ctx in
1394
let r = alloc_reg ctx KDynamic in
1101
1395
let first = ref true in
1102
let nslot = ref 1 in
1396
let nslot = ref 0 in
1103
1397
List.iter (fun f ->
1104
incr nslot;
1105
1398
match f.cf_expr with
1106
| Some { eexpr = TFunction _ } | None -> ()
1399
| Some { eexpr = TFunction _ } when f.cf_set <> NormalAccess -> ()
1107
1400
| Some e ->
1401
incr nslot;
1108
1402
if !first then begin
1109
write ctx A3GetScope0;
1110
write ctx (A3Get (type_path ctx c.cl_path));
1111
write ctx (A3SetReg r);
1403
write ctx HGetGlobalScope;
1404
write ctx (HGetProp (type_path ctx c.cl_path));
1405
write ctx (HSetReg r.rid); (* needed for setslot *)
1112
1406
first := false;
1113
1407
end;
1114
write ctx (A3Reg r);
1115
gen_expr ctx true e;
1116
write ctx (A3SetSlot !nslot);
1408
write ctx (HReg r.rid);
1409
gen_expr ctx true (Transform.block_vars e);
1410
write ctx (HSetSlot !nslot);
1411
| _ ->
1412
incr nslot
1117
1413
) c.cl_ordered_statics;
1118
1414
free_reg ctx r
1119
1415
1120
let generate_enum_init ctx e slot =
1416
let generate_enum_init ctx e hc =
1121
1417
let path = ([],"Object") in
1122
1418
let name_id = type_path ctx e.e_path in
1123
write ctx A3GetScope0;
1124
write ctx (A3GetProp (type_path ctx path));
1125
write ctx A3Scope;
1126
write ctx (A3GetProp (type_path ~getclass:true ctx path));
1127
write ctx (A3ClassDef slot);
1128
write ctx A3PopScope;
1129
let r = alloc_reg ctx in
1130
write ctx A3Dup;
1131
write ctx (A3SetReg r);
1132
write ctx (A3Set name_id);
1419
write ctx HGetGlobalScope;
1420
write ctx (HGetLex (type_path ctx path));
1421
write ctx HScope;
1422
write ctx (HGetLex (type_path ctx path));
1423
write ctx (HClassDef hc);
1424
write ctx HPopScope;
1425
let r = alloc_reg ctx KDynamic in
1426
write ctx HDup;
1427
write ctx (HSetReg r.rid); (* needed for setslot *)
1428
write ctx (HInitProp name_id);
1133
1429
let nslot = ref 0 in
1134
1430
PMap.iter (fun _ f ->
1135
1431
incr nslot;
1136
1432
match f.ef_type with
1137
1433
| TFun _ -> ()
1138
1434
| _ ->
1139
write ctx (A3Reg r);
1140
write ctx (A3GetInf name_id);
1141
write ctx (A3String (lookup f.ef_name ctx.strings));
1142
write ctx A3Null;
1143
write ctx (A3New (name_id,2));
1144
write ctx (A3SetSlot !nslot);
1435
write ctx (HReg r.rid);
1436
write ctx (HFindPropStrict name_id);
1437
write ctx (HString f.ef_name);
1438
write ctx (HInt f.ef_index);
1439
write ctx HNull;
1440
write ctx (HConstructProperty (name_id,3));
1441
write ctx (HSetSlot !nslot);
1145
1442
) e.e_constrs;
1443
write ctx (HReg r.rid);
1444
List.iter (fun n -> write ctx (HString n)) e.e_names;
1445
write ctx (HArray (List.length e.e_names));
1446
write ctx (HSetSlot (!nslot + 1));
1146
1447
free_reg ctx r
1147
1448
1148
1449
let generate_field_kind ctx f c stat =
1155
1456
PMap.exists f.cf_name c.cl_fields || loop c
1156
1457
in
1157
1458
if f.cf_set = NormalAccess then
1158
Some (A3FVar {
1159
v3_type = None;
1160
v3_value = A3VNone;
1161
v3_const = false;
1162
})
1459
Some (HFVar {
1460
hlv_type = Some (type_path ctx ([],"Function"));
1461
hlv_value = HVNone;
1462
hlv_const = false;
1463
})
1163
1464
else
1164
Some (A3FMethod {
1165
m3_type = generate_function ctx fdata stat;
1166
m3_final = false;
1167
m3_override = not stat && loop c;
1168
m3_kind = MK3Normal;
1465
Some (HFMethod {
1466
hlm_type = generate_method ctx fdata stat;
1467
hlm_final = stat;
1468
hlm_override = not stat && loop c;
1469
hlm_kind = MK3Normal;
1169
1470
})
1170
1471
| _ when c.cl_interface && not stat ->
1171
1472
None
1473
| _ when f.cf_get = ResolveAccess ->
1474
None
1172
1475
| _ ->
1173
Some (A3FVar {
1174
v3_type = None;
1175
v3_value = A3VNone;
1176
v3_const = false;
1476
Some (HFVar {
1477
hlv_type = type_opt ctx f.cf_type;
1478
hlv_value = HVNone;
1479
hlv_const = false;
1177
1480
})
1178
1481
1179
1482
let generate_class ctx c =
1180
let name_id = type_path ctx c.cl_path in
1181
let st_id = empty_method ctx in
1483
let name = type_path ctx c.cl_path in
1182
1484
let cid , cnargs = (match c.cl_constructor with
1183
| None ->
1184
if c.cl_interface then begin
1185
let mt0 = {
1186
mt3_ret = None;
1187
mt3_args = [];
1188
mt3_native = false;
1189
mt3_var_args = false;
1190
mt3_new_block = false;
1191
mt3_debug_name = None;
1192
mt3_dparams = None;
1193
mt3_pnames = None;
1194
mt3_unk_flags = (false,false,false);
1195
} in
1196
add mt0 ctx.mtypes, 0
1197
end else
1485
| None ->
1486
if c.cl_interface then
1487
{ (empty_method ctx null_pos) with hlmt_function = None }, 0
1488
else
1198
1489
generate_construct ctx {
1199
1490
tf_args = [];
1200
tf_type = t_dynamic;
1491
tf_type = t_void;
1201
1492
tf_expr = {
1202
1493
eexpr = TBlock [];
1203
etype = t_dynamic;
1494
etype = t_void;
1204
1495
epos = null_pos;
1205
1496
}
1206
} c.cl_fields
1497
} c
1207
1498
| Some f ->
1208
1499
match f.cf_expr with
1209
| Some { eexpr = TFunction fdata } -> generate_construct ctx fdata c.cl_fields
1500
| Some { eexpr = TFunction fdata } -> generate_construct ctx fdata c
1210
1501
| _ -> assert false
1211
1502
) in
1212
1503
let fields = Array.of_list (PMap.fold (fun f acc ->
1214
1505
| None -> acc
1215
1506
| Some k ->
1216
1507
{
1217
f3_name = ident ctx f.cf_name;
1218
f3_slot = 0;
1219
f3_kind = k;
1220
f3_metas = None;
1508
hlf_name = ident f.cf_name;
1509
hlf_slot = 0;
1510
hlf_kind = k;
1511
hlf_metas = None;
1221
1512
} :: acc
1222
1513
) c.cl_fields []) in
1223
let sc = {
1224
cl3_name = name_id;
1225
cl3_super = (if c.cl_interface then None else Some (type_path ctx (match c.cl_super with None -> [],"Object" | Some (c,_) -> c.cl_path)));
1226
cl3_sealed = true;
1227
cl3_final = false;
1228
cl3_interface = c.cl_interface;
1229
cl3_rights = None;
1230
cl3_implements = Array.of_list (List.map (fun (c,_) ->
1514
let st_field_count = ref 0 in
1515
let st_meth_count = ref 0 in
1516
let rec is_dynamic c =
1517
if c.cl_dynamic <> None then true
1518
else match c.cl_super with
1519
| None -> false
1520
| Some (c,_) -> is_dynamic c
1521
in
1522
{
1523
hlc_name = name;
1524
hlc_super = (if c.cl_interface then None else Some (type_path ctx (match c.cl_super with None -> [],"Object" | Some (c,_) -> c.cl_path)));
1525
hlc_sealed = not (is_dynamic c);
1526
hlc_final = false;
1527
hlc_interface = c.cl_interface;
1528
hlc_namespace = None;
1529
hlc_implements = Array.of_list (List.map (fun (c,_) ->
1231
1530
if not c.cl_interface then Typer.error "Can't implement class in Flash9" c.cl_pos;
1232
1531
type_path ctx c.cl_path
1233
1532
) c.cl_implements);
1234
cl3_construct = cid;
1235
cl3_fields = fields;
1236
} in
1237
let st_count = ref 1 in
1238
let f_construct = generate_reflect_construct ctx name_id cnargs in
1239
let st = {
1240
st3_method = st_id;
1241
st3_fields = Array.of_list (f_construct :: (List.map (fun f ->
1242
incr st_count;
1533
hlc_construct = cid;
1534
hlc_fields = fields;
1535
hlc_static_construct = empty_method ctx c.cl_pos;
1536
hlc_static_fields = Array.of_list (List.map (fun f ->
1537
let k = (match generate_field_kind ctx f c true with None -> assert false | Some k -> k) in
1538
let count = (match k with HFMethod _ -> st_meth_count | HFVar _ -> st_field_count | _ -> assert false) in
1539
incr count;
1243
1540
{
1244
f3_name = ident ctx f.cf_name;
1245
f3_slot = !st_count;
1246
f3_kind = (match generate_field_kind ctx f c true with None -> assert false | Some k -> k);
1247
f3_metas = None;
1541
hlf_name = ident f.cf_name;
1542
hlf_slot = !count;
1543
hlf_kind = k;
1544
hlf_metas = None;
1248
1545
}
1249
) c.cl_ordered_statics))
1250
} in
1251
ctx.classes <- sc :: ctx.classes;
1252
ctx.statics <- st :: ctx.statics
1546
) c.cl_ordered_statics);
1547
}
1253
1548
1254
1549
let generate_enum ctx e =
1255
1550
let name_id = type_path ctx e.e_path in
1256
let st_id = empty_method ctx in
1257
let f = begin_fun ctx [("tag",false);("params",false)] [] false in
1258
let tag_id = ident ctx "tag" in
1259
let params_id = ident ctx "params" in
1260
write ctx (A3SetInf tag_id);
1261
write ctx (A3Reg 1);
1262
write ctx (A3Set tag_id);
1263
write ctx (A3SetInf params_id);
1264
write ctx (A3Reg 2);
1265
write ctx (A3Set params_id);
1266
write ctx A3RetVoid;
1551
let f = begin_fun ctx [("tag",false,t_string);("index",false,t_int);("params",false,mk_mono())] t_void [ethis] false e.e_pos in
1552
let tag_id = ident "tag" in
1553
let index_id = ident "index" in
1554
let params_id = ident "params" in
1555
write ctx (HFindProp tag_id);
1556
write ctx (HReg 1);
1557
write ctx (HInitProp tag_id);
1558
write ctx (HFindProp index_id);
1559
write ctx (HReg 2);
1560
write ctx (HInitProp index_id);
1561
write ctx (HFindProp params_id);
1562
write ctx (HReg 3);
1563
write ctx (HInitProp params_id);
1564
write ctx HRetVoid;
1267
1565
let construct = f() in
1268
let f = begin_fun ctx [] [] true in
1269
write ctx (A3GetProp (type_path ctx ~getclass:true (["flash"],"Boot")));
1270
write ctx A3This;
1271
write ctx (A3Call (ident ctx "enum_to_string",1));
1272
write ctx A3Ret;
1566
let f = begin_fun ctx [] t_string [] true e.e_pos in
1567
write ctx (HGetLex (type_path ctx ([],ctx.boot)));
1568
write ctx HThis;
1569
write ctx (HCallProperty (ident "enum_to_string",1));
1570
write ctx HRet;
1273
1571
let tostring = f() in
1274
let sc = {
1275
cl3_name = name_id;
1276
cl3_super = Some (type_path ctx ([],"Object"));
1277
cl3_sealed = true;
1278
cl3_final = false;
1279
cl3_interface = false;
1280
cl3_rights = None;
1281
cl3_implements = [||];
1282
cl3_construct = construct;
1283
cl3_fields = [|
1284
{ f3_name = tag_id; f3_slot = 0; f3_kind = A3FVar { v3_type = None; v3_value = A3VNone; v3_const = false; }; f3_metas = None };
1285
{ f3_name = params_id; f3_slot = 0; f3_kind = A3FVar { v3_type = None; v3_value = A3VNone; v3_const = false; }; f3_metas = None };
1286
{ f3_name = ident ctx "__enum__"; f3_slot = 0; f3_kind = A3FVar { v3_type = None; v3_value = A3VBool true; v3_const = true }; f3_metas = None };
1287
{
1288
f3_name = ident ctx "toString";
1289
f3_slot = 0;
1290
f3_kind = A3FMethod {
1291
m3_type = tostring;
1292
m3_final = false;
1293
m3_override = false;
1294
m3_kind = MK3Normal;
1295
};
1296
f3_metas = None;
1297
};
1298
|];
1299
} in
1300
1572
let st_count = ref 0 in
1301
1573
let constrs = PMap.fold (fun f acc ->
1302
1574
incr st_count;
1303
1575
{
1304
f3_name = ident ctx f.ef_name;
1305
f3_slot = !st_count;
1306
f3_kind = (match f.ef_type with
1576
hlf_name = ident f.ef_name;
1577
hlf_slot = !st_count;
1578
hlf_kind = (match f.ef_type with
1307
1579
| TFun (args,_) ->
1308
let fdata = begin_fun ctx (List.map (fun (name,opt,_) -> name,opt) args) [] true in
1309
write ctx (A3GetInf name_id);
1310
write ctx (A3String (lookup f.ef_name ctx.strings));
1580
let fdata = begin_fun ctx args (TEnum (e,[])) [] true f.ef_pos in
1581
write ctx (HFindPropStrict name_id);
1582
write ctx (HString f.ef_name);
1583
write ctx (HInt f.ef_index);
1311
1584
let n = ref 0 in
1312
List.iter (fun _ -> incr n; write ctx (A3Reg !n)) args;
1313
write ctx (A3Array (!n));
1314
write ctx (A3New (name_id,2));
1315
write ctx A3Ret;
1585
List.iter (fun _ -> incr n; write ctx (HReg !n)) args;
1586
write ctx (HArray (!n));
1587
write ctx (HConstructProperty (name_id,3));
1588
write ctx HRet;
1316
1589
let fid = fdata() in
1317
A3FMethod {
1318
m3_type = fid;
1319
m3_final = false;
1320
m3_override = false;
1321
m3_kind = MK3Normal;
1590
HFMethod {
1591
hlm_type = fid;
1592
hlm_final = true;
1593
hlm_override = false;
1594
hlm_kind = MK3Normal;
1322
1595
}
1323
1596
| _ ->
1324
A3FVar { v3_type = (Some name_id); v3_value = A3VNone; v3_const = false; }
1597
HFVar { hlv_type = (Some name_id); hlv_value = HVNone; hlv_const = false; }
1325
1598
);
1326
f3_metas = None;
1599
hlf_metas = None;
1327
1600
} :: acc
1328
1601
) e.e_constrs [] in
1329
let st = {
1330
st3_method = st_id;
1331
st3_fields = Array.of_list ({
1332
f3_name = ident ctx "__isenum";
1333
f3_slot = !st_count + 1;
1334
f3_kind = A3FVar { v3_type = None; v3_value = A3VBool true; v3_const = true; };
1335
f3_metas = None;
1336
} :: constrs)
1337
} in
1338
ctx.classes <- sc :: ctx.classes;
1339
ctx.statics <- st :: ctx.statics
1602
{
1603
hlc_name = name_id;
1604
hlc_super = Some (type_path ctx ([],"Object"));
1605
hlc_sealed = true;
1606
hlc_final = true;
1607
hlc_interface = false;
1608
hlc_namespace = None;
1609
hlc_implements = [||];
1610
hlc_construct = construct;
1611
hlc_fields = [|
1612
{ hlf_name = tag_id; hlf_slot = 0; hlf_kind = HFVar { hlv_type = None; hlv_value = HVNone; hlv_const = false; }; hlf_metas = None };
1613
{ hlf_name = index_id; hlf_slot = 0; hlf_kind = HFVar { hlv_type = None; hlv_value = HVNone; hlv_const = false; }; hlf_metas = None };
1614
{ hlf_name = params_id; hlf_slot = 0; hlf_kind = HFVar { hlv_type = None; hlv_value = HVNone; hlv_const = false; }; hlf_metas = None };
1615
{ hlf_name = ident "__enum__"; hlf_slot = 0; hlf_kind = HFVar { hlv_type = None; hlv_value = HVBool true; hlv_const = true }; hlf_metas = None };
1616
{
1617
hlf_name = ident "toString";
1618
hlf_slot = 0;
1619
hlf_kind = HFMethod {
1620
hlm_type = tostring;
1621
hlm_final = true;
1622
hlm_override = false;
1623
hlm_kind = MK3Normal;
1624
};
1625
hlf_metas = None;
1626
};
1627
|];
1628
hlc_static_construct = empty_method ctx e.e_pos;
1629
hlc_static_fields = Array.of_list ({
1630
hlf_name = ident "__isenum";
1631
hlf_slot = !st_count + 2;
1632
hlf_kind = HFVar { hlv_type = None; hlv_value = HVBool true; hlv_const = true; };
1633
hlf_metas = None;
1634
} :: {
1635
hlf_name = ident "__constructs__";
1636
hlf_slot = !st_count + 1;
1637
hlf_kind = HFVar { hlv_type = None; hlv_value = HVNone; hlv_const = false; };
1638
hlf_metas = None;
1639
} :: constrs);
1640
}
1340
1641
1341
1642
let generate_type ctx t =
1342
1643
match t with
1343
| TClassDecl c -> if not c.cl_extern then generate_class ctx c
1344
| TTypeDecl _ -> ()
1345
| TEnumDecl e -> if not e.e_extern then generate_enum ctx e
1346
1347
let generate_inits ctx types =
1348
let f = begin_fun ctx [] [] false in
1644
| TClassDecl c ->
1645
if c.cl_extern then
1646
None
1647
else
1648
Some (generate_class ctx c)
1649
| TEnumDecl e ->
1650
if e.e_extern then
1651
None
1652
else
1653
Some (generate_enum ctx e)
1654
| TTypeDecl _ ->
1655
None
1656
1657
let generate_resources ctx hres =
1658
write ctx HGetGlobalScope;
1659
write ctx (HGetProp (type_path ctx ([],ctx.boot)));
1660
let id = type_path ctx (["flash";"utils"],"Dictionary") in
1661
write ctx (HFindPropStrict id);
1662
write ctx (HConstructProperty (id,0));
1663
let r = alloc_reg ctx (KType id) in
1664
set_reg ctx r;
1665
Hashtbl.iter (fun name data ->
1666
write ctx (HReg r.rid);
1667
write ctx (HString name);
1668
write ctx (HString data);
1669
setvar ctx VArray false;
1670
) hres;
1671
write ctx (HReg r.rid);
1672
write ctx (HInitProp (ident "__res"))
1673
1674
let generate_inits ctx types hres =
1675
let f = begin_fun ctx [] t_void [ethis] false null_pos in
1349
1676
let slot = ref 0 in
1350
let classes = List.fold_left (fun acc t ->
1351
match t with
1352
| TClassDecl c when not c.cl_extern ->
1353
incr slot;
1354
generate_class_init ctx c (!slot - 1);
1355
{
1356
f3_name = type_path ctx c.cl_path;
1357
f3_slot = !slot;
1358
f3_kind = A3FClass (index_nz_int (!slot - 1));
1359
f3_metas = None;
1360
} :: acc
1361
| TEnumDecl e when not e.e_extern ->
1362
incr slot;
1363
generate_enum_init ctx e (!slot - 1);
1364
{
1365
f3_name = type_path ctx e.e_path;
1366
f3_slot = !slot;
1367
f3_kind = A3FClass (index_nz_int (!slot - 1));
1368
f3_metas = None;
1369
} :: acc
1370
| _ ->
1371
acc
1677
let classes = List.fold_left (fun acc (t,hc) ->
1678
match hc with
1679
| None -> acc
1680
| Some hc ->
1681
match t with
1682
| TClassDecl c ->
1683
incr slot;
1684
generate_class_init ctx c hc;
1685
{
1686
hlf_name = type_path ctx c.cl_path;
1687
hlf_slot = !slot;
1688
hlf_kind = HFClass hc;
1689
hlf_metas = None;
1690
} :: acc
1691
| TEnumDecl e ->
1692
incr slot;
1693
generate_enum_init ctx e hc;
1694
{
1695
hlf_name = type_path ctx e.e_path;
1696
hlf_slot = !slot;
1697
hlf_kind = HFClass hc;
1698
hlf_metas = None;
1699
} :: acc
1700
| _ ->
1701
acc
1372
1702
) [] types in
1373
1703
1374
1704
(* define flash.Boot.init method *)
1375
write ctx A3GetScope0;
1376
write ctx (A3Get (type_path ctx (["flash"],"Boot")));
1377
let finit = begin_fun ctx [] [] true in
1378
List.iter (fun t ->
1705
write ctx HGetGlobalScope;
1706
write ctx (HGetProp (type_path ctx ([],ctx.boot)));
1707
let finit = begin_fun ctx [] t_void [] true null_pos in
1708
List.iter (fun (t,_) ->
1379
1709
match t with
1380
1710
| TClassDecl c ->
1381
1711
(match c.cl_init with
1382
1712
| None -> ()
1383
| Some e -> gen_expr ctx false e);
1713
| Some e -> gen_expr ctx false (Transform.block_vars e));
1384
1714
| _ -> ()
1385
1715
) types;
1386
List.iter (fun t ->
1716
List.iter (fun (t,_) ->
1387
1717
match t with
1388
1718
| TClassDecl c -> generate_class_statics ctx c
1389
1719
| _ -> ()
1390
1720
) types;
1391
write ctx A3RetVoid;
1392
write ctx (A3Function (finit()));
1393
write ctx (A3Set (ident ctx "init"));
1394
write ctx A3RetVoid;
1721
write ctx HRetVoid;
1722
write ctx (HFunction (finit()));
1723
write ctx (HInitProp (ident "init"));
1724
1725
(* generate resources *)
1726
generate_resources ctx hres;
1727
1728
write ctx HRetVoid;
1395
1729
{
1396
st3_method = f();
1397
st3_fields = Array.of_list (List.rev classes);
1730
hls_method = f();
1731
hls_fields = Array.of_list (List.rev classes);
1398
1732
}
1399
1733
1400
1734
let generate types hres =
1401
let brights = new_lookup() in
1402
let strings = new_lookup() in
1403
let rights = new_lookup() in
1404
let empty_id = lookup "" strings in
1405
let rpublic = lookup (A3RPublic (Some empty_id)) brights in
1406
1735
let ctx = {
1407
strings = strings;
1408
ints = new_lookup();
1409
floats = new_lookup();
1410
brights = brights;
1411
rights = rights;
1412
types = new_lookup();
1413
mtypes = new_lookup_nz();
1414
rpublic = rpublic;
1415
gpublic = lookup [rpublic] rights;
1416
classes = [];
1417
statics = [];
1418
functions = new_lookup();
1736
boot = "Boot_" ^ Printf.sprintf "%X" (Random.int 0xFFFFFF);
1419
1737
code = DynArray.create();
1420
1738
locals = PMap.empty;
1421
1739
infos = default_infos();
1427
1745
in_static = false;
1428
1746
debug = Plugin.defined "debug";
1429
1747
last_line = -1;
1748
last_file = "";
1430
1749
try_scope_reg = None;
1431
} in
1432
List.iter (generate_type ctx) types;
1433
Hashtbl.iter (fun _ _ -> assert false) hres;
1434
let init = generate_inits ctx types in
1435
let a = {
1436
as3_ints = lookup_array ctx.ints;
1437
as3_floats = lookup_array ctx.floats;
1438
as3_idents = lookup_array ctx.strings;
1439
as3_base_rights = lookup_array ctx.brights;
1440
as3_rights = lookup_array ctx.rights;
1441
as3_types = lookup_array ctx.types;
1442
as3_method_types = lookup_array ctx.mtypes;
1443
as3_metadatas = [||];
1444
as3_classes = Array.of_list (List.rev ctx.classes);
1445
as3_statics = Array.of_list (List.rev ctx.statics);
1446
as3_inits = [|init|];
1447
as3_functions = lookup_array ctx.functions;
1448
as3_unknown = "";
1449
} in
1450
[Swf.TActionScript3 (Some (0,""),a)]
1451
1452
1453
(* ----------------------------------------------------------------------------------------
1454
1455
HX generation
1456
1457
---------------------------------------------------------------------------------------- *)
1458
1459
let ident ctx p =
1460
As3code.iget ctx.as3_idents p
1461
1462
let package ctx idx =
1463
match As3code.iget ctx.as3_base_rights idx with
1464
| A3RPrivate (Some id)
1465
| A3RPublic (Some id)
1466
| A3RInternal (Some id)
1467
| A3RProtected id
1468
| A3RUnknown1 id
1469
| A3RUnknown2 (Some id) ->
1470
let pack = ident ctx id in
1471
ExtString.String.nsplit pack "."
1472
| A3RPrivate None | A3RPublic None | A3RInternal None | A3RUnknown2 None ->
1473
[]
1474
1475
let real_type_path ctx p =
1476
match As3code.iget ctx.as3_types p with
1477
| A3TMethodVar (id,pack) ->
1478
let name = ident ctx id in
1479
let pack = package ctx pack in
1480
pack , name
1481
| A3TClassInterface (Some id,pack) ->
1482
let name = ident ctx id in
1483
let pack = package ctx (List.hd (As3code.iget ctx.as3_rights pack)) in
1484
pack , name
1485
| A3TClassInterface (None,_) ->
1486
[] , "$ClassInterfaceNone"
1487
| A3TArrayAccess _ ->
1488
[] , "$ArrayAccess"
1489
| A3TUnknown1 _ ->
1490
[] , "$Unknown1"
1491
| A3TUnknown2 _ ->
1492
[] , "$Unknown2"
1493
1494
let type_path ctx p =
1495
match real_type_path ctx p with
1496
| [] , "Object" -> [] , "Dynamic"
1497
| [] , "Boolean" -> [] , "Bool"
1498
| [] , "int" -> [] , "Int"
1499
| [] , "uint" -> [] , "UInt"
1500
| [] , "Number" -> [] , "Float"
1501
| [] , "Array" -> [] , "Array<Dynamic>"
1502
| [] , "void" -> [] , "Void"
1503
| [] , "Function" -> [] , "Dynamic"
1504
| path -> path
1505
1506
let ident_rights ctx id =
1507
match As3code.iget ctx.as3_types id with
1508
| A3TMethodVar (id,r) ->
1509
let name = ident ctx id in
1510
let r = (match As3code.iget ctx.as3_base_rights r with
1511
| A3RPublic _ | A3RUnknown1 _ -> false
1512
| _ -> true
1513
) in
1514
r , name
1515
| _ -> false, "???"
1516
1517
let rec create_dir acc = function
1518
| [] -> ()
1519
| d :: l ->
1520
let path = acc ^ "/" ^ d in
1521
(try Unix.mkdir path 0o777 with _ -> ());
1522
create_dir path l
1523
1524
let value_type = function
1525
| A3VNone
1526
| A3VNull -> "Dynamic"
1527
| A3VBool _ -> "Bool"
1528
| A3VString _ -> "String"
1529
| A3VInt _ -> "Int"
1530
| A3VFloat _ -> "Float"
1531
| A3VNamespace _ -> "$Namespace"
1532
1533
let type_val ctx t v =
1534
match t with
1535
| None ->
1536
(match v with
1537
| None -> "Dynamic"
1538
| Some v -> value_type v)
1539
| Some t ->
1540
s_type_path (type_path ctx t)
1541
1542
let has_getset ml f m =
1543
List.exists (fun f2 ->
1544
match f2.f3_kind with
1545
| A3FMethod m2 when f.f3_name = f2.f3_name ->
1546
(match m.m3_kind , m2.m3_kind with
1547
| MK3Getter , MK3Setter | MK3Setter , MK3Getter -> true
1548
| _ -> false)
1549
| _ -> false
1550
) ml
1551
1552
let gen_method ctx ch name mt =
1553
let m = As3code.iget ctx.as3_method_types (As3parse.no_nz mt) in
1554
let ret = (match m.mt3_ret with
1555
| None -> "Void"
1556
| Some t -> s_type_path (type_path ctx t)
1557
) in
1558
let p = ref 0 in
1559
let params = List.map (fun a ->
1560
let name = (match m.mt3_pnames with
1561
| None -> "p" ^ string_of_int !p
1562
| Some l -> ident ctx (List.nth l (!p))
1563
) in
1564
let opt_val = (match m.mt3_dparams with
1565
| None -> None
1566
| Some l ->
1567
try
1568
Some (List.nth l (!p - List.length m.mt3_args + List.length l))
1569
with
1570
_ -> None
1571
) in
1572
let t = type_val ctx a opt_val in
1573
incr p;
1574
(if opt_val <> None then "?" else "") ^ name ^ " : " ^ t
1575
) m.mt3_args in
1576
let vargs = if m.mt3_var_args then " /* ...arguments */" else "" in
1577
IO.printf ch "function %s(%s%s) : %s;\n" name (String.concat ", " params) vargs ret
1578
1579
let gen_fields ctx ch fields stat =
1580
let fields = List.sort (fun f1 f2 -> compare (ident_rights ctx f1.f3_name) (ident_rights ctx f2.f3_name)) (Array.to_list fields) in
1581
List.iter (fun f ->
1582
match f.f3_kind with
1583
| A3FMethod m ->
1584
if m.m3_override then
1585
()
1586
else
1587
let priv , name = ident_rights ctx f.f3_name in
1588
(match m.m3_kind with
1589
| MK3Normal ->
1590
IO.printf ch "\t";
1591
if priv then IO.printf ch "private ";
1592
if stat then IO.printf ch "static ";
1593
gen_method ctx ch name m.m3_type
1594
| MK3Getter ->
1595
let set = has_getset fields f m in
1596
let set_str = if set then "" else "(default,null)" in
1597
let m = As3code.iget ctx.as3_method_types (As3parse.no_nz m.m3_type) in
1598
let t = (match m.mt3_ret with None -> "Dynamic" | Some t -> s_type_path (type_path ctx t)) in
1599
IO.printf ch "\t%s%svar %s%s : %s;\n" (if priv then "private " else "") (if stat then "static " else "") name set_str t
1600
| MK3Setter ->
1601
let get = has_getset fields f m in
1602
if not get then begin
1603
let m = As3code.iget ctx.as3_method_types (As3parse.no_nz m.m3_type) in
1604
let t = (match m.mt3_ret with None -> "Dynamic" | Some t -> s_type_path (type_path ctx t)) in
1605
IO.printf ch "\t%s%svar %s(null,default) : %s;\n" (if priv then "private " else "") (if stat then "static " else "") name t
1606
end;
1607
)
1608
| A3FVar v ->
1609
let t = type_val ctx v.v3_type (Some v.v3_value) in
1610
let priv , n = ident_rights ctx f.f3_name in
1611
IO.printf ch "\t%s%svar %s : %s;\n" (if priv then "private " else "") (if stat then "static " else "") n t
1612
| A3FClass _ ->
1613
IO.printf ch "\t// ????\n"
1614
) fields
1615
1616
let genhx_class ctx c s =
1617
let base_path = "hxclasses" in
1618
let pack , name = real_type_path ctx c.cl3_name in
1619
prerr_string ("import " ^ s_type_path (pack,name));
1620
create_dir "." (base_path :: pack);
1621
let f = open_out (base_path ^ "/" ^ (match pack with [] -> "" | l -> String.concat "/" l ^ "/") ^ name ^ ".hx") in
1622
let ch = IO.output_channel f in
1623
if pack <> [] then IO.printf ch "package %s;\n\n" (String.concat "." pack);
1624
IO.printf ch "extern %s %s" (if c.cl3_interface then "interface" else "class") name;
1625
let prev = ref (match c.cl3_super with
1626
| None -> false
1627
| Some p ->
1628
match type_path ctx p with
1629
| [] , "Dynamic" -> false
1630
| path ->
1631
IO.printf ch " extends %s" (s_type_path path);
1632
true
1633
) in
1634
Array.iter (fun i ->
1635
if !prev then IO.printf ch ",";
1636
prev := true;
1637
IO.printf ch " implements %s" (s_type_path (type_path ctx i));
1638
) c.cl3_implements;
1639
IO.printf ch " {\n";
1640
IO.printf ch "\t"; gen_method ctx ch "new" c.cl3_construct;
1641
gen_fields ctx ch c.cl3_fields false;
1642
gen_fields ctx ch s.st3_fields true;
1643
IO.printf ch "}\n";
1644
prerr_endline ";";
1645
IO.close_out ch
1646
1647
let genhx file =
1648
let file = (try Plugin.find_file file with Not_found -> failwith ("File not found : " ^ file)) in
1649
let ch = IO.input_channel (open_in_bin file) in
1650
SwfParser.full_parsing := true;
1651
let _, swf = Swf.parse ch in
1652
SwfParser.full_parsing := false;
1653
IO.close_in ch;
1654
List.iter (fun t ->
1655
match t.Swf.tdata with
1656
| Swf.TActionScript3 (_,t) -> Array.iteri (fun i c -> genhx_class t c t.as3_statics.(i)) t.as3_classes
1657
| _ -> ()
1658
) swf
1750
for_call = false;
1751
} in
1752
let classes = List.map (fun t -> (t,generate_type ctx t)) types in
1753
let init = generate_inits ctx classes hres in
1754
[init], ctx.boot, (fun () -> empty_method ctx null_pos)
1659
1755
1660
1756
;;
1757
Random.self_init();
1661
1758
gen_expr_ref := gen_expr
Loggerhead is a web-based interface for Breezy
Version: 2.0.1