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 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411
|
(*
* Copyright (C)2005-2014 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 Ast
open Type
open Common
module Utils = struct
let class_of_module_type mt = match mt with
| TClassDecl c -> c
| _ -> failwith ("Not a class: " ^ (s_type_path (t_infos mt).mt_path))
let find_type com path =
try
List.find (fun mt -> match mt with
| TAbstractDecl _ -> false
| _ -> (t_infos mt).mt_path = path
) com.types
with Not_found ->
error (Printf.sprintf "Could not find type %s\n" (s_type_path path)) null_pos
let mk_static_field c cf p =
let ta = TAnon { a_fields = c.cl_statics; a_status = ref (Statics c) } in
let ethis = mk (TTypeExpr (TClassDecl c)) ta p in
let t = monomorphs cf.cf_params cf.cf_type in
mk (TField (ethis,(FStatic (c,cf)))) t p
let mk_static_call c cf el p =
let ef = mk_static_field c cf p in
let tr = match follow ef.etype with
| TFun(args,tr) -> tr
| _ -> assert false
in
mk (TCall(ef,el)) tr p
let resolve_static_field c n =
try
PMap.find n c.cl_statics
with Not_found ->
failwith (Printf.sprintf "Class %s has no field %s" (s_type_path c.cl_path) n)
let mk_static_field_2 c n p =
mk_static_field c (resolve_static_field c n) p
let mk_static_call_2 c n el p =
mk_static_call c (resolve_static_field c n) el p
end
module KeywordHandler = struct
let kwds =
let h = Hashtbl.create 0 in
List.iter (fun s -> Hashtbl.add h s ()) [
"and"; "as"; "assert"; "break"; "class"; "continue"; "def"; "del"; "elif"; "else"; "except"; "exec"; "finally"; "for";
"from"; "global"; "if"; "import"; "in"; "is"; "lambda"; "not"; "or"; "pass"; " raise"; "return"; "try"; "while";
"with"; "yield"; "None"; "True"; "False";
];
h
let kwds2 =
let h = Hashtbl.create 0 in
List.iter (fun s -> Hashtbl.add h s ()) [
"len"; "int"; "float"; "list"; "bool"; "str"; "isinstance"; "print"; "min"; "max";
"hasattr"; "getattr"; "setattr"; "delattr"; "callable"; "type"; "ord"; "chr"; "iter"; "map"; "filter";
"tuple"; "dict"; "set"; "bytes"; "bytearray"
];
h
let handle_keywords s =
let l = String.length s in
if Hashtbl.mem kwds s then
"_hx_" ^ s
(*
handle special __ underscore behaviour (creates private fields for objects) for fields but only if the field doesn't
end with at least one underscores like __iter__ because these are special fields
*)
else if l > 2 && String.sub s 0 2 = "__" && String.sub s (l - 1) 1 <> "_" then
"_hx_" ^ s
else s
let check_var_declaration v =
if Hashtbl.mem kwds2 v.v_name then v.v_name <- "_hx_" ^ v.v_name
end
module Transformer = struct
type adjusted_expr = {
a_expr : texpr;
a_blocks : texpr list;
a_next_id : unit -> string;
a_is_value : bool;
}
let como = ref None
let t_bool = ref t_dynamic
let t_void = ref t_dynamic
let t_string = ref t_dynamic
let t_int = ref t_dynamic
let c_reflect = ref (fun () -> null_class)
let init com =
como := Some com;
t_bool := com.basic.tbool;
t_void := com.basic.tvoid;
t_string := com.basic.tstring;
t_int := com.basic.tint;
c_reflect := fun () -> Utils.class_of_module_type (Utils.find_type com ([],"Reflect"))
and debug_expr e =
let s_type = Type.s_type (print_context()) in
let s = Type.s_expr_pretty "\t" s_type e in
Printf.printf "%s\n" s
and debug_expr_with_type e =
let s_type = Type.s_type (print_context()) in
let es = Type.s_expr_pretty "\t" s_type e in
let t = s_type e.etype in
Printf.printf "%s : %s\n" es t
and debug_type t =
let s_type = Type.s_type (print_context()) in
let t = s_type t in
Printf.printf "%s\n" t
let new_counter () =
let n = ref (-1) in
(fun () ->
incr n;
Printf.sprintf "_hx_local_%i" !n
)
let to_expr ae =
match ae.a_blocks with
| [] ->
ae.a_expr
| el ->
match ae.a_expr.eexpr with
| TBlock el2 ->
{ ae.a_expr with eexpr = TBlock (el @ el2) }
| _ ->
{ ae.a_expr with eexpr = TBlock (el @ [ae.a_expr])}
let lift_expr ?(is_value = false) ?(next_id = None) ?(blocks = []) e =
let next_id = match next_id with
| None ->
new_counter()
| Some f ->
f
in
{
a_expr = e;
a_blocks = blocks;
a_next_id = next_id;
a_is_value = is_value
}
let lift_expr1 is_value next_id blocks e =
lift_expr ~is_value:is_value ~next_id:(Some next_id) ~blocks:blocks e
let to_tvar ?(capture = false) n t =
alloc_var n t
(* { v_name = n; v_type = t; v_id = 0; v_capture = capture; v_extra = None; v_meta = [] } *)
let create_non_local n pos =
let s = "nonlocal " ^ (KeywordHandler.handle_keywords n) in
(* TODO: this is a hack... *)
let id = mk (TLocal (to_tvar "python_Syntax._pythonCode" t_dynamic ) ) !t_void pos in
let id2 = mk (TLocal( to_tvar s t_dynamic )) !t_void pos in
mk (TCall(id, [id2])) t_dynamic pos
let to_tlocal_expr ?(capture = false) n t p =
mk (TLocal (to_tvar ~capture:capture n t)) t p
let check_unification e t = match follow e.etype,follow t with
| TAnon an1, TAnon an2 ->
PMap.iter (fun s cf ->
if not (PMap.mem s an1.a_fields) then an1.a_fields <- PMap.add s cf an1.a_fields
) an2.a_fields;
e
| _ ->
e
let dynamic_field_read e s =
Utils.mk_static_call_2 ((!c_reflect)()) "field" [e;mk (TConst (TString s)) !t_string e.epos] e.epos
let dynamic_field_write e1 s e2 =
Utils.mk_static_call_2 ((!c_reflect)()) "setField" [e1;mk (TConst (TString s)) !t_string e1.epos;e2] e1.epos
let dynamic_field_read_write next_id e1 s op e2 =
let id = next_id() in
let temp_var = to_tvar id e1.etype in
let temp_var_def = mk (TVar(temp_var,Some e1)) e1.etype e1.epos in
let temp_local = mk (TLocal temp_var) e1.etype e1.epos in
let e_field = dynamic_field_read temp_local s in
let e_op = mk (TBinop(op,e_field,e2)) e_field.etype e_field.epos in
let e_set_field = dynamic_field_write temp_local s e_op in
mk (TBlock [
temp_var_def;
e_set_field;
]) e_set_field.etype e_set_field.epos
let add_non_locals_to_func e = match e.eexpr with
| TFunction tf ->
let cur = ref PMap.empty in
let save () =
let prev = !cur in
(fun () ->
cur := prev
)
in
let declare v =
cur := PMap.add v.v_id v !cur;
in
List.iter (fun (v,_) -> declare v) tf.tf_args;
let non_locals = Hashtbl.create 0 in
let rec it e = match e.eexpr with
| TVar(v,e1) ->
begin match e1 with
| Some e ->
maybe_continue e
| None ->
()
end;
declare v;
| TTry(e1,catches) ->
it e1;
List.iter (fun (v,e) ->
let restore = save() in
declare v;
it e;
restore()
) catches;
| TBinop( (OpAssign | OpAssignOp(_)), { eexpr = TLocal v }, e2) ->
if not (PMap.mem v.v_id !cur) then
Hashtbl.add non_locals v.v_id v;
maybe_continue e2;
| TFunction _ ->
()
| _ ->
Type.iter it e
and maybe_continue e = match e.eexpr with
| TFunction _ ->
()
| _ ->
it e
in
it tf.tf_expr;
let el = Hashtbl.fold (fun k v acc ->
(create_non_local v.v_name e.epos) :: acc
) non_locals [] in
let el = tf.tf_expr :: el in
let tf = { tf with tf_expr = { tf.tf_expr with eexpr = TBlock(List.rev el)}} in
{e with eexpr = TFunction tf}
| _ ->
assert false
let rec transform_function tf ae is_value =
let p = tf.tf_expr.epos in
let assigns = List.fold_left (fun acc (v,value) -> match value with
| None | Some TNull ->
acc
| Some ct ->
let a_local = mk (TLocal v) v.v_type p in
let a_null = mk (TConst TNull) v.v_type p in
let a_cmp = mk (TBinop(OpEq,a_local,a_null)) !t_bool p in
let a_value = mk (TConst(ct)) v.v_type p in
let a_assign = mk (TBinop(OpAssign,a_local,a_value)) v.v_type p in
let a_if = mk (TIf(a_cmp,a_assign,None)) !t_void p in
a_if :: acc
) [] tf.tf_args in
let body = match assigns with
| [] ->
tf.tf_expr
| _ ->
let eb = mk (TBlock (List.rev assigns)) t_dynamic p in
Type.concat eb tf.tf_expr
in
let e1 = to_expr (transform_expr ~next_id:(Some ae.a_next_id) body) in
let fn = mk (TFunction({
tf_expr = e1;
tf_args = tf.tf_args;
tf_type = tf.tf_type;
})) ae.a_expr.etype p in
let fn = add_non_locals_to_func fn in
if is_value then begin
let new_name = ae.a_next_id() in
let new_var = alloc_var new_name tf.tf_type in
let new_local = mk (TLocal new_var) fn.etype p in
let def = mk (TVar(new_var,Some fn)) fn.etype p in
lift_expr1 false ae.a_next_id [def] new_local
end else
lift_expr fn
and transform_var_expr ae eo v =
let b,new_expr = match eo with
| None ->
[],None
| Some e1 ->
let f = transform_expr1 true ae.a_next_id [] e1 in
let b = f.a_blocks in
b,Some(f.a_expr)
in
let e = mk (TVar(v,new_expr)) ae.a_expr.etype ae.a_expr.epos in
lift_expr ~next_id:(Some ae.a_next_id) ~blocks:b e
and transform_expr ?(is_value = false) ?(next_id = None) ?(blocks = []) (e : texpr) : adjusted_expr =
transform1 (lift_expr ~is_value ~next_id ~blocks e)
and transform_expr1 is_value next_id blocks e =
transform_expr ~is_value ~next_id:(Some next_id) ~blocks e
and transform_exprs_to_block el tb is_value p next_id =
match el with
| [e] ->
transform_expr ~is_value ~next_id:(Some next_id) e
| _ ->
let size = List.length el in
let res = DynArray.create () in
ExtList.List.iteri (fun i e ->
(* this removes len(x) calls which are reproduced by the inlined return
of Array.push even if the value is not used *)
let is_removable_statement e = (not is_value || i < size-1) &&
match e.eexpr with
| TField(_, FInstance({cl_path = [],"list"},_,{ cf_name = "length" })) -> true
| _ -> false
in
if not (is_removable_statement e) then
let ae = transform_expr ~is_value ~next_id:(Some next_id) e in
List.iter (DynArray.add res) ae.a_blocks;
DynArray.add res ae.a_expr
else
()
) el;
lift_expr (mk (TBlock (DynArray.to_list res)) tb p)
and transform_switch ae is_value e1 cases edef =
let case_functions = ref [] in
let case_to_if (el,e) eelse =
let val_reversed = List.rev el in
let mk_eq e = mk (TBinop(OpEq,e1,e)) !t_bool (punion e1.epos e.epos) in
let cond = match val_reversed with
| [] ->
assert false
| [e] ->
mk_eq e
| e :: el ->
List.fold_left (fun eelse e -> mk (TBinop(OpBoolOr,eelse,mk_eq e)) !t_bool (punion eelse.epos e.epos)) (mk_eq e) el
in
let eif = if is_value then begin
let name = ae.a_next_id() in
let func = exprs_to_func [e] name ae in
case_functions := !case_functions @ func.a_blocks;
let call = func.a_expr in
mk (TIf(cond,call,eelse)) ae.a_expr.etype ae.a_expr.epos
end else
mk (TIf(cond,e,eelse)) ae.a_expr.etype e.epos
in
eif
in
let rev_cases = List.rev cases in
let edef = Some (match edef with
| None ->
mk (TBlock []) ae.a_expr.etype ae.a_expr.epos
| Some e ->
e)
in
let res = match rev_cases,edef with
| [],Some edef ->
edef
| [],None ->
(* I don't think that can happen? *)
assert false
| [case],_ ->
case_to_if case edef
| case :: cases,_ ->
List.fold_left (fun acc case -> case_to_if case (Some acc)) (case_to_if case edef) cases
in
let res = if is_value then
mk (TBlock ((List.rev (res :: !case_functions)))) res.etype res.epos
else
res
in
forward_transform res ae
and transform_string_switch ae is_value e1 cases edef =
let length_map = Hashtbl.create 0 in
List.iter (fun (el,e) ->
List.iter (fun es ->
match es.eexpr with
| TConst (TString s) ->
let l = String.length s in
let sl = try
Hashtbl.find length_map l
with Not_found ->
let sl = ref [] in
Hashtbl.replace length_map l sl;
sl
in
sl := ([es],e) :: !sl;
| _ ->
()
) el
) cases;
if Hashtbl.length length_map < 2 then
transform_switch ae is_value e1 cases edef
else
let mk_eq e1 e2 = mk (TBinop(OpEq,e1,e2)) !t_bool (punion e1.epos e2.epos) in
let mk_or e1 e2 = mk (TBinop(OpOr,e1,e2)) !t_bool (punion e1.epos e2.epos) in
let mk_if (el,e) eo =
let eif = List.fold_left (fun eacc e -> mk_or eacc (mk_eq e1 e)) (mk_eq e1 (List.hd el)) (List.tl el) in
mk (TIf(Codegen.mk_parent eif,e,eo)) e.etype e.epos
in
let cases = Hashtbl.fold (fun i el acc ->
let eint = mk (TConst (TInt (Int32.of_int i))) !t_int e1.epos in
let fs = match List.fold_left (fun eacc ec -> Some (mk_if ec eacc)) edef !el with Some e -> e | None -> assert false in
([eint],fs) :: acc
) length_map [] in
let c_string = match !t_string with TInst(c,_) -> c | _ -> assert false in
let cf_length = PMap.find "length" c_string.cl_fields in
let ef = mk (TField(e1,FInstance(c_string,[],cf_length))) !t_int e1.epos in
let res_var = alloc_var (ae.a_next_id()) ef.etype in
let res_local = {ef with eexpr = TLocal res_var} in
let var_expr = {ef with eexpr = TVar(res_var,Some ef)} in
let e = mk (TBlock [
var_expr;
mk (TSwitch(res_local,cases,edef)) ae.a_expr.etype e1.epos
]) ae.a_expr.etype e1.epos in
forward_transform e ae
and transform_op_assign_op ae e1 op one is_value post =
let e1_ = transform_expr e1 ~is_value:true ~next_id:(Some ae.a_next_id) in
let handle_as_local temp_local =
let ex = ae.a_expr in
let res_var = alloc_var (ae.a_next_id()) ex.etype in
let res_local = {ex with eexpr = TLocal res_var} in
let plus = {ex with eexpr = TBinop(op,temp_local,one)} in
let var_expr = {ex with eexpr = TVar(res_var,Some temp_local)} in
let assign_expr = {ex with eexpr = TBinop(OpAssign,e1_.a_expr,plus)} in
let blocks = if post then
[var_expr;assign_expr;res_local]
else
[assign_expr;temp_local]
in
(* TODO: block is ignored in the else case? *)
let block = e1_.a_blocks @ blocks in
if is_value then begin
let f = exprs_to_func block (ae.a_next_id()) ae in
lift_expr f.a_expr ~is_value:true ~next_id:(Some ae.a_next_id) ~blocks:f.a_blocks
end else begin
let block = e1_.a_blocks @ [assign_expr] in
transform_exprs_to_block block ex.etype false ex.epos ae.a_next_id
end
in
match e1_.a_expr.eexpr with
| TArray({eexpr = TLocal _},{eexpr = TLocal _})
| TField({eexpr = TLocal _},_)
| TLocal _ ->
handle_as_local e1_.a_expr
| TArray(e1,e2) ->
let id = ae.a_next_id() in
let temp_var_l = alloc_var id e1.etype in
let temp_local_l = {e1 with eexpr = TLocal temp_var_l} in
let temp_var_l = {e1 with eexpr = TVar(temp_var_l,Some e1)} in
let id = ae.a_next_id() in
let temp_var_r = alloc_var id e2.etype in
let temp_local_r = {e2 with eexpr = TLocal temp_var_r} in
let temp_var_r = {e2 with eexpr = TVar(temp_var_r,Some e2)} in
let id = ae.a_next_id() in
let temp_var = alloc_var id e1_.a_expr.etype in
let temp_local = {e1_.a_expr with eexpr = TLocal temp_var} in
let temp_var_expr = {e1_.a_expr with eexpr = TArray(temp_local_l,temp_local_r)} in
let temp_var = {e1_.a_expr with eexpr = TVar(temp_var,Some temp_var_expr)} in
let plus = {ae.a_expr with eexpr = TBinop(op,temp_local,one)} in
let assign_expr = {ae.a_expr with eexpr = TBinop(OpAssign,temp_var_expr,plus)} in
let block = e1_.a_blocks @ [temp_var_l;temp_var_r;temp_var;assign_expr;if post then temp_local else temp_var_expr] in
if is_value then begin
let f = exprs_to_func block (ae.a_next_id()) ae in
lift_expr f.a_expr ~is_value:true ~next_id:(Some ae.a_next_id) ~blocks:f.a_blocks
end else
transform_exprs_to_block block ae.a_expr.etype false ae.a_expr.epos ae.a_next_id
| TField(e1,fa) ->
let temp_var_l = alloc_var (ae.a_next_id()) e1.etype in
let temp_local_l = {e1 with eexpr = TLocal temp_var_l} in
let temp_var_l = {e1 with eexpr = TVar(temp_var_l,Some e1)} in
let temp_var = alloc_var (ae.a_next_id()) e1_.a_expr.etype in
let temp_local = {e1_.a_expr with eexpr = TLocal temp_var} in
let temp_var_expr = {e1_.a_expr with eexpr = TField(temp_local_l,fa)} in
let temp_var = {e1_.a_expr with eexpr = TVar(temp_var,Some temp_var_expr)} in
let plus = {ae.a_expr with eexpr = TBinop(op,temp_local,one)} in
let assign_expr = {ae.a_expr with eexpr = TBinop(OpAssign,temp_var_expr,plus)} in
let block = e1_.a_blocks @ [temp_var_l;temp_var;assign_expr;if post then temp_local else temp_var_expr] in
if is_value then begin
let f = exprs_to_func block (ae.a_next_id()) ae in
lift_expr f.a_expr ~is_value:true ~next_id:(Some ae.a_next_id) ~blocks:f.a_blocks
end else
transform_exprs_to_block block ae.a_expr.etype false ae.a_expr.epos ae.a_next_id
| _ ->
debug_expr e1_.a_expr;
assert false
and var_to_treturn_expr ?(capture = false) n t p =
let x = mk (TLocal (to_tvar ~capture:capture n t)) t p in
mk (TReturn (Some x)) t p
and exprs_to_func exprs name base =
let convert_return_expr (expr:texpr) =
match expr.eexpr with
| TWhile(_,_,_) ->
let ret = { expr with eexpr = TReturn (None) } in
[expr; ret]
| TFunction(f) ->
let ret = var_to_treturn_expr name f.tf_type f.tf_expr.epos in
[expr;ret]
| TBinop(OpAssign, l, r) ->
let r = { l with eexpr = TReturn(Some l) } in
[expr; r]
| x ->
let ret_expr = { expr with eexpr = TReturn( Some(expr) )} in
[ret_expr]
in
let def =
(let ex = match exprs with
| [] -> assert false
| [x] ->
(let exs = convert_return_expr x in
match exs with
| [] -> assert false
| [x] -> x
| x ->
match List.rev x with
| x::xs ->
mk (TBlock exs) x.etype base.a_expr.epos
| _ -> assert false)
| x ->
match List.rev x with
| x::xs ->
(let ret = x in
let tail = List.rev xs in
let block = tail @ (convert_return_expr ret) in
match List.rev block with
| x::_ ->
mk (TBlock block) x.etype base.a_expr.epos
| _ -> assert false)
| _ -> assert false
in
let f1 = { tf_args = []; tf_type = TFun([],ex.etype); tf_expr = ex} in
let fexpr = mk (TFunction f1) ex.etype ex.epos in
let fvar = to_tvar name fexpr.etype in
let f = add_non_locals_to_func fexpr in
let assign = { ex with eexpr = TVar(fvar, Some(f))} in
let call_expr = (mk (TLocal fvar) fexpr.etype ex.epos ) in
let substitute = mk (TCall(call_expr, [])) ex.etype ex.epos in
lift_expr ~blocks:[assign] substitute)
in
match exprs with
| [{ eexpr = TFunction({ tf_args = []} as f) } as x] ->
let l = to_tlocal_expr name f.tf_type f.tf_expr.epos in
let substitute = mk (TCall(l, [])) f.tf_type f.tf_expr.epos in
lift_expr ~blocks:[x] substitute
| _ -> def
and transform_call is_value e params ae =
let trans is_value blocks e = transform_expr1 is_value ae.a_next_id blocks e in
let trans1 e params =
let e = trans true [] e in
let blocks = e.a_blocks @ (List.flatten (List.map (fun (p) -> p.a_blocks) params)) in
let params = List.map (fun (p) -> p.a_expr) params in
let e = { ae.a_expr with eexpr = TCall(e.a_expr, params) } in
lift_expr ~blocks:blocks e
in
match e, params with
(* the foreach block should not be handled as a value *)
| ({ eexpr = TField(_, FStatic({cl_path = ["python";],"Syntax"},{ cf_name = "_foreach" }))} as e, [e1;e2;e3]) ->
trans1 e [trans true [] e1; trans true [] e2; trans false [] e3]
| (e, params) ->
trans1 e (List.map (trans true []) params)
and transform1 ae : adjusted_expr =
let trans is_value blocks e = transform_expr1 is_value ae.a_next_id blocks e in
let lift is_value blocks e = lift_expr1 is_value ae.a_next_id blocks e in
let a_expr = ae.a_expr in
match ae.a_is_value,ae.a_expr.eexpr with
| (is_value,TBlock [x]) ->
trans is_value [] x
| (false,TBlock []) ->
lift_expr a_expr
| (true,TBlock []) ->
lift_expr (mk (TConst TNull) ae.a_expr.etype ae.a_expr.epos)
| (false,TBlock el) ->
transform_exprs_to_block el ae.a_expr.etype false ae.a_expr.epos ae.a_next_id
| (true,TBlock el) ->
let name = ae.a_next_id() in
let block,tr = match List.rev el with
| e :: el ->
List.rev ((mk (TReturn (Some e)) t_dynamic e.epos) :: el),e.etype
| [] ->
assert false
in
let my_block = transform_exprs_to_block block tr false ae.a_expr.epos ae.a_next_id in
let fn = mk (TFunction {
tf_args = [];
tf_type = tr;
tf_expr = my_block.a_expr;
}) ae.a_expr.etype ae.a_expr.epos in
let t_var = alloc_var name ae.a_expr.etype in
let f = add_non_locals_to_func fn in
let fn_assign = mk (TVar (t_var,Some f)) ae.a_expr.etype ae.a_expr.epos in
let ev = mk (TLocal t_var) ae.a_expr.etype ae.a_expr.epos in
let substitute = mk (TCall(ev,[])) ae.a_expr.etype ae.a_expr.epos in
lift_expr ~blocks:[fn_assign] substitute
| (is_value,TFunction(f)) ->
transform_function f ae is_value
| (_,TVar(v,None)) ->
transform_var_expr ae None v
| (false, TVar(v,Some({ eexpr = TUnop((Increment | Decrement as unop),post_fix,({eexpr = TLocal _ | TField({eexpr = TConst TThis},_)} as ve))} as e1))) ->
let one = {e1 with eexpr = TConst (TInt (Int32.of_int 1))} in
let op = if unop = Increment then OpAdd else OpSub in
let inc = {e1 with eexpr = TBinop(op,ve,one)} in
let inc_assign = {e1 with eexpr = TBinop(OpAssign,ve,inc)} in
let var_assign = {e1 with eexpr = TVar(v,Some ve)} in
if post_fix = Postfix then
lift true [var_assign] inc_assign
else
lift true [inc_assign] var_assign
| (_,TVar(v,eo)) ->
transform_var_expr ae eo v
| (_,TFor(v,e1,e2)) ->
let a1 = trans true [] e1 in
let a2 = to_expr (trans false [] e2) in
let name = (ae.a_next_id ()) in
let t_var = alloc_var name e1.etype in
let mk_local v p = { eexpr = TLocal v; etype = v.v_type; epos = p } in
let ev = mk_local t_var e1.epos in
let ehasnext = mk (TField(ev,quick_field e1.etype "hasNext")) (tfun [] (!t_bool) ) e1.epos in
let ehasnext = mk (TCall(ehasnext,[])) ehasnext.etype ehasnext.epos in
let enext = mk (TField(ev,quick_field e1.etype "next")) (tfun [] v.v_type) e1.epos in
let enext = mk (TCall(enext,[])) v.v_type e1.epos in
let var_assign = mk (TVar (v,Some enext)) v.v_type a_expr.epos in
let ebody = Type.concat var_assign (a2) in
let var_decl = mk (TVar (t_var,Some a1.a_expr)) (!t_void) e1.epos in
let twhile = mk (TWhile((mk (TParenthesis ehasnext) ehasnext.etype ehasnext.epos),ebody,NormalWhile)) (!t_void) e1.epos in
let blocks = a1.a_blocks @ [var_decl] in
lift_expr ~blocks: blocks twhile
| (_,TReturn None) ->
ae
| (_,TReturn (Some ({eexpr = TFunction f} as ef))) ->
let n = ae.a_next_id() in
let e1 = to_expr (trans false [] f.tf_expr) in
let f = mk (TFunction {
tf_args = f.tf_args;
tf_type = f.tf_type;
tf_expr = e1;
}) ef.etype ef.epos in
let f1 = add_non_locals_to_func f in
let var_n = alloc_var n ef.etype in
let f1_assign = mk (TVar(var_n,Some f1)) !t_void f1.epos in
let var_local = mk (TLocal var_n) ef.etype f1.epos in
let er = mk (TReturn (Some var_local)) t_dynamic ae.a_expr.epos in
lift true [f1_assign] er
| (_,TReturn Some(x)) ->
let x1 = trans true [] x in
(match x1.a_blocks with
| [] ->
lift true [] { ae.a_expr with eexpr = TReturn(Some x1.a_expr) }
| blocks ->
let f = exprs_to_func (blocks @ [x1.a_expr]) (ae.a_next_id()) ae in
lift true f.a_blocks {a_expr with eexpr = TReturn (Some f.a_expr)})
| (_, TParenthesis(e1)) ->
let e1 = trans true [] e1 in
let p = { ae.a_expr with eexpr = TParenthesis(e1.a_expr)} in
lift true e1.a_blocks p
| (_, TEnumParameter(e1,ef,i)) ->
let e1 = trans true [] e1 in
let p = { ae.a_expr with eexpr = TEnumParameter(e1.a_expr,ef,i)} in
lift true e1.a_blocks p
| (true, TIf(econd, eif, eelse)) ->
(let econd1 = trans true [] econd in
let eif1 = trans true [] eif in
let eelse1 = match eelse with
| Some x -> Some(trans true [] x)
| None -> None
in
let blocks = [] in
let eif2, blocks =
match eif1.a_blocks with
| [] -> eif1.a_expr, blocks
| x ->
let regular =
let fname = eif1.a_next_id () in
let f = exprs_to_func (List.append eif1.a_blocks [eif1.a_expr]) fname ae in
f.a_expr, List.append blocks f.a_blocks
in
match eif1.a_blocks with
| [{ eexpr = TVar(_, Some({ eexpr = TFunction(_)}))} as b] ->
eif1.a_expr, List.append blocks [b]
| _ -> regular
in
let eelse2, blocks =
match eelse1 with
| None -> None, blocks
| Some({ a_blocks = []} as x) -> Some(x.a_expr), blocks
| Some({ a_blocks = b} as eelse1) ->
let regular =
let fname = eelse1.a_next_id () in
let f = exprs_to_func (List.append eelse1.a_blocks [eelse1.a_expr]) fname ae in
Some(f.a_expr), List.append blocks f.a_blocks
in
match b with
| [{ eexpr = TVar(_, Some({ eexpr = TFunction(f)}))} as b] ->
Some(eelse1.a_expr), List.append blocks [b]
| _ -> regular
in
let blocks = List.append econd1.a_blocks blocks in
let new_if = { ae.a_expr with eexpr = TIf(econd1.a_expr, eif2, eelse2) } in
match blocks with
| [] ->
let meta = Meta.Custom(":ternaryIf"), [], ae.a_expr.epos in
let ternary = { ae.a_expr with eexpr = TMeta(meta, new_if) } in
lift_expr ~blocks:blocks ternary
| b ->
let f = exprs_to_func (List.append blocks [new_if]) (ae.a_next_id ()) ae in
lift_expr ~blocks:f.a_blocks f.a_expr)
| (false, TIf(econd, eif, eelse)) ->
let econd = trans true [] econd in
let eif = to_expr (trans false [] eif) in
let eelse = match eelse with
| Some(x) -> Some(to_expr (trans false [] x))
| None -> None
in
let new_if = { ae.a_expr with eexpr = TIf(econd.a_expr, eif, eelse) } in
lift false econd.a_blocks new_if
| (false, TWhile(econd, e1, NormalWhile)) ->
let econd1 = trans true [] econd in
let e11 = to_expr (trans false [] e1) in
let new_while = mk (TWhile(econd1.a_expr,e11,NormalWhile)) a_expr.etype a_expr.epos in
lift false econd1.a_blocks new_while
| (true, TWhile(econd, ebody, NormalWhile)) ->
let econd = trans true [] econd in
let ebody = to_expr (trans false [] ebody) in
let ewhile = { ae.a_expr with eexpr = TWhile(econd.a_expr, ebody, NormalWhile) } in
let eval = { ae.a_expr with eexpr = TConst(TNull) } in
let f = exprs_to_func (List.append econd.a_blocks [ewhile; eval]) (ae.a_next_id ()) ae in
lift true f.a_blocks f.a_expr
| (false, TWhile(econd, ebody, DoWhile)) ->
let not_expr = { econd with eexpr = TUnop(Not, Prefix, econd) } in
let break_expr = mk TBreak !t_void econd.epos in
let if_expr = mk (TIf(not_expr, break_expr, None)) (!t_void) econd.epos in
let new_e = match ebody.eexpr with
| TBlock(exprs) -> { econd with eexpr = TBlock( List.append exprs [if_expr]) }
| _ -> { econd with eexpr = TBlock( List.append [ebody] [if_expr]) }
in
let true_expr = mk (TConst(TBool(true))) econd.etype ae.a_expr.epos in
let new_expr = { ae.a_expr with eexpr = TWhile( true_expr, new_e, NormalWhile) } in
forward_transform new_expr ae
| (is_value, TSwitch(e, cases, edef)) ->
begin match follow e.etype with
| TInst({cl_path = [],"str"},_) ->
transform_string_switch ae is_value e cases edef
| _ ->
transform_switch ae is_value e cases edef
end
(* anon field access on optional params *)
| (is_value, TField(e,FAnon cf)) when Meta.has Meta.Optional cf.cf_meta ->
let e = dynamic_field_read e cf.cf_name in
transform_expr ~is_value:is_value e
| (is_value, TBinop(OpAssign,{eexpr = TField(e1,FAnon cf)},e2)) when Meta.has Meta.Optional cf.cf_meta ->
let e = dynamic_field_write e1 cf.cf_name e2 in
transform_expr ~is_value:is_value e
| (is_value, TBinop(OpAssignOp op,{eexpr = TField(e1,FAnon cf)},e2)) when Meta.has Meta.Optional cf.cf_meta ->
let e = dynamic_field_read_write ae.a_next_id e1 cf.cf_name op e2 in
transform_expr ~is_value:is_value e
(* TODO we need to deal with Increment, Decrement too!
| (_, TUnop( (Increment | Decrement) as unop, op,{eexpr = TField(e1,FAnon cf)})) when Meta.has Meta.Optional cf.cf_meta ->
let = dynamic_field_read e cf.cf_name in
let e = dynamic_field_read_write_unop ae.a_next_id e1 cf.cf_name unop op in
Printf.printf "dyn read write\n";
transform_expr e
*)
(*
anon field access with non optional members like iterator, length, split must be handled too, we need to Reflect on them too when it's a runtime method
*)
| (is_value, TUnop( (Increment | Decrement) as unop, op, e)) ->
let one = { ae.a_expr with eexpr = TConst(TInt(Int32.of_int(1)))} in
let is_postfix = match op with
| Postfix -> true
| Prefix -> false in
let op = match unop with
| Increment -> OpAdd
| Decrement -> OpSub
| _ -> assert false in
transform_op_assign_op ae e op one is_value is_postfix
| (_, TUnop(op, Prefix, e)) ->
let e1 = trans true [] e in
let r = { a_expr with eexpr = TUnop(op, Prefix, e1.a_expr) } in
lift_expr ~blocks:e1.a_blocks r
| (is_value, TField(e,FDynamic s)) ->
let e = dynamic_field_read e s in
transform_expr ~is_value:is_value e
| (is_value, TBinop(OpAssign,{eexpr = TField(e1,FDynamic s)},e2)) ->
let e = dynamic_field_write e1 s e2 in
transform_expr ~is_value:is_value e
| (is_value, TBinop(OpAssignOp op,{eexpr = TField(e1,FDynamic s)},e2)) ->
let e = dynamic_field_read_write ae.a_next_id e1 s op e2 in
transform_expr ~is_value:is_value e
| (is_value, TField(e1, FClosure(Some ({cl_path = [],("str" | "list")},_),cf))) ->
let e = dynamic_field_read e1 cf.cf_name in
transform_expr ~is_value:is_value e
| (is_value, TBinop(OpAssign, left, right))->
(let left = trans true [] left in
let right = trans true [] right in
let r = { a_expr with eexpr = TBinop(OpAssign, left.a_expr, right.a_expr)} in
if is_value then
(let blocks = List.concat [left.a_blocks; right.a_blocks; [r]] in
let f = exprs_to_func blocks (ae.a_next_id ()) ae in
lift true f.a_blocks f.a_expr)
else
lift false (List.append left.a_blocks right.a_blocks) r)
| (is_value, TBinop(OpAssignOp(x), left, right)) ->
let right = trans true [] right in
let v = right.a_expr in
let res = transform_op_assign_op ae left x v is_value false in
lift true (List.append right.a_blocks res.a_blocks) res.a_expr
| (_, TBinop(op, left, right))->
(let left = trans true [] left in
let right = trans true [] right in
let r = { a_expr with eexpr = TBinop(op, left.a_expr, right.a_expr)} in
lift false (List.append left.a_blocks right.a_blocks) r)
| (true, TThrow(x)) ->
let block = TBlock([a_expr; { a_expr with eexpr = TConst(TNull) }]) in
let r = { a_expr with eexpr = block } in
forward_transform r ae
| (false, TThrow(x)) ->
let x = trans true [] x in
let r = { a_expr with eexpr = TThrow(x.a_expr)} in
lift false x.a_blocks r
| (_, TNew(c, tp, params)) ->
let params = List.map (trans true []) params in
let blocks = List.flatten (List.map (fun (p) -> p.a_blocks) params) in
let params = List.map (fun (p) -> p.a_expr) params in
let e = { a_expr with eexpr = TNew(c, tp, params) } in
lift false blocks e
| (is_value, TCall(e,params)) ->
transform_call is_value e params ae
| (_, TArray(e1, e2)) ->
let e1 = trans true [] e1 in
let e2 = trans true [] e2 in
let r = { a_expr with eexpr = TArray(e1.a_expr, e2.a_expr)} in
let blocks = List.append e1.a_blocks e2.a_blocks in
lift_expr ~blocks:blocks r
| (false, TTry(etry, catches)) ->
let etry = trans false [] etry in
let catches = List.map (fun(v,e) -> v, trans false [] e) catches in
let blocks = List.flatten (List.map (fun (_,e) -> e.a_blocks) catches) in
let catches = List.map (fun(v,e) -> v, e.a_expr) catches in
let r = { a_expr with eexpr = TTry(etry.a_expr, catches)} in
let blocks = List.append etry.a_blocks blocks in
lift false blocks r
| (true, TTry(etry, catches)) ->
let id = ae.a_next_id () in
let temp_var = to_tvar id a_expr.etype in
let temp_var_def = { a_expr with eexpr = TVar(temp_var, None) } in
let temp_local = { a_expr with eexpr = TLocal(temp_var)} in
let mk_temp_assign right = { a_expr with eexpr = TBinop(OpAssign, temp_local, right)} in
let etry = mk_temp_assign etry in
let catches = List.map (fun (v,e)-> v, mk_temp_assign e) catches in
let new_try = { a_expr with eexpr = TTry(etry, catches)} in
let block = [temp_var_def; new_try; temp_local] in
let new_block = { a_expr with eexpr = TBlock(block)} in
forward_transform new_block ae
| (_, TObjectDecl(fields)) ->
let fields = List.map (fun (name,ex) -> name, trans true [] ex) fields in
let blocks = List.flatten (List.map (fun (_,ex) -> ex.a_blocks) fields) in
let fields = List.map (fun (name,ex) -> name, ex.a_expr) fields in
let r = { a_expr with eexpr = (TObjectDecl(fields) )} in
lift_expr ~blocks r
| (_, TArrayDecl(values)) ->
let values = List.map (trans true []) values in
let blocks = List.flatten (List.map (fun (v) -> v.a_blocks) values) in
let exprs = List.map (fun (v) -> v.a_expr) values in
let r = { a_expr with eexpr = TArrayDecl exprs } in
lift_expr ~blocks:blocks r
| (is_value, TCast(e1,Some mt)) ->
let e = Codegen.default_cast ~vtmp:(ae.a_next_id()) (match !como with Some com -> com | None -> assert false) e1 mt ae.a_expr.etype ae.a_expr.epos in
transform_expr ~is_value:is_value e
| (is_value, TCast(e,None)) ->
let e = trans is_value [] e in
let r = { a_expr with eexpr = TCast(e.a_expr, None)} in
lift_expr ~blocks:e.a_blocks r
| (_, TField(e,f)) ->
let e = trans true [] e in
let r = { a_expr with eexpr = TField(e.a_expr, f) } in
lift_expr ~blocks:e.a_blocks r
| (is_value, TMeta(m, e)) ->
let e = trans is_value [] e in
let r = { a_expr with eexpr = TMeta(m, e.a_expr); etype = e.a_expr.etype } in
lift_expr ~blocks:e.a_blocks r
| ( _, TLocal _ ) -> lift_expr a_expr
| ( _, TConst _ ) -> lift_expr a_expr
| ( _, TTypeExpr _ ) -> lift_expr a_expr
| ( _, TUnop _ ) -> assert false
| ( true, TWhile(econd, ebody, DoWhile) ) ->
let new_expr = trans false [] a_expr in
let f = exprs_to_func (new_expr.a_blocks @ [new_expr.a_expr]) (ae.a_next_id()) ae in
lift_expr ~is_value:true ~blocks:f.a_blocks f.a_expr
| ( _, TBreak ) | ( _, TContinue ) ->
lift_expr a_expr
and transform e =
to_expr (transform1 (lift_expr e))
and forward_transform e base =
transform1 (lift_expr1 base.a_is_value base.a_next_id base.a_blocks e)
let transform_to_value e =
to_expr (transform1 (lift_expr e ~is_value:true))
end
module Printer = struct
type print_context = {
pc_indent : string;
pc_next_anon_func : unit -> string;
pc_debug : bool;
pc_com : Common.context;
}
let has_feature pctx = Common.has_feature pctx.pc_com
let add_feature pctx = Common.add_feature pctx.pc_com
let create_context =
let n = ref (-1) in
(fun indent com debug -> {
pc_indent = indent;
pc_next_anon_func = (fun () -> incr n; Printf.sprintf "anon_%i" !n);
pc_debug = debug;
pc_com = com;
}
)
let tabs = ref ""
let opt o f s = match o with
| None -> ""
| Some v -> s ^ (f v)
(* TODO: both of these are crazy *)
let is_type p t =
(fun r ->
let x = t_infos r in
(String.concat "." (fst x.mt_path)) = p && (snd x.mt_path) = t
)
let is_type1 p s =
(fun t -> match follow t with
| TInst(c,_) -> (is_type p s)(TClassDecl c)
| TAbstract(a,_) -> (is_type p s)(TAbstractDecl a)
| TEnum(en,_) -> (is_type p s)(TEnumDecl en)
| _ -> false
)
let is_underlying_string t = match follow t with
| TAbstract(a,tl) -> (is_type1 "" "str")(Abstract.get_underlying_type a tl)
| _ -> false
let is_underlying_array t = match follow t with
| TAbstract(a,tl) -> (is_type1 "" "list")(Abstract.get_underlying_type a tl)
| _ -> false
let rec is_anon_or_dynamic t = match follow t with
| TAbstract(a,tl) ->
is_anon_or_dynamic (Abstract.get_underlying_type a tl)
| TAnon _ | TDynamic _ -> true
| _ -> false
let handle_keywords s =
KeywordHandler.handle_keywords s
let print_unop = function
| Increment | Decrement -> assert false
| Not -> "not "
| Neg -> "-";
| NegBits -> "~"
let print_binop = function
| OpAdd -> "+"
| OpSub -> "-"
| OpMult -> "*"
| OpDiv -> "/"
| OpAssign -> "="
| OpEq -> "=="
| OpNotEq -> "!="
| OpGt -> ">"
| OpGte -> ">="
| OpLt -> "<"
| OpLte -> "<="
| OpAnd -> "&"
| OpOr -> "|"
| OpXor -> "^"
| OpBoolAnd -> "and"
| OpBoolOr -> "or"
| OpShl -> "<<"
| OpShr -> ">>"
| OpUShr -> ">>"
| OpMod -> "%"
| OpInterval | OpArrow | OpAssignOp _ -> assert false
let print_string s =
Printf.sprintf "\"%s\"" (Ast.s_escape s)
let print_constant = function
| TThis -> "self"
| TNull -> "None"
| TBool(true) -> "True"
| TBool(false) -> "False"
| TString(s) -> print_string s
| TInt(i) -> Int32.to_string i
| TFloat s -> s
| TSuper -> "super"
let print_base_type tp =
try
begin match Meta.get Meta.Native tp.mt_meta with
| _,[EConst(String s),_],_ -> s
| _ -> raise Not_found
end
with Not_found ->
let pack,name = tp.mt_path in
(String.concat "_" pack) ^ (if pack = [] then name else "_" ^ name)
let print_module_type mt = print_base_type (t_infos mt)
let print_metadata (name,_,_) =
Printf.sprintf "@%s" name
let rec remove_outer_parens e = match e.eexpr with
| TParenthesis(e) -> remove_outer_parens e
| TMeta((Meta.Custom ":ternaryIf",_,_),_) -> e
| TMeta(_,e) -> remove_outer_parens e
| _ -> e
let print_args args p =
let had_value = ref false in
let had_var_args = ref false in
let had_kw_args = ref false in
let sl = List.map (fun (v,cto) ->
let check_err () = if !had_var_args || !had_kw_args then error "Arguments after KwArgs/VarArgs are not allowed" p in
KeywordHandler.check_var_declaration v;
let name = handle_keywords v.v_name in
match follow v.v_type with
| TAbstract({a_path = ["python"],"KwArgs"},_) ->
if !had_kw_args then error "Arguments after KwArgs are not allowed" p;
had_kw_args := true;
"**" ^ name
| TAbstract({a_path = ["python"],"VarArgs"},_) ->
check_err ();
had_var_args := true;
"*" ^ name
| _ ->
check_err ();
name ^ match cto with
| None when !had_value -> " = None"
| None -> ""
| Some ct ->
had_value := true;
Printf.sprintf " = %s" (print_constant ct)
) args in
String.concat "," sl
let rec print_op_assign_right pctx e =
match e.eexpr with
| TIf({eexpr = TParenthesis econd},eif,Some eelse)
| TIf(econd,eif,Some eelse) ->
Printf.sprintf "%s if %s else %s" (print_expr pctx eif) (print_expr pctx econd) (print_expr pctx eelse)
| _ ->
print_expr pctx (remove_outer_parens e)
and print_var pctx v eo =
match eo with
| Some ({eexpr = TFunction tf} as e) ->
print_function pctx tf (Some v.v_name) e.epos
| _ ->
let s_init = match eo with
| None -> "None"
| Some e -> print_op_assign_right pctx e
in
Printf.sprintf "%s = %s" (handle_keywords v.v_name) s_init
and print_function pctx tf name p =
let s_name = match name with
| None -> pctx.pc_next_anon_func()
| Some s -> handle_keywords s
in
let s_args = print_args tf.tf_args p in
let s_expr = print_expr {pctx with pc_indent = "\t" ^ pctx.pc_indent} tf.tf_expr in
Printf.sprintf "def %s(%s):\n%s\t%s" s_name s_args pctx.pc_indent s_expr
and print_tarray_list pctx e1 e2 =
let s1 = (print_expr pctx e1) in
let s2 = (print_expr pctx e2) in
let default = Printf.sprintf "python_internal_ArrayImpl._get(%s, %s)" s1 s2 in
let handle_index =
match e2.eexpr with
| TConst TInt index ->
if Int32.to_int index >= 0 then
Printf.sprintf "(%s[%s] if %s < len(%s) else None)" s1 s2 s2 s1
else
"None"
| TLocal _ ->
Printf.sprintf "(%s[%s] if %s >= 0 and %s < len(%s) else None)" s1 s2 s2 s2 s1
| _ ->
default
in
match e1.eexpr with
| TLocal _ -> handle_index
| TField ({eexpr=(TConst TThis | TLocal _)},_) -> handle_index
| _ -> default
and is_safe_string pctx x =
let follow_parens e = match e.eexpr with
| TParenthesis e -> e
| _ -> e
in
match (follow_parens x).eexpr with
| TBinop(OpAdd, e1, e2) -> is_safe_string pctx e1 && is_safe_string pctx e2
| TCall (e1,_) ->
let id = print_expr pctx (follow_parens e1) in
(match id with
| "Std.string" -> true
| _ -> false)
| TConst (TString s) -> true
| _ -> false
and print_expr pctx e =
let indent = pctx.pc_indent in
let print_expr_indented e = print_expr {pctx with pc_indent = "\t" ^ pctx.pc_indent} e in
match e.eexpr with
| TConst ct ->
print_constant ct
| TTypeExpr mt ->
print_module_type mt
| (TLocal v | TParenthesis({ eexpr = (TLocal v) })) ->
handle_keywords v.v_name
| TEnumParameter(e1,_,index) ->
Printf.sprintf "%s.params[%i]" (print_expr pctx e1) index
| TArray(e1,e2) when (is_type1 "" "list")(e1.etype) || is_underlying_array e1.etype ->
print_tarray_list pctx e1 e2
| TArray({etype = t} as e1,e2) when is_anon_or_dynamic t ->
Printf.sprintf "HxOverrides.arrayGet(%s, %s)" (print_expr pctx e1) (print_expr pctx e2)
| TArray(e1,e2) ->
Printf.sprintf "%s[%s]" (print_expr pctx e1) (print_expr pctx e2)
| TBinop(OpAssign, {eexpr = TArray(e1,e2)}, e3) when (is_type1 "" "list")(e1.etype) || is_underlying_array e1.etype ->
Printf.sprintf "python_internal_ArrayImpl._set(%s, %s, %s)" (print_expr pctx e1) (print_expr pctx e2) (print_expr pctx e3)
| TBinop(OpAssign,{eexpr = TArray({etype = t} as e1,e2)},e3) when is_anon_or_dynamic t ->
Printf.sprintf "HxOverrides.arraySet(%s,%s,%s)" (print_expr pctx e1) (print_expr pctx e2) (print_expr pctx e3)
| TBinop(OpAssign,{eexpr = TArray(e1,e2)},e3) ->
Printf.sprintf "%s[%s] = %s" (print_expr pctx e1) (print_expr pctx e2) (print_expr pctx (remove_outer_parens e3) )
| TBinop(OpAssign,{eexpr = TField(ef1,fa)},e2) ->
Printf.sprintf "%s = %s" (print_field pctx ef1 fa true) (print_op_assign_right pctx e2)
| TBinop(OpAssign,e1,e2) ->
Printf.sprintf "%s = %s" (print_expr pctx e1) (print_expr pctx (remove_outer_parens e2))
| TBinop(op,e1,({eexpr = TBinop(_,_,_)} as e2)) ->
print_expr pctx { e with eexpr = TBinop(op, e1, { e2 with eexpr = TParenthesis(e2) })}
| TBinop(OpEq,{eexpr = TCall({eexpr = TLocal {v_name = "__typeof__"}},[e1])},e2) ->
begin match e2.eexpr with
| TConst(TString s) ->
begin match s with
| "string" -> Printf.sprintf "Std._hx_is(%s, str)" (print_expr pctx e1)
| "boolean" -> Printf.sprintf "Std._hx_is(%s, bool)" (print_expr pctx e1)
| "number" -> Printf.sprintf "Std._hx_is(%s, float)" (print_expr pctx e1)
| _ -> assert false
end
| _ ->
assert false
end
| TBinop(OpEq,e1,({eexpr = TConst TNull} as e2)) ->
Printf.sprintf "(%s is %s)" (print_expr pctx e1) (print_expr pctx e2)
| TBinop(OpNotEq,e1,({eexpr = TConst TNull} as e2)) ->
Printf.sprintf "(%s is not %s)" (print_expr pctx e1) (print_expr pctx e2)
| TBinop(OpEq|OpNotEq as op,e1, e2) ->
let ops = match op with
| OpEq -> "is", "==", "HxOverrides.eq"
| OpNotEq -> "is not", "!=", "not HxOverrides.eq"
| _ -> assert false
in
let third (_,_,x) = x in
let fst (x,_,_) = x in
let snd (_,x,_) = x in
let is_list_or_anon x = begin match x with
| TInst({cl_path = [],("list")},_) -> true
| TAnon _ -> true
| _ -> false
end in
let is_const_byte x =
match x.eexpr with
| TConst TInt x ->
let x = Int32.to_int x in
x >= 0 && x <= 256
| _ -> false
in
(match follow e1.etype, follow e2.etype with
| TAbstract({a_path = [],("Int")}, _),TAbstract({a_path = [],("Int")}, _) when is_const_byte e2 || is_const_byte e1 ->
Printf.sprintf "(%s %s %s)" (print_expr pctx e1) (snd ops) (print_expr pctx e2)
(* the following optimization causes a problem with polygonal unit tests
see: https://github.com/HaxeFoundation/haxe/issues/2952
*)
(* Printf.sprintf "(%s %s %s)" (print_expr pctx e1) (fst ops) (print_expr pctx e2) *)
| TInst({cl_path = [],("list")},_), _ ->
Printf.sprintf "(%s %s %s)" (print_expr pctx e1) (fst ops) (print_expr pctx e2)
| TDynamic _, TDynamic _ ->
Printf.sprintf "%s(%s,%s)" (third ops) (print_expr pctx e1) (print_expr pctx e2)
| TDynamic _, x | x, TDynamic _ when is_list_or_anon x ->
Printf.sprintf "%s(%s,%s)" (third ops) (print_expr pctx e1) (print_expr pctx e2)
| _,_ -> Printf.sprintf "(%s %s %s)" (print_expr pctx e1) (snd ops) (print_expr pctx e2))
| TBinop(OpMod,e1,e2) when (is_type1 "" "Int")(e1.etype) && (is_type1 "" "Int")(e2.etype) ->
(match e1.eexpr with
| TConst(TInt(x)) when (Int32.to_int x) >= 0 ->
(* constant optimization *)
Printf.sprintf "%s %% %s" (print_expr pctx e1) (print_expr pctx e2)
| _ ->
Printf.sprintf "HxOverrides.mod(%s, %s)" (print_expr pctx e1) (print_expr pctx e2))
| TBinop(OpMod,e1,e2) ->
Printf.sprintf "HxOverrides.modf(%s, %s)" (print_expr pctx e1) (print_expr pctx e2)
| TBinop(OpUShr,e1,e2) ->
Printf.sprintf "HxOverrides.rshift(%s, %s)" (print_expr pctx e1) (print_expr pctx e2)
| TBinop(OpAdd,e1,e2) when (is_type1 "" "str")(e.etype) || is_underlying_string e.etype ->
let rec safe_string ex =
match ex.eexpr, ex.etype with
| e, _ when is_safe_string pctx ex -> print_expr pctx ex
| TBinop(OpAdd, e1, e2), x when (is_type1 "" "str")(x) -> Printf.sprintf "(%s + %s)" (safe_string e1) (safe_string e2)
| (TLocal(_)),x when (is_type1 "" "str")(x) ->
(*
we could add this pattern too, but is it sideeffect free??
| TField({ eexpr = TLocal(_)},_)
*)
let s = (print_expr pctx ex) in
Printf.sprintf "(\"null\" if %s is None else %s)" s s
| _,x when (is_type1 "" "str")(x) -> Printf.sprintf "HxOverrides.stringOrNull(%s)" (print_expr pctx ex)
| _,_ ->
if has_feature pctx "Std.string" then
Printf.sprintf "Std.string(%s)" (print_expr pctx ex)
else
Printf.sprintf "str(%s)" (print_expr pctx ex)
in
let e1_str = safe_string e1 in
let e2_str = safe_string e2 in
Printf.sprintf "(%s + %s)" e1_str e2_str
| TBinop(OpAdd,e1,e2) when (match follow e.etype with TDynamic _ -> true | _ -> false) ->
Printf.sprintf "python_Boot._add_dynamic(%s,%s)" (print_expr pctx e1) (print_expr pctx e2)
| TBinop(op,e1,e2) ->
Printf.sprintf "(%s %s %s)" (print_expr pctx e1) (print_binop op) (print_expr pctx e2)
| TField(e1,fa) ->
print_field pctx e1 fa false
| TParenthesis e1 ->
Printf.sprintf "(%s)" (print_expr pctx e1)
| TObjectDecl fl ->
let fl2 = ref fl in
begin match follow e.etype with
| TAnon an ->
PMap.iter (fun s cf ->
if not (List.mem_assoc s fl) then fl2 := (s,null cf.cf_type cf.cf_pos) :: !fl2
) an.a_fields
| _ ->
()
end;
Printf.sprintf "_hx_AnonObject(%s)" (print_exprs_named pctx ", " !fl2)
| TArrayDecl el ->
Printf.sprintf "[%s]" (print_exprs pctx ", " el)
| TCall(e1,el) ->
print_call pctx e1 el e
| TNew(c,_,el) ->
let id = print_base_type (t_infos (TClassDecl c)) in
Printf.sprintf "%s(%s)" id (print_exprs pctx ", " el)
| TUnop(Not,Prefix,e1) ->
Printf.sprintf "(%s%s)" (print_unop Not) (print_expr pctx e1)
| TUnop(op,Prefix,e1) ->
Printf.sprintf "%s%s" (print_unop op) (print_expr pctx e1)
| TFunction tf ->
print_function pctx tf None e.epos
| TVar (v,eo) ->
KeywordHandler.check_var_declaration v;
print_var pctx v eo
| TBlock [] ->
Printf.sprintf "pass"
| TBlock [{ eexpr = TBlock _} as b] ->
print_expr pctx b
| TBlock el ->
let old = !tabs in
tabs := pctx.pc_indent;
let s = print_block_exprs pctx ("\n" ^ !tabs) pctx.pc_debug el in
tabs := old;
Printf.sprintf "%s" s
| TIf(econd,eif,(Some {eexpr = TIf _} as eelse)) ->
print_if_else pctx econd eif eelse true
| TIf(econd,eif,eelse) ->
print_if_else pctx econd eif eelse false
| TWhile(econd,e1,NormalWhile) ->
Printf.sprintf "while %s:\n%s\t%s" (print_expr pctx (remove_outer_parens econd)) indent (print_expr_indented e1)
| TWhile(econd,e1,DoWhile) ->
error "Currently not supported" e.epos
| TTry(e1,catches) ->
print_try pctx e1 catches
| TReturn eo ->
Printf.sprintf "return%s" (opt eo (print_op_assign_right pctx) " ")
| TBreak ->
"break"
| TContinue ->
"continue"
| TThrow e1 ->
let rec is_native_exception t =
match Abstract.follow_with_abstracts t with
| TInst ({ cl_path = [],"BaseException" }, _) ->
true
| TInst ({ cl_super = Some csup }, _) ->
is_native_exception (TInst(fst csup, snd csup))
| _ ->
false
in
if is_native_exception e1.etype then
Printf.sprintf "raise %s" (print_expr pctx e1)
else
Printf.sprintf "raise _HxException(%s)" (print_expr pctx e1)
| TCast(e1,None) ->
print_expr pctx e1
| TMeta((Meta.Custom ":ternaryIf",_,_),{eexpr = TIf(econd,eif,Some eelse)}) ->
Printf.sprintf "(%s if %s else %s)" (print_expr pctx eif) (print_expr pctx econd) (print_expr pctx eelse)
| TMeta(_,e1) ->
print_expr pctx e1
| TSwitch _ | TCast(_, Some _) | TFor _ | TUnop(_,Postfix,_) ->
assert false
and print_if_else pctx econd eif eelse as_elif =
let econd1 = match econd.eexpr with
| TParenthesis e -> e
| _ -> econd
in
let if_str = print_expr {pctx with pc_indent = "\t" ^ pctx.pc_indent} eif in
let indent = pctx.pc_indent in
let else_str = if as_elif then
opt eelse (print_expr pctx) "el"
else
opt eelse (print_expr {pctx with pc_indent = "\t" ^ pctx.pc_indent}) (Printf.sprintf "else:\n%s\t" indent)
in
let else_str = if else_str = "" then "" else "\n" ^ indent ^ else_str in
Printf.sprintf "if %s:\n%s\t%s%s" (print_expr pctx (remove_outer_parens econd1)) indent if_str else_str
and print_field pctx e1 fa is_assign =
let obj = match e1.eexpr with
| TConst TSuper -> "super()"
| _ -> print_expr pctx e1
in
let name = field_name fa in
let is_extern = (match fa with
| FInstance(c,_,_) -> c.cl_extern
| FStatic(c,_) -> c.cl_extern
| _ -> false)
in
let do_default () =
Printf.sprintf "%s.%s" obj (if is_extern then name else (handle_keywords name))
in
let call_override s =
match s with
| "iterator" | "toUpperCase" | "toLowerCase" | "pop" | "shift" | "join" | "push" | "map" | "filter" -> true
| _ -> false
in
match fa with
(* we need to get rid of these cases in the transformer, how is this handled in js *)
| FInstance(c,_,{cf_name = "length"}) when (is_type "" "list")(TClassDecl c) ->
Printf.sprintf "len(%s)" (print_expr pctx e1)
| FInstance(c,_,{cf_name = "length"}) when (is_type "" "str")(TClassDecl c) ->
Printf.sprintf "len(%s)" (print_expr pctx e1)
| FStatic(c,{cf_name = "fromCharCode"}) when (is_type "" "str")(TClassDecl c) ->
Printf.sprintf "HxString.fromCharCode"
| FStatic({cl_path = ["python";"internal"],"UBuiltins"},{cf_name = s}) ->
s
| FInstance _ | FStatic _ ->
do_default ()
| FAnon cf when is_assign && call_override(name) ->
begin match follow cf.cf_type with
| TFun([],_) ->
Printf.sprintf "python_lib_FuncTools.partial(HxOverrides.%s, %s)" name obj
| _ ->
do_default()
end
| _ ->
do_default()
and print_try pctx e1 catches =
let has_catch_all = List.exists (fun (v,_) -> match v.v_type with
| TDynamic _ -> true
| _ -> false
) catches in
let has_only_catch_all = has_catch_all && begin match catches with
| [_] -> true
| _ -> false
end in
let print_catch pctx i (v,e) =
KeywordHandler.check_var_declaration v;
let is_empty_expr = begin match e.eexpr with
| TBlock [] -> true
| _ -> false
end in
let indent = pctx.pc_indent in
(* Don't generate assignment to catch variable when catch expression is an empty block *)
let assign = if is_empty_expr then "" else Printf.sprintf "%s = _hx_e1\n%s" v.v_name indent in
let handle_base_type bt =
let t = print_base_type bt in
let print_type_check t_str =
Printf.sprintf "if isinstance(_hx_e1, %s):\n%s\t%s\t%s" t_str indent assign (print_expr {pctx with pc_indent = "\t" ^ pctx.pc_indent} e)
in
let res = match t with
| "str" -> print_type_check "str"
| "Bool" -> print_type_check "bool"
| "Int" -> print_type_check "int"
| "Float" -> print_type_check "float"
| t -> print_type_check t
in
if i > 0 then
indent ^ "el" ^ res
else
res
in
match follow v.v_type with
| TDynamic _ ->
begin if has_only_catch_all then
Printf.sprintf "%s%s" assign (print_expr pctx e)
else
(* Dynamic is always the last block *)
Printf.sprintf "%selse:\n\t%s%s\t%s" indent indent assign (print_expr {pctx with pc_indent = "\t" ^ pctx.pc_indent} e)
end
| TInst(c,_) ->
handle_base_type (t_infos (TClassDecl c))
| TEnum(en,_) ->
handle_base_type (t_infos (TEnumDecl en))
| TAbstract(a,_) ->
handle_base_type (t_infos (TAbstractDecl a))
| _ ->
assert false
in
let indent = pctx.pc_indent in
let print_expr_indented e = print_expr {pctx with pc_indent = "\t" ^ pctx.pc_indent} e in
let try_str = Printf.sprintf "try:\n%s\t%s\n%s" indent (print_expr_indented e1) indent in
let except = if has_feature pctx "has_throw" then
Printf.sprintf "except Exception as _hx_e:\n%s\t_hx_e1 = _hx_e.val if isinstance(_hx_e, _HxException) else _hx_e\n%s\t" indent indent
else
Printf.sprintf "except Exception as _hx_e:\n%s\t_hx_e1 = _hx_e\n%s\t" indent indent
in
let catch_str = String.concat (Printf.sprintf "\n") (ExtList.List.mapi (fun i catch -> print_catch {pctx with pc_indent = "\t" ^ pctx.pc_indent} i catch) catches) in
let except_end = if not has_catch_all then Printf.sprintf "\n%s\telse:\n%s\t\traise _hx_e" indent indent else "" in
Printf.sprintf "%s%s%s%s" try_str except catch_str except_end
and print_call2 pctx e1 el =
let id = print_expr pctx e1 in
match id,el with
| "__define_feature__",[_;e] ->
print_expr pctx e
| "super",_ ->
let s_el = (print_call_args pctx e1 el) in
Printf.sprintf "super().__init__(%s)" s_el
| ("python_Syntax._pythonCode"),[({ eexpr = TConst (TString code) } as ecode); {eexpr = TArrayDecl tl}] ->
let exprs = Array.of_list tl in
let i = ref 0 in
let err msg =
let pos = { ecode.epos with pmin = ecode.epos.pmin + !i } in
error msg pos
in
let regex = Str.regexp "[{}]" in
let rec loop m = match m with
| [] -> ""
| Str.Text txt :: tl ->
i := !i + String.length txt;
txt ^ (loop tl)
| Str.Delim a :: Str.Delim b :: tl when a = b ->
i := !i + 2;
a ^ (loop tl)
| Str.Delim "{" :: Str.Text n :: Str.Delim "}" :: tl ->
(try
let expr = Array.get exprs (int_of_string n) in
let txt = print_expr pctx expr in
i := !i + 2 + String.length n;
txt ^ (loop tl)
with | Failure "int_of_string" ->
err ("Index expected. Got " ^ n)
| Invalid_argument _ ->
err ("Out-of-bounds pythonCode special parameter: " ^ n))
| Str.Delim x :: _ ->
err ("Unexpected " ^ x)
in
loop (Str.full_split regex code)
| ("python_Syntax._pythonCode"), [e] ->
print_expr pctx e
| "python_Syntax._callNamedUntyped",el ->
let res,fields = match List.rev el with
| {eexpr = TObjectDecl fields} :: el ->
List.rev el,fields
| _ ->
assert false
in
begin match res with
| e1 :: [] ->
Printf.sprintf "%s(%s)" (print_expr pctx e1) (print_params_named pctx ", " fields)
| e1 :: el ->
Printf.sprintf "%s(%s, %s)" (print_expr pctx e1) (print_exprs pctx ", " el) (print_params_named pctx ", " fields)
| [] ->
Printf.sprintf "%s(%s)" (print_expr pctx e1) (print_params_named pctx ", " fields)
end
| "python_Syntax.varArgs",[e1] ->
"*" ^ (print_expr pctx e1)
| "python_Syntax.call" ,e1 :: [{eexpr = TArrayDecl el}]->
Printf.sprintf "%s(%s)" (print_expr pctx e1) (print_exprs pctx ", " el)
| "python_Syntax.field",[e1;{eexpr = TConst(TString id)}] ->
Printf.sprintf "%s.%s" (print_expr pctx e1) id
| "python_Syntax._tuple", [{eexpr = TArrayDecl el}] ->
(match el with
| [e] ->
Printf.sprintf "(%s,)" (print_expr pctx e)
| _ ->
Printf.sprintf "(%s)" (print_exprs pctx ", " el))
| "python_Syntax._arrayAccess", e1 :: {eexpr = TArrayDecl el} :: etrail ->
let trailing_colon = match etrail with
| [{eexpr = TConst(TBool(true))}] -> true
| _ -> false
in
Printf.sprintf "%s[%s%s]" (print_expr pctx e1) (print_exprs pctx ":" el) (if trailing_colon then ":" else "")
| "python_Syntax.isIn",[e1;e2] ->
Printf.sprintf "%s in %s" (print_expr pctx e1) (print_expr pctx e2)
| "python_Syntax.delete",[e1] ->
Printf.sprintf "del %s" (print_expr pctx e1)
| "python_Syntax.binop",[e0;{eexpr = TConst(TString id)};e2] ->
Printf.sprintf "(%s %s %s)" (print_expr pctx e0) id (print_expr pctx e2)
| "python_Syntax.assign",[e0;e1] ->
Printf.sprintf "%s = %s" (print_expr pctx e0) (print_expr pctx e1)
| "python_Syntax.arraySet",[e1;e2;e3] ->
Printf.sprintf "%s[%s] = %s" (print_expr pctx e1) (print_expr pctx e2) (print_expr pctx e3)
| "python_Syntax._newInstance", e1 :: [{eexpr = TArrayDecl el}] ->
Printf.sprintf "%s(%s)" (print_expr pctx e1) (print_exprs pctx ", " el)
| "python_Syntax.opPow", [e1;e2] ->
Printf.sprintf "(%s ** %s)" (print_expr pctx e1) (print_expr pctx e2)
| "python_Syntax._foreach",[e1;e2;e3] ->
let pctx = {pctx with pc_indent = "\t" ^ pctx.pc_indent} in
let i = pctx.pc_indent in
Printf.sprintf "for %s in %s:\n%s%s" (print_expr pctx e1) (print_expr pctx e2) i (print_expr pctx e3)
| _,el ->
Printf.sprintf "%s(%s)" id (print_call_args pctx e1 el)
and print_call pctx e1 el call_expr =
let get_native_fields t = match follow t with
| TAnon(a) ->
let fold f cf acc =
if Meta.has Meta.Native cf.cf_meta then begin
let _, args, mp = Meta.get Meta.Native cf.cf_meta in
match args with
| [( EConst(String s),_)] -> PMap.add f s acc
| _ -> acc
end else acc
in
let mapping = PMap.foldi fold a.a_fields PMap.empty in
mapping
| _ -> PMap.empty
in
let native_fields_str native_fields =
let fold_dict k v acc =
let prefix = if acc = "" then "" else "," in
Printf.sprintf "%s%s\"%s\":\"%s\"" acc prefix (handle_keywords k) v
in
PMap.foldi fold_dict native_fields ""
in
match e1.eexpr, el with
| TLocal { v_name = "`trace" }, [e;infos] ->
if has_feature pctx "haxe.Log.trace" then begin
"haxe_Log.trace(" ^ (print_expr pctx e) ^ "," ^ (print_expr pctx infos) ^ ")"
end else if is_safe_string pctx e then
"print(" ^ (print_expr pctx e) ^ ")"
else
"print(str(" ^ (print_expr pctx e) ^ "))"
| TField(e1,((FAnon {cf_name = (("join" | "push" | "map" | "filter") as s)}) | FDynamic (("join" | "push" | "map" | "filter") as s))), [x] ->
Printf.sprintf "HxOverrides.%s(%s, %s)" s (print_expr pctx e1) (print_expr pctx x)
| TField(e1,((FAnon {cf_name = (("iterator" | "toUpperCase" | "toLowerCase" | "pop" | "shift") as s)}) | FDynamic (("iterator" | "toUpperCase" | "toLowerCase" | "pop" | "shift") as s))), [] ->
Printf.sprintf "HxOverrides.%s(%s)" s (print_expr pctx e1)
| TField(_, (FStatic({cl_path = ["python"; "_KwArgs"], "KwArgs_Impl_"},{ cf_name="fromT" }))), [e2] ->
let t = match follow call_expr.etype with
| TAbstract(_, [t]) -> t
| _ -> assert false
in
let native_fields = get_native_fields t in
if PMap.is_empty native_fields then
print_call2 pctx e1 el
else
let s1 = native_fields_str native_fields in
Printf.sprintf "python__KwArgs_KwArgs_Impl_.fromT(HxOverrides.mapKwArgs(%s, {%s}))" (print_expr pctx e2) s1
| TField(_, (FStatic({cl_path = ["python"; "_KwArgs"], "KwArgs_Impl_"},{ cf_name="toDictHelper" }))), [e2; et] ->
let native_fields = get_native_fields et.etype in
if PMap.is_empty native_fields then
print_call2 pctx e1 el
else
let s1 = native_fields_str native_fields in
Printf.sprintf "python__KwArgs_KwArgs_Impl_.toDictHelper(HxOverrides.reverseMapKwArgs(%s, {%s}), None)" (print_expr pctx e2) s1
| _,_ ->
print_call2 pctx e1 el
and print_call_args pctx e1 el =
let print_arg pctx i x =
let e = match x.eexpr, follow x.etype with
| TConst TNull, TAbstract({a_path = ["python"],"KwArgs"},_) -> "{}"
| TConst TNull, TAbstract({a_path = ["python"],"VarArgs"},_) -> "[]"
| _ -> (print_expr pctx x)
in
let prefix = match e1.eexpr, follow x.etype with
(* the should not apply for the instance methods of the abstract itself *)
| TField(_, FStatic({cl_path = ["python"; "_KwArgs"],"KwArgs_Impl_"},f)), _ when i == 0 && Meta.has Meta.Impl f.cf_meta -> ""
| TField(_, FStatic({cl_path = ["python"; "_VarArgs"],"VarArgs_Impl_"},f)), _ when i == 0 && Meta.has Meta.Impl f.cf_meta -> ""
| _, TAbstract({a_path = ["python"],"KwArgs"},_) -> "**"
| _, TAbstract({a_path = ["python"],"VarArgs"},_) -> "*"
| _, _ -> ""
in
prefix ^ e
in
String.concat "," (ExtList.List.mapi (print_arg pctx) el)
and print_exprs pctx sep el =
String.concat sep (List.map (print_expr pctx) el)
and last_debug_comment = ref ("")
and print_block_exprs pctx sep print_debug_comment el =
if print_debug_comment then begin
let el = List.fold_left (fun acc e ->
let line = Lexer.get_error_line e.epos in
let debug_line = (Printf.sprintf "# %s:%i" e.epos.pfile line) in
let res = if (!last_debug_comment) <> debug_line then
(print_expr pctx e) :: debug_line :: acc
else
(print_expr pctx e) :: acc
in
last_debug_comment := debug_line;
res
) [] el in
String.concat sep (List.rev el)
end else
print_exprs pctx sep el
and print_exprs_named pctx sep fl =
let args = String.concat sep (List.map (fun (s,e) -> Printf.sprintf "'%s': %s" (handle_keywords s) (print_expr pctx e)) fl) in
Printf.sprintf "{%s}" args
and print_params_named pctx sep fl =
let args = String.concat sep (List.map (fun (s,e) -> Printf.sprintf "%s= %s" (handle_keywords s) (print_expr pctx e)) fl) in
Printf.sprintf "%s" args
let handle_keywords s =
KeywordHandler.handle_keywords s
end
module Generator = struct
type context = {
com : Common.context;
buf : Buffer.t;
packages : (string,int) Hashtbl.t;
mutable static_inits : (unit -> unit) list;
mutable class_inits : (unit -> unit) list;
mutable indent_count : int;
transform_time : float;
print_time : float;
}
let has_feature ctx = Common.has_feature ctx.com
let add_feature ctx = Common.add_feature ctx.com
type class_field_infos = {
cfd_fields : string list;
cfd_props : string list;
cfd_methods : string list;
}
type import_type =
| IModule of string
| IObject of string * string
let mk_context com = {
com = com;
buf = Buffer.create 16000;
packages = Hashtbl.create 0;
static_inits = [];
class_inits = [];
indent_count = 0;
transform_time = 0.;
print_time = 0.;
}
(* Transformer interface *)
let transform_expr e =
(* let e = Codegen.UnificationCallback.run Transformer.check_unification e in *)
Transformer.transform e
let transform_to_value e =
(* let e = Codegen.UnificationCallback.run Transformer.check_unification e in *)
Transformer.transform_to_value e
(* Printer interface *)
let get_path mt =
Printer.print_base_type mt
let tfunc_str f pctx name p =
Printer.print_function pctx f name p
let texpr_str e pctx =
Printer.print_expr pctx e
let handle_keywords s =
Printer.handle_keywords s
(* Helper *)
let get_full_name mt =
(* TODO: haxe source is crazy *)
s_type_path mt.mt_path
let collect_class_field_data cfl =
let fields = DynArray.create () in
let props = DynArray.create () in
let methods = DynArray.create () in
List.iter (fun cf ->
match cf.cf_kind with
| Var({v_read = AccResolve}) ->
()
| Var _ when is_extern_field cf ->
()
| Var({v_read = AccCall}) ->
if Meta.has Meta.IsVar cf.cf_meta then
DynArray.add fields cf.cf_name
else
DynArray.add props cf.cf_name
| Var _ ->
DynArray.add fields cf.cf_name
| _ ->
DynArray.add methods cf.cf_name
) cfl;
{
cfd_fields = DynArray.to_list fields;
cfd_props = DynArray.to_list props;
cfd_methods = DynArray.to_list methods;
}
let collect_class_statics_data cfl =
let fields = DynArray.create () in
List.iter (fun cf ->
if not (is_extern_field cf) then
DynArray.add fields cf.cf_name
) cfl;
DynArray.to_list fields
let filter_py_metas metas =
List.filter (fun (n,_,_) -> match n with Meta.Custom ":python" -> true | _ -> false) metas
let get_members_with_init_expr c =
List.filter (fun cf -> match cf.cf_kind with
| Var _ when is_extern_field cf -> false
| Var _ when cf.cf_expr = None -> true
| _ -> false
) c.cl_ordered_fields
(* Printing *)
let spr ctx s =
Buffer.add_string ctx.buf s
let spr_line ctx s =
Buffer.add_string ctx.buf s;
Buffer.add_string ctx.buf "\n"
let print ctx =
Printf.kprintf (fun s -> begin
Buffer.add_string ctx.buf s
end)
let newline ctx =
if not (Buffer.length ctx.buf = 0) then spr ctx "\n"
(* Generating functions *)
let gen_py_metas ctx metas indent =
List.iter (fun (n,el,_) ->
match el with
| [EConst(String s),_] ->
print ctx "%s@%s\n" indent s
| _ ->
assert false
) metas
let gen_expr ctx e field indent =
let pctx = Printer.create_context ("\t" ^ indent) ctx.com ctx.com.debug in
let e = match e.eexpr with
| TFunction(f) ->
{e with eexpr = TBlock [e]}
| _ ->
e
in
let expr2 = transform_to_value e in
let name = "_hx_init_" ^ (String.concat "_" (ExtString.String.nsplit field ".")) in
let maybe_split_expr expr2 = match expr2.eexpr with
| TBlock es when es <> [] && field <> "" ->
begin match List.rev es with
| e_last :: el ->
let new_last = {e_last with eexpr = TReturn (Some e_last)} in
let new_block = {expr2 with eexpr = TBlock (List.rev (new_last :: el))} in
let v_name = alloc_var name (tfun [] e_last.etype) in
let f_name = mk (TLocal v_name) v_name.v_type e_last.epos in
let call_f = mk (TCall(f_name,[])) e_last.etype e_last.epos in
Some new_block,call_f
| _ ->
assert false
end
| _ ->
None,expr2
in
let r = maybe_split_expr expr2 in
match r with
| Some e1,e2 ->
let expr_string_1 = texpr_str e1 pctx in
let expr_string_2 = texpr_str e2 pctx in
print ctx "%sdef %s():\n\t%s" indent name expr_string_1;
newline ctx;
print ctx "%s%s = %s" indent field expr_string_2;
| None,e2 ->
let expr_string_2 = texpr_str e2 pctx in
if field = "" then
spr ctx expr_string_2
else
print ctx "%s%s = %s" indent field expr_string_2
let gen_func_expr ctx e c name metas extra_args indent stat p =
let pctx = Printer.create_context indent ctx.com ctx.com.debug in
let e = match e.eexpr with
| TFunction(f) ->
let args = List.map (fun s ->
alloc_var s t_dynamic,None
) extra_args in
{e with eexpr = TFunction {f with tf_args = args @ f.tf_args}}
| _ ->
e
in
if stat then begin
newline ctx;
spr ctx indent;
spr ctx "@staticmethod\n"
end;
let expr1 = transform_expr e in
let expr_string = match expr1.eexpr with
| TFunction f ->
tfunc_str f pctx (Some name) p
| _ ->
Printf.sprintf "%s = %s" name (texpr_str expr1 pctx)
in
gen_py_metas ctx metas indent;
spr ctx indent;
spr ctx expr_string
let gen_class_constructor ctx c cf =
let member_inits = get_members_with_init_expr c in
let py_metas = filter_py_metas cf.cf_meta in
begin match cf.cf_expr with
| Some ({eexpr = TFunction f} as ef) ->
let ethis = mk (TConst TThis) (TInst(c,List.map snd c.cl_params)) cf.cf_pos in
let member_data = List.map (fun cf ->
let ef = mk (TField(ethis,FInstance(c,[],cf))) cf.cf_type cf.cf_pos in (* TODO *)
mk (TBinop(OpAssign,ef,null ef.etype ef.epos)) ef.etype ef.epos
) member_inits in
let e = concat (mk (TBlock member_data) ctx.com.basic.tvoid cf.cf_pos) f.tf_expr in
let ef = {ef with eexpr = TFunction {f with tf_expr = e}} in
cf.cf_expr <- Some ef;
newline ctx;
newline ctx;
gen_func_expr ctx ef c "__init__" py_metas ["self"] "\t" false cf.cf_pos
| _ ->
assert false
end
let gen_class_field ctx c p cf =
let field = handle_keywords cf.cf_name in
begin match cf.cf_expr with
| None ->
()(* print ctx "\t# var %s" field *)
| Some e ->
newline ctx;
newline ctx;
begin match cf.cf_kind with
| Method _ ->
let py_metas = filter_py_metas cf.cf_meta in
gen_func_expr ctx e c field py_metas ["self"] "\t" false cf.cf_pos;
| _ ->
gen_expr ctx e (Printf.sprintf "# var %s" field) "\t";
end
end
let gen_class_empty_constructor ctx p cfl =
if has_feature ctx "Type.createEmptyInstance" then begin
newline ctx;
newline ctx;
print ctx "\t@staticmethod\n\tdef _hx_empty_init(_hx_o):";
let found_fields = ref false in
List.iter (fun cf -> match cf.cf_kind with
| Var ({v_read = AccResolve | AccCall}) ->
()
| Var _ ->
found_fields := true;
newline ctx;
print ctx "\t\t_hx_o.%s = None" (handle_keywords cf.cf_name)
| _ ->
()
) cfl;
if not !found_fields then
spr ctx "\t\tpass"
end else begin
newline ctx
end
let gen_class_statics ctx c p =
let methods, other = List.partition (fun cf ->
match cf.cf_kind with
| Method _ -> (match cf.cf_expr with Some _ -> true | _ -> false)
| _ -> false
) c.cl_ordered_statics in
(* generate non methods *)
let has_empty_static_vars = ref false in
List.iter (fun cf ->
let p = get_path (t_infos (TClassDecl c)) in
let field = handle_keywords cf.cf_name in
match cf.cf_expr with
| None ->
has_empty_static_vars := true;
newline ctx;
print ctx "\t%s = None" field
| Some e ->
(let f = fun () ->
newline ctx;
gen_expr ctx e (Printf.sprintf "%s.%s" p field) "";
in
ctx.static_inits <- f :: ctx.static_inits)
) other;
(* generate static methods *)
let has_static_methods = ref false in
List.iter (fun cf ->
has_static_methods := true;
let field = handle_keywords cf.cf_name in
let py_metas = filter_py_metas cf.cf_meta in
let e = match cf.cf_expr with Some e -> e | _ -> assert false in
newline ctx;
gen_func_expr ctx e c field py_metas [] "\t" true cf.cf_pos;
) methods;
!has_static_methods || !has_empty_static_vars
let gen_class_init ctx c =
match c.cl_init with
| None ->
()
| Some e ->
let is_math = c.cl_path = ([], "Math") in
let math_feature = has_feature ctx "Math" in
let f = if is_math && not math_feature then
fun () -> ()
else fun () ->
let e = transform_expr e in
newline ctx;
spr ctx (texpr_str e (Printer.create_context "" ctx.com ctx.com.debug));
in
ctx.class_inits <- f :: ctx.class_inits
let gen_class ctx c =
if not c.cl_extern then begin
let is_nativegen = Meta.has Meta.NativeGen c.cl_meta in
let mt = (t_infos (TClassDecl c)) in
let p = get_path mt in
let p_name = get_full_name mt in
let x = collect_class_field_data c.cl_ordered_fields in
let p_super = match c.cl_super with
| None ->
None
| Some (csup,_) ->
Some (get_path (t_infos (TClassDecl csup)))
in
let p_interfaces = List.map (fun (c,tl) ->
get_path (t_infos (TClassDecl c))
) c.cl_implements in
newline ctx;
newline ctx;
newline ctx;
print ctx "class %s" p;
(match p_super with Some p -> print ctx "(%s)" p | _ -> ());
spr ctx ":";
let use_pass = ref true in
if not is_nativegen then begin
if has_feature ctx "python._hx_class_name" then begin
use_pass := false;
print ctx "\n\t_hx_class_name = \"%s\"" p_name
end;
let print_field names field quote =
if has_feature ctx ("python." ^ field) then try
let q s = if quote then "\"" ^ s ^ "\"" else s in
let s = match names with
| [] when (match c.cl_super with Some _ -> false | _ -> true) ->
(* always overwrite parent's class fields *)
raise Exit
| _ ->
"[" ^ (String.concat ", " (List.map q names)) ^ "]"
in
use_pass := false;
print ctx "\n\t%s = %s" field s
with Exit -> ()
in
print_field x.cfd_fields "_hx_fields" true;
print_field x.cfd_methods "_hx_methods" true;
(* TODO: It seems strange to have a separation for member fields but a plain _hx_statics for static ones *)
print_field (collect_class_statics_data c.cl_ordered_statics) "_hx_statics" true;
print_field (p_interfaces) "_hx_interfaces" false;
if has_feature ctx "python._hx_super" then (match p_super with
| None -> ()
| Some ps ->
use_pass := false;
print ctx "\n\t_hx_super = %s\n" ps
);
end;
begin match c.cl_constructor with
| Some cf -> gen_class_constructor ctx c cf;
| None -> ()
end;
List.iter (fun cf -> gen_class_field ctx c p cf) c.cl_ordered_fields;
let has_inner_static = gen_class_statics ctx c p in
let has_empty_constructor = match ((Meta.has Meta.NativeGen c.cl_meta) || c.cl_interface), c.cl_ordered_fields with
| true,_
| _, [] ->
false
| _ ->
gen_class_empty_constructor ctx p c.cl_ordered_fields;
has_feature ctx "Type.createEmptyInstance"
in
let use_pass = !use_pass && (not has_inner_static) && (not has_empty_constructor) && match x.cfd_methods with
| [] -> c.cl_constructor = None
| _ -> c.cl_interface
in
if use_pass then spr ctx "\n\tpass";
if not is_nativegen then begin
if has_feature ctx "python._hx_class" then print ctx "\n%s._hx_class = %s" p p;
if has_feature ctx "python._hx_classes" then print ctx "\n_hx_classes[\"%s\"] = %s" p_name p;
end
end;
gen_class_init ctx c
let gen_enum_metadata ctx en p =
let meta = Codegen.build_metadata ctx.com (TEnumDecl en) in
match meta with
| None ->
()
| Some e ->
newline ctx;
print ctx "%s.__meta__ = " p;
gen_expr ctx e "" ""
let gen_enum ctx en =
let mt = (t_infos (TEnumDecl en)) in
let p = get_path mt in
let p_name = get_full_name mt in
let enum_constructs = PMap.foldi (fun k ef acc -> ef :: acc) en.e_constrs [] in
let enum_constructs = List.sort (fun a b -> if a.ef_index < b.ef_index then -1 else if a.ef_index > b.ef_index then 1 else 0) enum_constructs in
newline ctx;
newline ctx;
print ctx "class %s(Enum):" p;
let use_pass = ref true in
if has_feature ctx "python._hx_class_name" then begin
use_pass := false;
print ctx "\n\t_hx_class_name = \"%s\"" p_name
end;
if has_feature ctx "python._hx_constructs" then begin
let fix = match enum_constructs with [] -> "" | _ -> "\"" in
let enum_constructs_str = fix ^ (String.concat ("\", \"") (List.map (fun ef -> ef.ef_name) enum_constructs)) ^ fix in
use_pass := false;
print ctx "\n\t_hx_constructs = [%s]" enum_constructs_str;
end;
let const_constructors,param_constructors = List.partition (fun ef ->
match follow ef.ef_type with
| TFun(_,_) -> false
| _ -> true
) enum_constructs in
List.iter (fun ef ->
match follow ef.ef_type with
| TFun(args, _) ->
let print_args args =
let had_optional = ref false in
let sl = List.map (fun (n,o,_) ->
let name = handle_keywords n in
let arg_value = if !had_optional then
"= None"
else if o then begin
had_optional := true;
" = None"
end else
""
in
Printf.sprintf "%s%s" name arg_value
) args in
String.concat "," sl
in
let f = handle_keywords ef.ef_name in
let param_str = print_args args in
let args_str = String.concat "," (List.map (fun (n,_,_) -> handle_keywords n) args) in
newline ctx;
newline ctx;
print ctx "\t@staticmethod\n\tdef %s(%s):\n" f param_str;
print ctx "\t\treturn %s(\"%s\", %i, [%s])" p ef.ef_name ef.ef_index args_str;
use_pass := false;
| _ -> assert false
) param_constructors;
if !use_pass then spr ctx "\n\tpass";
List.iter (fun ef ->
(* TODO: haxe source has api.quoteString for ef.ef_name *)
let f = handle_keywords ef.ef_name in
newline ctx;
print ctx "%s.%s = %s(\"%s\", %i, list())" p f p ef.ef_name ef.ef_index
) const_constructors;
if has_feature ctx "python._hx_class" then print ctx "\n%s._hx_class = %s" p p;
if has_feature ctx "python._hx_classes" then print ctx "\n_hx_classes[\"%s\"] = %s" p_name p;
gen_enum_metadata ctx en p
let gen_abstract ctx a =
newline ctx;
newline ctx;
newline ctx;
let mt = (t_infos (TAbstractDecl a)) in
let p = get_path mt in
let p_name = get_full_name mt in
print ctx "class %s:" p;
let use_pass = ref true in
if has_feature ctx "python._hx_class_name" then begin
use_pass := false;
print ctx "\n\t_hx_class_name = \"%s\"" p_name
end;
(match a.a_impl with
| Some c ->
List.iter (fun cf ->
use_pass := false;
if cf.cf_name = "_new" then
gen_class_constructor ctx c cf
else
gen_class_field ctx c p cf
) c.cl_ordered_statics
| None -> ());
if !use_pass then spr ctx "\n\tpass";
if has_feature ctx "python._hx_class" then print ctx "\n%s._hx_class = %s" p p;
if has_feature ctx "python._hx_classes" then print ctx "\n_hx_classes[\"%s\"] = %s" p_name p
let gen_type ctx mt = match mt with
| TClassDecl c -> gen_class ctx c
| TEnumDecl en when not en.e_extern -> gen_enum ctx en
| TAbstractDecl {a_path = [],"UInt"} -> ()
| TAbstractDecl {a_path = [],"Enum"} -> ()
| TAbstractDecl {a_path = [],"EnumValue"} when not (has_feature ctx "has_enum") -> ()
| TAbstractDecl {a_path = [],"Void"} -> ()
| TAbstractDecl {a_path = [],"Int"} when not (has_feature ctx "Int.*") -> ()
| TAbstractDecl {a_path = [],"Float"} when not (has_feature ctx "Float.*") -> ()
| TAbstractDecl {a_path = [],"Class"} when not (has_feature ctx "Class.*") -> ()
| TAbstractDecl {a_path = [],"Dynamic"} when not (has_feature ctx "Dynamic.*") -> ()
| TAbstractDecl {a_path = [],"Bool"} when not (has_feature ctx "Bool.*") -> ()
| TAbstractDecl a when Meta.has Meta.CoreType a.a_meta -> gen_abstract ctx a
| _ -> ()
(* Generator parts *)
let gen_resources ctx =
if Hashtbl.length ctx.com.resources > 0 then begin
let slash_index = try (String.rindex ctx.com.file '/')+1 with Not_found -> 0 in
let len = String.length ctx.com.file - slash_index in
let file_name = String.sub ctx.com.file slash_index len in
newline ctx;
newline ctx;
newline ctx;
spr ctx "def _hx_resources__():";
spr ctx "\n\timport inspect";
spr ctx "\n\timport sys";
spr ctx "\n\tif not hasattr(sys.modules[__name__], '__file__'):";
print ctx "\n\t\t_file = '%s'" file_name;
spr ctx "\n\telse:";
spr ctx "\n\t\t_file = __file__";
spr ctx "\n\treturn {";
let first = ref true in
Hashtbl.iter (fun k v ->
let prefix = if !first then begin
first := false;
"";
end else
","
in
let k_enc = Codegen.escape_res_name k false in
print ctx "%s\"%s\": open('%%s.%%s'%%(_file,'%s'),'rb').read()" prefix (Ast.s_escape k) k_enc;
Std.output_file (ctx.com.file ^ "." ^ k_enc) v
) ctx.com.resources;
spr ctx "}"
end
let gen_imports ctx =
let import path meta =
if Meta.has Meta.PythonImport meta && is_directly_used ctx.com meta then begin
let _, args, mp = Meta.get Meta.PythonImport meta in
let class_name = match path with
| [],name -> name
| path,name -> (ExtString.String.join "_" path) ^ "_" ^ name
in
let import_type,ignore_error = match args with
| [(EConst(String(module_name)), _)]
| [(EConst(String(module_name)), _); (EBinop(OpAssign, (EConst(Ident("ignoreError")),_), (EConst(Ident("false")),_)),_)] ->
IModule module_name, false
| [(EConst(String(module_name)), _); (EBinop(OpAssign, (EConst(Ident("ignoreError")),_), (EConst(Ident("true")),_)),_)] ->
IModule module_name,true
| [(EConst(String(module_name)), _); (EConst(String(object_name)), _)]
| [(EConst(String(module_name)), _); (EConst(String(object_name)), _); (EBinop(OpAssign, (EConst(Ident("ignoreError")),_), (EConst(Ident("false")),_)),_)] ->
IObject (module_name,object_name), false
| [(EConst(String(module_name)), _); (EConst(String(object_name)), _); (EBinop(OpAssign, (EConst(Ident("ignoreError")),_), (EConst(Ident("true")),_)),_)] ->
IObject (module_name,object_name), true
| _ ->
error "Unsupported @:pythonImport format" mp
in
let import = match import_type with
| IModule module_name ->
(* importing whole module *)
"import " ^ module_name ^ " as " ^ class_name
| IObject (module_name,object_name) ->
if String.contains object_name '.' then
(* importing nested class *)
"import " ^ module_name ^ " as _hx_temp_import; " ^ class_name ^ " = _hx_temp_import." ^ object_name ^ "; del _hx_temp_import"
else
(* importing a class from a module *)
"from " ^ module_name ^ " import " ^ object_name ^ " as " ^ class_name
in
newline ctx;
if ignore_error then begin
spr ctx "try:\n\t";
spr_line ctx import;
spr ctx "except:\n\tpass"
end else
spr ctx import
end
in
List.iter (fun mt ->
match mt with
| TClassDecl c when c.cl_extern -> import c.cl_path c.cl_meta
| TEnumDecl e when e.e_extern -> import e.e_path e.e_meta
| _ -> ()
) ctx.com.types
let gen_types ctx =
let used_paths = Hashtbl.create 0 in
let find_type path =
Hashtbl.add used_paths path true;
Utils.find_type ctx.com path
in
let need_anon_for_trace = (has_feature ctx "has_anon_trace") && (has_feature ctx "haxe.Log.trace") in
if (has_feature ctx "has_anon") || (has_feature ctx "_hx_AnonObject") || need_anon_for_trace then begin
let with_body = (has_feature ctx "has_anon") || need_anon_for_trace in
newline ctx;
newline ctx;
newline ctx;
spr ctx "class _hx_AnonObject:\n";
if with_body then begin
spr ctx "\tdef __init__(self, fields):\n";
spr ctx "\t\tself.__dict__ = fields"
end else
spr ctx "\tpass";
Hashtbl.add used_paths ([],"_hx_AnonObject") true;
end;
if has_feature ctx "python._hx_classes" then begin
newline ctx;
newline ctx;
newline ctx;
spr ctx "_hx_classes = {}";
end;
if has_feature ctx "Boot.*" then
gen_type ctx (find_type (["python"],"Boot"));
if has_feature ctx "has_enum" || has_feature ctx "Enum.*" then
gen_type ctx (find_type ([],"Enum"));
if has_feature ctx "HxOverrides.*" then
gen_type ctx (find_type ([],"HxOverrides"));
List.iter (fun mt ->
if not (Hashtbl.mem used_paths (t_infos mt).mt_path) then
gen_type ctx mt
) ctx.com.types
let gen_static_inits ctx =
newline ctx;
List.iter (fun f -> f()) (List.rev ctx.static_inits)
let gen_class_inits ctx =
newline ctx;
List.iter (fun f -> f()) (List.rev ctx.class_inits)
let gen_main ctx =
match ctx.com.main with
| None ->
()
| Some e ->
newline ctx;
newline ctx;
gen_expr ctx e "" ""
(* Entry point *)
let run com =
Transformer.init com;
let ctx = mk_context com in
gen_imports ctx;
gen_resources ctx;
gen_types ctx;
gen_class_inits ctx;
gen_static_inits ctx;
gen_main ctx;
mkdir_from_path com.file;
let ch = open_out_bin com.file in
output_string ch (Buffer.contents ctx.buf);
close_out ch
end
let generate com =
Generator.run com
|