codegen.ml 4.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151
  1. (*
  2. The Haxe Compiler
  3. Copyright (C) 2005-2019 Haxe Foundation
  4. This program is free software; you can redistribute it and/or
  5. modify it under the terms of the GNU General Public License
  6. as published by the Free Software Foundation; either version 2
  7. of the License, or (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  15. *)
  16. open Ast
  17. open Type
  18. open Globals
  19. open Extlib_leftovers
  20. (* -------------------------------------------------------------------------- *)
  21. (* TOOLS *)
  22. let rec has_properties c =
  23. List.exists (fun f ->
  24. match f.cf_kind with
  25. | Var { v_read = AccCall } -> true
  26. | Var { v_write = AccCall } -> true
  27. | _ when Meta.has Meta.Accessor f.cf_meta -> true
  28. | _ -> false
  29. ) c.cl_ordered_fields || (match c.cl_super with Some (c,_) -> has_properties c | _ -> false)
  30. let get_properties fields =
  31. List.fold_left (fun acc f ->
  32. if Meta.has Meta.Accessor f.cf_meta then
  33. (f.cf_name, f.cf_name) :: acc
  34. else
  35. let acc = (match f.cf_kind with
  36. | Var { v_read = AccCall } -> ("get_" ^ f.cf_name , "get_" ^ f.cf_name) :: acc
  37. | _ -> acc) in
  38. match f.cf_kind with
  39. | Var { v_write = AccCall } -> ("set_" ^ f.cf_name , "set_" ^ f.cf_name) :: acc
  40. | _ -> acc
  41. ) [] fields
  42. (* -------------------------------------------------------------------------- *)
  43. (* MISC FEATURES *)
  44. let rec is_volatile t =
  45. match t with
  46. | TMono r ->
  47. (match r.tm_type with
  48. | Some t -> is_volatile t
  49. | _ -> false)
  50. | TLazy f ->
  51. is_volatile (lazy_type f)
  52. | TType (t,tl) ->
  53. (match t.t_path with
  54. | _ -> is_volatile (apply_typedef t tl))
  55. | _ ->
  56. false
  57. let bytes_serialize data =
  58. let b64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" in
  59. let tbl = Array.init (String.length b64) (fun i -> String.get b64 i) in
  60. Bytes.unsafe_to_string (Base64.str_encode ~tbl data)
  61. (*
  62. Build a default safe-cast expression :
  63. { var $t = <e>; if( Std.is($t,<t>) ) $t else throw "Class cast error"; }
  64. *)
  65. let default_cast ?(vtmp="$t") api std e texpr t p =
  66. let vtmp = alloc_var VGenerated vtmp e.etype e.epos in
  67. let var = mk (TVar (vtmp,Some e)) api.tvoid p in
  68. let vexpr = mk (TLocal vtmp) e.etype p in
  69. let texpr = Texpr.Builder.make_typeexpr texpr p in
  70. let is = Texpr.Builder.resolve_and_make_static_call std "isOfType" [vexpr;texpr] p in
  71. let enull = Texpr.Builder.make_null vexpr.etype p in
  72. let eop = Texpr.Builder.binop OpEq vexpr enull api.tbool p in
  73. let echeck = Texpr.Builder.binop OpBoolOr is eop api.tbool p in
  74. let exc = mk (TThrow (mk (TConst (TString "Class cast error")) api.tstring p)) t p in
  75. let check = mk (TIf (Texpr.Builder.mk_parent echeck,mk (TCast (vexpr,None)) t p,Some exc)) t p in
  76. mk (TBlock [var;check;vexpr]) t p
  77. module UnificationCallback = struct
  78. let check_call_params f el tl =
  79. let rec loop acc el tl = match el,tl with
  80. | e :: el, (n,_,t) :: tl ->
  81. loop ((f e t) :: acc) el tl
  82. | [], [] ->
  83. acc
  84. | [],_ ->
  85. acc
  86. | e :: el, [] ->
  87. loop (e :: acc) el []
  88. in
  89. List.rev (loop [] el tl)
  90. let check_call f el t = match follow t with
  91. | TFun(args,_) ->
  92. check_call_params f el args
  93. | _ ->
  94. List.map (fun e -> f e t_dynamic) el
  95. end;;
  96. let interpolate_code error code tl f_string f_expr p =
  97. let exprs = Array.of_list tl in
  98. let i = ref 0 in
  99. let err msg =
  100. let pos = { p with pmin = p.pmin + !i } in
  101. error msg pos
  102. in
  103. let regex = Str.regexp "[{}]" in
  104. let rec loop m = match m with
  105. | [] ->
  106. ()
  107. | Str.Text txt :: tl ->
  108. i := !i + String.length txt;
  109. f_string txt;
  110. loop tl
  111. | Str.Delim "{" :: Str.Text n :: Str.Delim "}" :: tl ->
  112. begin try
  113. let expr = Array.get exprs (int_of_string n) in
  114. f_expr expr;
  115. with
  116. | Failure _ ->
  117. f_string ("{" ^ n ^ "}");
  118. | Invalid_argument _ ->
  119. err ("Out-of-bounds special parameter: " ^ n)
  120. end;
  121. i := !i + 2 + String.length n;
  122. loop tl
  123. | Str.Delim x :: tl ->
  124. f_string x;
  125. incr i;
  126. loop tl
  127. in
  128. loop (Str.full_split regex code)
  129. (* Static extensions for classes *)
  130. module ExtClass = struct
  131. let add_static_init c cf e p =
  132. let ethis = Texpr.Builder.make_static_this c p in
  133. let ef1 = mk (TField(ethis,FStatic(c,cf))) cf.cf_type p in
  134. let e_assign = mk (TBinop(OpAssign,ef1,e)) e.etype p in
  135. TClass.add_cl_init c e_assign
  136. end