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 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243
|
(*
* Copyright (C)2005-2013 Haxe Foundation
*
* Permission is hereby granted, free of charge, to any person obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense,
* and/or sell copies of the Software, and to permit persons to whom the
* Software is furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
* DEALINGS IN THE SOFTWARE.
*)
open Type
open Common
type context_infos = {
com : Common.context;
}
type context = {
inf : context_infos;
ch : out_channel;
buf : Buffer.t;
path : path;
mutable get_sets : (string * bool,string) Hashtbl.t;
mutable curclass : tclass;
mutable tabs : string;
mutable in_value : tvar option;
mutable in_static : bool;
mutable handle_break : bool;
mutable imports : (string,string list list) Hashtbl.t;
mutable gen_uid : int;
mutable local_types : t list;
mutable constructor_block : bool;
mutable block_inits : (unit -> unit) option;
}
let follow = Abstract.follow_with_abstracts
let is_var_field f =
match f with
| FStatic (_,f) | FInstance (_,_,f) ->
(match f.cf_kind with Var _ | Method MethDynamic -> true | _ -> false)
| _ ->
false
let is_special_compare e1 e2 =
match e1.eexpr, e2.eexpr with
| TConst TNull, _ | _ , TConst TNull -> None
| _ ->
match follow e1.etype, follow e2.etype with
| TInst ({ cl_path = ["flash"],"NativeXml" } as c,_) , _ | _ , TInst ({ cl_path = ["flash"],"NativeXml" } as c,_) -> Some c
| _ -> None
let protect name =
match name with
| "Error" | "Namespace" -> "_" ^ name
| _ -> name
let s_path ctx stat path p =
match path with
| ([],name) ->
(match name with
| "Int" -> "int"
| "Float" -> "Number"
| "Dynamic" -> "Object"
| "Bool" -> "Boolean"
| "Enum" -> "Class"
| "EnumValue" -> "enum"
| _ -> name)
| (["flash"],"FlashXml__") ->
"Xml"
| (["flash";"errors"],"Error") ->
"Error"
| (["flash"],"Vector") ->
"Vector"
| (["flash";"xml"],"XML") ->
"XML"
| (["flash";"xml"],"XMLList") ->
"XMLList"
| ["flash";"utils"],"QName" ->
"QName"
| ["flash";"utils"],"Namespace" ->
"Namespace"
| (["haxe"],"Int32") when not stat ->
"int"
| (pack,name) ->
let name = protect name in
let packs = (try Hashtbl.find ctx.imports name with Not_found -> []) in
if not (List.mem pack packs) then Hashtbl.replace ctx.imports name (pack :: packs);
Ast.s_type_path (pack,name)
let reserved =
let h = Hashtbl.create 0 in
List.iter (fun l -> Hashtbl.add h l ())
(* these ones are defined in order to prevent recursion in some Std functions *)
["is";"as";"int";"uint";"const";"getTimer";"typeof";"parseInt";"parseFloat";
(* AS3 keywords which are not Haxe ones *)
"finally";"with";"final";"internal";"native";"namespace";"include";"delete";
(* some globals give some errors with Flex SDK as well *)
"print";"trace";
(* we don't include get+set since they are not 'real' keywords, but they can't be used as method names *)
"function";"class";"var";"if";"else";"while";"do";"for";"break";"continue";"return";"extends";"implements";
"import";"switch";"case";"default";"static";"public";"private";"try";"catch";"new";"this";"throw";"interface";
"override";"package";"null";"true";"false";"void"
];
h
(* "each", "label" : removed (actually allowed in locals and fields accesses) *)
let s_ident n =
if Hashtbl.mem reserved n then "_" ^ n else n
let valid_as3_ident s =
try
for i = 0 to String.length s - 1 do
match String.unsafe_get s i with
| 'a'..'z' | 'A'..'Z' | '$' | '_' -> ()
| '0'..'9' when i > 0 -> ()
| _ -> raise Exit
done;
true
with Exit ->
false
let anon_field s =
let s = s_ident s in
if not (valid_as3_ident s) then "\"" ^ s ^ "\"" else s
let rec create_dir acc = function
| [] -> ()
| d :: l ->
let dir = String.concat "/" (List.rev (d :: acc)) in
if not (Sys.file_exists dir) then Unix.mkdir dir 0o755;
create_dir (d :: acc) l
let init infos path =
let dir = infos.com.file :: fst path in
create_dir [] dir;
let ch = open_out (String.concat "/" dir ^ "/" ^ snd path ^ ".as") in
let imports = Hashtbl.create 0 in
Hashtbl.add imports (snd path) [fst path];
{
inf = infos;
tabs = "";
ch = ch;
path = path;
buf = Buffer.create (1 lsl 14);
in_value = None;
in_static = false;
handle_break = false;
imports = imports;
curclass = null_class;
gen_uid = 0;
local_types = [];
get_sets = Hashtbl.create 0;
constructor_block = false;
block_inits = None;
}
let close ctx =
begin match ctx.inf.com.main_class with
| Some tp when tp = ctx.curclass.cl_path ->
output_string ctx.ch "// Compile __main__.as instead\n";
| _ ->
()
end;
output_string ctx.ch (Printf.sprintf "package %s {\n" (String.concat "." (fst ctx.path)));
Hashtbl.iter (fun name paths ->
List.iter (fun pack ->
let path = pack, name in
if path <> ctx.path then output_string ctx.ch ("\timport " ^ Ast.s_type_path path ^ ";\n");
) paths
) ctx.imports;
output_string ctx.ch (Buffer.contents ctx.buf);
close_out ctx.ch
let gen_local ctx l =
ctx.gen_uid <- ctx.gen_uid + 1;
if ctx.gen_uid = 1 then l else l ^ string_of_int ctx.gen_uid
let spr ctx s = Buffer.add_string ctx.buf s
let print ctx = Printf.kprintf (fun s -> Buffer.add_string ctx.buf s)
let unsupported p = error "This expression cannot be generated to AS3" p
let newline ctx =
let rec loop p =
match Buffer.nth ctx.buf p with
| '}' | '{' | ':' | ';' -> print ctx "\n%s" ctx.tabs
| '\n' | '\t' -> loop (p - 1)
| _ -> print ctx ";\n%s" ctx.tabs
in
loop (Buffer.length ctx.buf - 1)
let block_newline ctx = match Buffer.nth ctx.buf (Buffer.length ctx.buf - 1) with
| '}' -> print ctx ";\n%s" ctx.tabs
| _ -> newline ctx
let rec concat ctx s f = function
| [] -> ()
| [x] -> f x
| x :: l ->
f x;
spr ctx s;
concat ctx s f l
let open_block ctx =
let oldt = ctx.tabs in
ctx.tabs <- "\t" ^ ctx.tabs;
(fun() -> ctx.tabs <- oldt)
let parent e =
match e.eexpr with
| TParenthesis _ -> e
| _ -> mk (TParenthesis e) e.etype e.epos
let default_value tstr =
match tstr with
| "int" | "uint" -> "0"
| "Number" -> "NaN"
| "Boolean" -> "false"
| _ -> "null"
let rec type_str ctx t p =
match t with
| TEnum _ | TInst _ when List.memq t ctx.local_types ->
"*"
| TAbstract (a,pl) when not (Ast.Meta.has Ast.Meta.CoreType a.a_meta) ->
type_str ctx (Abstract.get_underlying_type a pl) p
| TAbstract (a,_) ->
(match a.a_path with
| [], "Void" -> "void"
| [], "UInt" -> "uint"
| [], "Int" -> "int"
| [], "Float" -> "Number"
| [], "Bool" -> "Boolean"
| _ -> s_path ctx true a.a_path p)
| TEnum (e,_) ->
if e.e_extern then (match e.e_path with
| [], "Void" -> "void"
| [], "Bool" -> "Boolean"
| _ ->
let rec loop = function
| [] -> "Object"
| (Ast.Meta.FakeEnum,[Ast.EConst (Ast.Ident n),_],_) :: _ ->
(match n with
| "Int" -> "int"
| "UInt" -> "uint"
| _ -> n)
| _ :: l -> loop l
in
loop e.e_meta
) else
s_path ctx true e.e_path p
| TInst ({ cl_path = ["flash"],"Vector" },[pt]) ->
(match pt with
| TInst({cl_kind = KTypeParameter _},_) -> "*"
| _ -> "Vector.<" ^ type_str ctx pt p ^ ">")
| TInst (c,_) ->
(match c.cl_kind with
| KNormal | KGeneric | KGenericInstance _ | KAbstractImpl _ -> s_path ctx false c.cl_path p
| KTypeParameter _ | KExtension _ | KExpr _ | KMacroType | KGenericBuild _ -> "*")
| TFun _ ->
"Function"
| TMono r ->
(match !r with None -> "*" | Some t -> type_str ctx t p)
| TAnon _ | TDynamic _ ->
"*"
| TType (t,args) ->
(match t.t_path with
| [], "UInt" -> "uint"
| [] , "Null" ->
(match args with
| [t] ->
(match follow t with
| TAbstract ({ a_path = [],"UInt" },_)
| TAbstract ({ a_path = [],"Int" },_)
| TAbstract ({ a_path = [],"Float" },_)
| TAbstract ({ a_path = [],"Bool" },_)
| TInst ({ cl_path = [],"Int" },_)
| TInst ({ cl_path = [],"Float" },_)
| TEnum ({ e_path = [],"Bool" },_) -> "*"
| _ -> type_str ctx t p)
| _ -> assert false);
| _ -> type_str ctx (apply_params t.t_params args t.t_type) p)
| TLazy f ->
type_str ctx ((!f)()) p
let rec iter_switch_break in_switch e =
match e.eexpr with
| TFunction _ | TWhile _ | TFor _ -> ()
| TSwitch _ when not in_switch -> iter_switch_break true e
| TBreak when in_switch -> raise Exit
| _ -> iter (iter_switch_break in_switch) e
let handle_break ctx e =
let old_handle = ctx.handle_break in
try
iter_switch_break false e;
ctx.handle_break <- false;
(fun() -> ctx.handle_break <- old_handle)
with
Exit ->
spr ctx "try {";
let b = open_block ctx in
newline ctx;
ctx.handle_break <- true;
(fun() ->
b();
ctx.handle_break <- old_handle;
newline ctx;
spr ctx "} catch( e : * ) { if( e != \"__break__\" ) throw e; }";
)
let this ctx = if ctx.in_value <> None then "$this" else "this"
let generate_resources infos =
if Hashtbl.length infos.com.resources <> 0 then begin
let dir = (infos.com.file :: ["__res"]) in
create_dir [] dir;
let add_resource name data =
let name = Base64.str_encode name in
let ch = open_out_bin (String.concat "/" (dir @ [name])) in
output_string ch data;
close_out ch
in
Hashtbl.iter (fun name data -> add_resource name data) infos.com.resources;
let ctx = init infos ([],"__resources__") in
spr ctx "\timport flash.utils.Dictionary;\n";
spr ctx "\tpublic class __resources__ {\n";
spr ctx "\t\tpublic static var list:Dictionary;\n";
let inits = ref [] in
let k = ref 0 in
Hashtbl.iter (fun name _ ->
let varname = ("v" ^ (string_of_int !k)) in
k := !k + 1;
print ctx "\t\t[Embed(source = \"__res/%s\", mimeType = \"application/octet-stream\")]\n" (Base64.str_encode name);
print ctx "\t\tpublic static var %s:Class;\n" varname;
inits := ("list[\"" ^ Ast.s_escape name ^ "\"] = " ^ varname ^ ";") :: !inits;
) infos.com.resources;
spr ctx "\t\tstatic public function __init__():void {\n";
spr ctx "\t\t\tlist = new Dictionary();\n";
List.iter (fun init ->
print ctx "\t\t\t%s\n" init
) !inits;
spr ctx "\t\t}\n";
spr ctx "\t}\n";
spr ctx "}";
close ctx;
end
let gen_constant ctx p = function
| TInt i -> print ctx "%ld" i
| TFloat s -> spr ctx s
| TString s -> print ctx "\"%s\"" (Ast.s_escape s)
| TBool b -> spr ctx (if b then "true" else "false")
| TNull -> spr ctx "null"
| TThis -> spr ctx (this ctx)
| TSuper -> spr ctx "super"
let gen_function_header ctx name f params p =
let old = ctx.in_value in
let old_t = ctx.local_types in
let old_bi = ctx.block_inits in
ctx.in_value <- None;
ctx.local_types <- List.map snd params @ ctx.local_types;
let init () =
List.iter (fun (v,o) -> match o with
| Some c when is_nullable v.v_type && c <> TNull ->
newline ctx;
print ctx "if(%s==null) %s=" v.v_name v.v_name;
gen_constant ctx p c;
| _ -> ()
) f.tf_args;
ctx.block_inits <- None;
in
ctx.block_inits <- Some init;
print ctx "function%s(" (match name with None -> "" | Some (n,meta) ->
let rec loop = function
| [] -> n
| (Ast.Meta.Getter,[Ast.EConst (Ast.Ident i),_],_) :: _ -> "get " ^ i
| (Ast.Meta.Setter,[Ast.EConst (Ast.Ident i),_],_) :: _ -> "set " ^ i
| _ :: l -> loop l
in
" " ^ loop meta
);
concat ctx "," (fun (v,c) ->
match v.v_name with
| "__arguments__" ->
print ctx "...__arguments__"
| _ ->
let tstr = type_str ctx v.v_type p in
print ctx "%s : %s" (s_ident v.v_name) tstr;
match c with
| None ->
if ctx.constructor_block then print ctx " = %s" (default_value tstr);
| Some c ->
spr ctx " = ";
gen_constant ctx p c
) f.tf_args;
print ctx ") : %s " (type_str ctx f.tf_type p);
(fun () ->
ctx.in_value <- old;
ctx.local_types <- old_t;
ctx.block_inits <- old_bi;
)
let rec gen_call ctx e el r =
match e.eexpr , el with
| TCall (x,_) , el ->
spr ctx "(";
gen_value ctx e;
spr ctx ")";
spr ctx "(";
concat ctx "," (gen_value ctx) el;
spr ctx ")";
| TLocal { v_name = "__is__" } , [e1;e2] ->
gen_value ctx e1;
spr ctx " is ";
gen_value ctx e2;
| TLocal { v_name = "__in__" } , [e1;e2] ->
spr ctx "(";
gen_value ctx e1;
spr ctx " in ";
gen_value ctx e2;
spr ctx ")"
| TLocal { v_name = "__as__" }, [e1;e2] ->
gen_value ctx e1;
spr ctx " as ";
gen_value ctx e2;
| TLocal { v_name = "__int__" }, [e] ->
spr ctx "int(";
gen_value ctx e;
spr ctx ")";
| TLocal { v_name = "__float__" }, [e] ->
spr ctx "Number(";
gen_value ctx e;
spr ctx ")";
| TLocal { v_name = "__typeof__" }, [e] ->
spr ctx "typeof ";
gen_value ctx e;
| TLocal { v_name = "__keys__" }, [e] ->
let ret = (match ctx.in_value with None -> assert false | Some r -> r) in
print ctx "%s = new Array()" ret.v_name;
newline ctx;
let tmp = gen_local ctx "$k" in
print ctx "for(var %s : String in " tmp;
gen_value ctx e;
print ctx ") %s.push(%s)" ret.v_name tmp;
| TLocal { v_name = "__hkeys__" }, [e] ->
let ret = (match ctx.in_value with None -> assert false | Some r -> r) in
print ctx "%s = new Array()" ret.v_name;
newline ctx;
let tmp = gen_local ctx "$k" in
print ctx "for(var %s : String in " tmp;
gen_value ctx e;
print ctx ") %s.push(%s.substr(1))" ret.v_name tmp;
| TLocal { v_name = "__foreach__" }, [e] ->
let ret = (match ctx.in_value with None -> assert false | Some r -> r) in
print ctx "%s = new Array()" ret.v_name;
newline ctx;
let tmp = gen_local ctx "$k" in
print ctx "for each(var %s : * in " tmp;
gen_value ctx e;
print ctx ") %s.push(%s)" ret.v_name tmp;
| TLocal { v_name = "__new__" }, e :: args ->
spr ctx "new ";
gen_value ctx e;
spr ctx "(";
concat ctx "," (gen_value ctx) args;
spr ctx ")";
| TLocal { v_name = "__delete__" }, [e;f] ->
spr ctx "delete(";
gen_value ctx e;
spr ctx "[";
gen_value ctx f;
spr ctx "]";
spr ctx ")";
| TLocal { v_name = "__unprotect__" }, [e] ->
gen_value ctx e
| TLocal { v_name = "__vector__" }, [e] ->
spr ctx (type_str ctx r e.epos);
spr ctx "(";
gen_value ctx e;
spr ctx ")"
| TField (_, FStatic( { cl_path = (["flash"],"Lib") }, { cf_name = "as" })), [e1;e2] ->
gen_value ctx e1;
spr ctx " as ";
gen_value ctx e2
| TField (_, FStatic ({ cl_path = (["flash"],"Vector") }, cf)), args ->
(match cf.cf_name, args with
| "ofArray", [e] | "convert", [e] ->
(match follow r with
| TInst ({ cl_path = (["flash"],"Vector") },[t]) ->
print ctx "Vector.<%s>(" (type_str ctx t e.epos);
gen_value ctx e;
print ctx ")";
| _ -> assert false)
| _ -> assert false)
| TField(e1, (FAnon {cf_name = s} | FDynamic s)),[ef] when s = "map" || s = "filter" ->
spr ctx (s_path ctx true (["flash";],"Boot") e.epos);
gen_field_access ctx t_dynamic (s ^ "Dynamic");
spr ctx "(";
concat ctx "," (gen_value ctx) [e1;ef];
spr ctx ")"
| TField (ee,f), args when is_var_field f ->
spr ctx "(";
gen_value ctx e;
spr ctx ")";
spr ctx "(";
concat ctx "," (gen_value ctx) el;
spr ctx ")"
| _ ->
gen_value ctx e;
spr ctx "(";
concat ctx "," (gen_value ctx) el;
spr ctx ")"
and gen_value_op ctx e =
match e.eexpr with
| TBinop (op,_,_) when op = Ast.OpAnd || op = Ast.OpOr || op = Ast.OpXor ->
spr ctx "(";
gen_value ctx e;
spr ctx ")";
| _ ->
gen_value ctx e
and gen_field_access ctx t s =
let field c =
match fst c.cl_path, snd c.cl_path, s with
| [], "Math", "NaN"
| [], "Math", "NEGATIVE_INFINITY"
| [], "Math", "POSITIVE_INFINITY"
| [], "Math", "isFinite"
| [], "Math", "isNaN"
| [], "Date", "now"
| [], "Date", "fromTime"
| [], "Date", "fromString"
->
print ctx "[\"%s\"]" s
| [], "String", "charCodeAt" ->
spr ctx "[\"charCodeAtHX\"]"
| [], "Array", "map" ->
spr ctx "[\"mapHX\"]"
| [], "Array", "filter" ->
spr ctx "[\"filterHX\"]"
| [], "Date", "toString" ->
print ctx "[\"toStringHX\"]"
| [], "String", "cca" ->
print ctx ".charCodeAt"
| ["flash";"xml"], "XML", "namespace" ->
print ctx ".namespace"
| _ ->
print ctx ".%s" (s_ident s)
in
match follow t with
| TInst (c,_) -> field c
| TAnon a ->
(match !(a.a_status) with
| Statics c -> field c
| _ -> print ctx ".%s" (s_ident s))
| _ ->
print ctx ".%s" (s_ident s)
and gen_expr ctx e =
match e.eexpr with
| TConst c ->
gen_constant ctx e.epos c
| TLocal v ->
spr ctx (s_ident v.v_name)
| TArray ({ eexpr = TLocal { v_name = "__global__" } },{ eexpr = TConst (TString s) }) ->
let path = Ast.parse_path s in
spr ctx (s_path ctx false path e.epos)
| TArray (e1,e2) ->
gen_value ctx e1;
spr ctx "[";
gen_value ctx e2;
spr ctx "]";
| TBinop (Ast.OpEq,e1,e2) when (match is_special_compare e1 e2 with Some c -> true | None -> false) ->
let c = match is_special_compare e1 e2 with Some c -> c | None -> assert false in
gen_expr ctx (mk (TCall (mk (TField (mk (TTypeExpr (TClassDecl c)) t_dynamic e.epos,FDynamic "compare")) t_dynamic e.epos,[e1;e2])) ctx.inf.com.basic.tbool e.epos);
(* what is this used for? *)
(* | TBinop (op,{ eexpr = TField (e1,s) },e2) ->
gen_value_op ctx e1;
gen_field_access ctx e1.etype s;
print ctx " %s " (Ast.s_binop op);
gen_value_op ctx e2; *)
(* assignments to variable or dynamic methods fields on interfaces are generated as class["field"] = value *)
| TBinop (op,{eexpr = TField (ei, FInstance({cl_interface = true},_,{cf_kind = (Method MethDynamic | Var _); cf_name = s}))},e2) ->
gen_value ctx ei;
print ctx "[\"%s\"]" s;
print ctx " %s " (Ast.s_binop op);
gen_value_op ctx e2;
| TBinop (op,e1,e2) ->
gen_value_op ctx e1;
print ctx " %s " (Ast.s_binop op);
gen_value_op ctx e2;
(* variable fields and dynamic methods on interfaces are generated as (class["field"] as class) *)
| TField (ei, FInstance({cl_interface = true},_,{cf_kind = (Method MethDynamic | Var _); cf_name = s})) ->
spr ctx "(";
gen_value ctx ei;
print ctx "[\"%s\"]" s;
print ctx " as %s)" (type_str ctx e.etype e.epos);
| TField({eexpr = TArrayDecl _} as e1,s) ->
spr ctx "(";
gen_expr ctx e1;
spr ctx ")";
gen_field_access ctx e1.etype (field_name s)
| TEnumParameter (e,_,i) ->
gen_value ctx e;
print ctx ".params[%i]" i;
| TField (e,s) ->
gen_value ctx e;
gen_field_access ctx e.etype (field_name s)
| TTypeExpr t ->
spr ctx (s_path ctx true (t_path t) e.epos)
| TParenthesis e ->
spr ctx "(";
gen_value ctx e;
spr ctx ")";
| TMeta (_,e) ->
gen_expr ctx e
| TReturn eo ->
if ctx.in_value <> None then unsupported e.epos;
(match eo with
| None ->
spr ctx "return"
| Some e when (match follow e.etype with TEnum({ e_path = [],"Void" },[]) | TAbstract ({ a_path = [],"Void" },[]) -> true | _ -> false) ->
print ctx "{";
let bend = open_block ctx in
newline ctx;
gen_value ctx e;
newline ctx;
spr ctx "return";
bend();
newline ctx;
print ctx "}";
| Some e ->
spr ctx "return ";
gen_value ctx e);
| TBreak ->
if ctx.in_value <> None then unsupported e.epos;
if ctx.handle_break then spr ctx "throw \"__break__\"" else spr ctx "break"
| TContinue ->
if ctx.in_value <> None then unsupported e.epos;
spr ctx "continue"
| TBlock el ->
print ctx "{";
let bend = open_block ctx in
let cb = (if not ctx.constructor_block then
(fun () -> ())
else if not (Codegen.constructor_side_effects e) then begin
ctx.constructor_block <- false;
(fun () -> ())
end else begin
ctx.constructor_block <- false;
print ctx " if( !%s.skip_constructor ) {" (s_path ctx true (["flash"],"Boot") e.epos);
(fun() -> print ctx "}")
end) in
(match ctx.block_inits with None -> () | Some i -> i());
List.iter (fun e -> gen_block_element ctx e) el;
bend();
newline ctx;
cb();
print ctx "}";
| TFunction f ->
let h = gen_function_header ctx None f [] e.epos in
let old = ctx.in_static in
ctx.in_static <- true;
gen_expr ctx f.tf_expr;
ctx.in_static <- old;
h();
| TCall (v,el) ->
gen_call ctx v el e.etype
| TArrayDecl el ->
spr ctx "[";
concat ctx "," (gen_value ctx) el;
spr ctx "]"
| TThrow e ->
spr ctx "throw ";
gen_value ctx e;
| TVar (v,eo) ->
spr ctx "var ";
print ctx "%s : %s" (s_ident v.v_name) (type_str ctx v.v_type e.epos);
begin match eo with
| None -> ()
| Some e ->
spr ctx " = ";
gen_value ctx e
end
| TNew (c,params,el) ->
(match c.cl_path, params with
| (["flash"],"Vector"), [pt] -> print ctx "new Vector.<%s>(" (type_str ctx pt e.epos)
| _ -> print ctx "new %s(" (s_path ctx true c.cl_path e.epos));
concat ctx "," (gen_value ctx) el;
spr ctx ")"
| TIf (cond,e,eelse) ->
spr ctx "if";
gen_value ctx (parent cond);
spr ctx " ";
gen_expr ctx e;
(match eelse with
| None -> ()
| Some e ->
newline ctx;
spr ctx "else ";
gen_expr ctx e);
| TUnop (op,Ast.Prefix,e) ->
spr ctx (Ast.s_unop op);
gen_value ctx e
| TUnop (op,Ast.Postfix,e) ->
gen_value ctx e;
spr ctx (Ast.s_unop op)
| TWhile (cond,e,Ast.NormalWhile) ->
let handle_break = handle_break ctx e in
spr ctx "while";
gen_value ctx (parent cond);
spr ctx " ";
gen_expr ctx e;
handle_break();
| TWhile (cond,e,Ast.DoWhile) ->
let handle_break = handle_break ctx e in
spr ctx "do ";
gen_expr ctx e;
spr ctx " while";
gen_value ctx (parent cond);
handle_break();
| TObjectDecl fields ->
spr ctx "{ ";
concat ctx ", " (fun (f,e) -> print ctx "%s : " (anon_field f); gen_value ctx e) fields;
spr ctx "}"
| TFor (v,it,e) ->
let handle_break = handle_break ctx e in
let tmp = gen_local ctx "$it" in
print ctx "{ var %s : * = " tmp;
gen_value ctx it;
newline ctx;
print ctx "while( %s.hasNext() ) { var %s : %s = %s.next()" tmp (s_ident v.v_name) (type_str ctx v.v_type e.epos) tmp;
newline ctx;
gen_expr ctx e;
newline ctx;
spr ctx "}}";
handle_break();
| TTry (e,catchs) ->
spr ctx "try ";
gen_expr ctx e;
List.iter (fun (v,e) ->
newline ctx;
print ctx "catch( %s : %s )" (s_ident v.v_name) (type_str ctx v.v_type e.epos);
gen_expr ctx e;
) catchs;
| TSwitch (e,cases,def) ->
spr ctx "switch";
gen_value ctx (parent e);
spr ctx " {";
newline ctx;
List.iter (fun (el,e2) ->
List.iter (fun e ->
spr ctx "case ";
gen_value ctx e;
spr ctx ":";
) el;
gen_block ctx e2;
print ctx "break";
newline ctx;
) cases;
(match def with
| None -> ()
| Some e ->
spr ctx "default:";
gen_block ctx e;
print ctx "break";
newline ctx;
);
spr ctx "}"
| TCast (e1,None) ->
let s = type_str ctx e.etype e.epos in
if s = "*" then
gen_expr ctx e1
else begin
spr ctx "((";
gen_value ctx e1;
print ctx ") as %s)" s
end
| TCast (e1,Some t) ->
gen_expr ctx (Codegen.default_cast ctx.inf.com e1 t e.etype e.epos)
and gen_block_element ctx e = match e.eexpr with
| TObjectDecl fl ->
List.iter (fun (_,e) -> gen_block_element ctx e) fl
| _ ->
block_newline ctx;
gen_expr ctx e
and gen_block ctx e =
newline ctx;
match e.eexpr with
| TBlock [] -> ()
| _ ->
gen_expr ctx e;
newline ctx
and gen_value ctx e =
let assign e =
mk (TBinop (Ast.OpAssign,
mk (TLocal (match ctx.in_value with None -> assert false | Some r -> r)) t_dynamic e.epos,
e
)) e.etype e.epos
in
let block e =
mk (TBlock [e]) e.etype e.epos
in
let value block =
let old = ctx.in_value in
let t = type_str ctx e.etype e.epos in
let r = alloc_var (gen_local ctx "$r") e.etype in
ctx.in_value <- Some r;
if ctx.in_static then
print ctx "function() : %s " t
else
print ctx "(function($this:%s) : %s " (snd ctx.path) t;
let b = if block then begin
spr ctx "{";
let b = open_block ctx in
newline ctx;
print ctx "var %s : %s" r.v_name t;
newline ctx;
b
end else
(fun() -> ())
in
(fun() ->
if block then begin
newline ctx;
print ctx "return %s" r.v_name;
b();
newline ctx;
spr ctx "}";
end;
ctx.in_value <- old;
if ctx.in_static then
print ctx "()"
else
print ctx "(%s))" (this ctx)
)
in
match e.eexpr with
| TCall ({ eexpr = TLocal { v_name = "__keys__" } },_) | TCall ({ eexpr = TLocal { v_name = "__hkeys__" } },_) ->
let v = value true in
gen_expr ctx e;
v()
| TConst _
| TLocal _
| TArray _
| TBinop _
| TField _
| TEnumParameter _
| TTypeExpr _
| TParenthesis _
| TObjectDecl _
| TArrayDecl _
| TCall _
| TNew _
| TUnop _
| TFunction _ ->
gen_expr ctx e
| TMeta (_,e1) ->
gen_value ctx e1
| TCast (e1,None) ->
let s = type_str ctx e.etype e1.epos in
begin match s with
| "*" ->
gen_value ctx e1
| "Function" | "Array" | "String" ->
spr ctx "((";
gen_value ctx e1;
print ctx ") as %s)" s;
| _ ->
print ctx "%s(" s;
gen_value ctx e1;
spr ctx ")";
end
| TCast (e1,Some t) ->
gen_value ctx (Codegen.default_cast ctx.inf.com e1 t e.etype e.epos)
| TReturn _
| TBreak
| TContinue ->
unsupported e.epos
| TVar _
| TFor _
| TWhile _
| TThrow _ ->
(* value is discarded anyway *)
let v = value true in
gen_expr ctx e;
v()
| TBlock [] ->
spr ctx "null"
| TBlock [e] ->
gen_value ctx e
| TBlock el ->
let v = value true in
let rec loop = function
| [] ->
spr ctx "return null";
| [e] ->
gen_expr ctx (assign e);
| e :: l ->
gen_expr ctx e;
newline ctx;
loop l
in
loop el;
v();
| TIf (cond,e,eo) ->
spr ctx "(";
gen_value ctx cond;
spr ctx "?";
gen_value ctx e;
spr ctx ":";
(match eo with
| None -> spr ctx "null"
| Some e -> gen_value ctx e);
spr ctx ")"
| TSwitch (cond,cases,def) ->
let v = value true in
gen_expr ctx (mk (TSwitch (cond,
List.map (fun (e1,e2) -> (e1,assign e2)) cases,
match def with None -> None | Some e -> Some (assign e)
)) e.etype e.epos);
v()
| TTry (b,catchs) ->
let v = value true in
gen_expr ctx (mk (TTry (block (assign b),
List.map (fun (v,e) -> v, block (assign e)) catchs
)) e.etype e.epos);
v()
let final m =
if Ast.Meta.has Ast.Meta.Final m then "final " else ""
let generate_field ctx static f =
newline ctx;
ctx.in_static <- static;
ctx.gen_uid <- 0;
List.iter (fun(m,pl,_) ->
match m,pl with
| Ast.Meta.Meta, [Ast.ECall ((Ast.EConst (Ast.Ident n),_),args),_] ->
let mk_arg (a,p) =
match a with
| Ast.EConst (Ast.String s) -> (None, s)
| Ast.EBinop (Ast.OpAssign,(Ast.EConst (Ast.Ident n),_),(Ast.EConst (Ast.String s),_)) -> (Some n, s)
| _ -> error "Invalid meta definition" p
in
print ctx "[%s" n;
(match args with
| [] -> ()
| _ ->
print ctx "(";
concat ctx "," (fun a ->
match mk_arg a with
| None, s -> gen_constant ctx (snd a) (TString s)
| Some s, e -> print ctx "%s=" s; gen_constant ctx (snd a) (TString e)
) args;
print ctx ")");
print ctx "]";
| _ -> ()
) f.cf_meta;
let public = f.cf_public || Hashtbl.mem ctx.get_sets (f.cf_name,static) || (f.cf_name = "main" && static)
|| f.cf_name = "resolve" || Ast.Meta.has Ast.Meta.Public f.cf_meta
(* consider all abstract methods public to avoid issues with inlined private access *)
|| (match ctx.curclass.cl_kind with KAbstractImpl _ -> true | _ -> false)
in
let rights = (if static then "static " else "") ^ (if public then "public" else "protected") in
let p = ctx.curclass.cl_pos in
match f.cf_expr, f.cf_kind with
| Some { eexpr = TFunction fd }, Method (MethNormal | MethInline) ->
print ctx "%s%s " rights (if static then "" else final f.cf_meta);
let rec loop c =
match c.cl_super with
| None -> ()
| Some (c,_) ->
if PMap.mem f.cf_name c.cl_fields then
spr ctx "override "
else
loop c
in
if not static then loop ctx.curclass;
let h = gen_function_header ctx (Some (s_ident f.cf_name, f.cf_meta)) fd f.cf_params p in
gen_expr ctx fd.tf_expr;
h();
newline ctx
| _ ->
let is_getset = (match f.cf_kind with Var { v_read = AccCall } | Var { v_write = AccCall } -> true | _ -> false) in
if ctx.curclass.cl_interface then
match follow f.cf_type with
| TFun (args,r) when (match f.cf_kind with Method MethDynamic | Var _ -> false | _ -> true) ->
let rec loop = function
| [] -> f.cf_name
| (Ast.Meta.Getter,[Ast.EConst (Ast.String name),_],_) :: _ -> "get " ^ name
| (Ast.Meta.Setter,[Ast.EConst (Ast.String name),_],_) :: _ -> "set " ^ name
| _ :: l -> loop l
in
print ctx "function %s(" (loop f.cf_meta);
concat ctx "," (fun (arg,o,t) ->
let tstr = type_str ctx t p in
print ctx "%s : %s" arg tstr;
if o then print ctx " = %s" (default_value tstr);
) args;
print ctx ") : %s " (type_str ctx r p);
| _ -> ()
else
let gen_init () = match f.cf_expr with
| None -> ()
| Some e ->
print ctx " = ";
gen_value ctx e
in
if is_getset then begin
let t = type_str ctx f.cf_type p in
let id = s_ident f.cf_name in
let v = (match f.cf_kind with Var v -> v | _ -> assert false) in
(match v.v_read with
| AccNormal | AccNo | AccNever ->
print ctx "%s function get %s() : %s { return $%s; }" rights id t id;
newline ctx
| AccCall ->
print ctx "%s function get %s() : %s { return %s(); }" rights id t ("get_" ^ f.cf_name);
newline ctx
| _ -> ());
(match v.v_write with
| AccNormal | AccNo | AccNever ->
print ctx "%s function set %s( __v : %s ) : void { $%s = __v; }" rights id t id;
newline ctx
| AccCall ->
print ctx "%s function set %s( __v : %s ) : void { %s(__v); }" rights id t ("set_" ^ f.cf_name);
newline ctx
| _ -> ());
print ctx "%sprotected var $%s : %s" (if static then "static " else "") (s_ident f.cf_name) (type_str ctx f.cf_type p);
gen_init()
end else begin
print ctx "%s var %s : %s" rights (s_ident f.cf_name) (type_str ctx f.cf_type p);
gen_init()
end
let rec define_getset ctx stat c =
let def f name =
Hashtbl.add ctx.get_sets (name,stat) f.cf_name
in
let field f =
match f.cf_kind with
| Method _ -> ()
| Var v ->
(match v.v_read with AccCall -> def f ("get_" ^ f.cf_name) | _ -> ());
(match v.v_write with AccCall -> def f ("set_" ^ f.cf_name) | _ -> ())
in
List.iter field (if stat then c.cl_ordered_statics else c.cl_ordered_fields);
match c.cl_super with
| Some (c,_) when not stat -> define_getset ctx stat c
| _ -> ()
let generate_class ctx c =
ctx.curclass <- c;
define_getset ctx true c;
define_getset ctx false c;
ctx.local_types <- List.map snd c.cl_params;
let pack = open_block ctx in
print ctx "\tpublic %s%s%s %s " (final c.cl_meta) (match c.cl_dynamic with None -> "" | Some _ -> if c.cl_interface then "" else "dynamic ") (if c.cl_interface then "interface" else "class") (snd c.cl_path);
(match c.cl_super with
| None -> ()
| Some (csup,_) -> print ctx "extends %s " (s_path ctx true csup.cl_path c.cl_pos));
(match c.cl_implements with
| [] -> ()
| l ->
spr ctx (if c.cl_interface then "extends " else "implements ");
concat ctx ", " (fun (i,_) -> print ctx "%s" (s_path ctx true i.cl_path c.cl_pos)) l);
spr ctx "{";
let cl = open_block ctx in
(match c.cl_constructor with
| None -> ()
| Some f ->
let f = { f with
cf_name = snd c.cl_path;
cf_public = true;
cf_kind = Method MethNormal;
} in
ctx.constructor_block <- true;
generate_field ctx false f;
);
List.iter (generate_field ctx false) c.cl_ordered_fields;
List.iter (generate_field ctx true) c.cl_ordered_statics;
cl();
newline ctx;
print ctx "}";
pack();
newline ctx;
print ctx "}";
newline ctx
let generate_main ctx inits =
ctx.curclass <- { null_class with cl_path = [],"__main__" };
let pack = open_block ctx in
print ctx "\timport flash.Lib";
newline ctx;
print ctx "public class __main__ extends %s {" (s_path ctx true (["flash"],"Boot") Ast.null_pos);
let cl = open_block ctx in
newline ctx;
spr ctx "public function __main__() {";
let fl = open_block ctx in
newline ctx;
spr ctx "super()";
newline ctx;
spr ctx "flash.Lib.current = this";
List.iter (fun e -> newline ctx; gen_expr ctx e) inits;
fl();
newline ctx;
print ctx "}";
cl();
newline ctx;
print ctx "}";
pack();
newline ctx;
print ctx "}";
newline ctx
let generate_enum ctx e =
ctx.local_types <- List.map snd e.e_params;
let pack = open_block ctx in
let ename = snd e.e_path in
print ctx "\tpublic final class %s extends enum {" ename;
let cl = open_block ctx in
newline ctx;
print ctx "public static const __isenum : Boolean = true";
newline ctx;
print ctx "public function %s( t : String, index : int, p : Array = null ) : void { this.tag = t; this.index = index; this.params = p; }" ename;
PMap.iter (fun _ c ->
newline ctx;
match c.ef_type with
| TFun (args,_) ->
print ctx "public static function %s(" c.ef_name;
concat ctx ", " (fun (a,o,t) ->
print ctx "%s : %s" (s_ident a) (type_str ctx t c.ef_pos);
if o then spr ctx " = null";
) args;
print ctx ") : %s {" ename;
print ctx " return new %s(\"%s\",%d,[" ename c.ef_name c.ef_index;
concat ctx "," (fun (a,_,_) -> spr ctx (s_ident a)) args;
print ctx "]); }";
| _ ->
print ctx "public static var %s : %s = new %s(\"%s\",%d)" c.ef_name ename ename c.ef_name c.ef_index;
) e.e_constrs;
newline ctx;
(match Codegen.build_metadata ctx.inf.com (TEnumDecl e) with
| None -> ()
| Some e ->
print ctx "public static var __meta__ : * = ";
gen_expr ctx e;
newline ctx);
print ctx "public static var __constructs__ : Array = [%s];" (String.concat "," (List.map (fun s -> "\"" ^ Ast.s_escape s ^ "\"") e.e_names));
cl();
newline ctx;
print ctx "}";
pack();
newline ctx;
print ctx "}";
newline ctx
let generate_base_enum ctx =
let pack = open_block ctx in
spr ctx "\timport flash.Boot";
newline ctx;
spr ctx "public class enum {";
let cl = open_block ctx in
newline ctx;
spr ctx "public var tag : String";
newline ctx;
spr ctx "public var index : int";
newline ctx;
spr ctx "public var params : Array";
newline ctx;
spr ctx "public function toString() : String { return flash.Boot.enum_to_string(this); }";
cl();
newline ctx;
print ctx "}";
pack();
newline ctx;
print ctx "}";
newline ctx
let generate com =
let infos = {
com = com;
} in
generate_resources infos;
let ctx = init infos ([],"enum") in
generate_base_enum ctx;
close ctx;
let inits = ref [] in
List.iter (fun t ->
match t with
| TClassDecl c ->
let c = (match c.cl_path with
| ["flash"],"FlashXml__" -> { c with cl_path = [],"Xml" }
| (pack,name) -> { c with cl_path = (pack,protect name) }
) in
(match c.cl_init with
| None -> ()
| Some e -> inits := e :: !inits);
if c.cl_extern then
()
else
let ctx = init infos c.cl_path in
generate_class ctx c;
close ctx
| TEnumDecl e ->
let pack,name = e.e_path in
let e = { e with e_path = (pack,protect name) } in
if e.e_extern then
()
else
let ctx = init infos e.e_path in
generate_enum ctx e;
close ctx
| TTypeDecl _ | TAbstractDecl _ ->
()
) com.types;
(match com.main with
| None -> ()
| Some e -> inits := e :: !inits);
let ctx = init infos ([],"__main__") in
generate_main ctx (List.rev !inits);
close ctx
|