|
@@ -9,6 +9,47 @@ type field_source =
|
|
| ClassMember of tclass
|
|
| ClassMember of tclass
|
|
| CLassConstructor of tclass
|
|
| CLassConstructor of tclass
|
|
|
|
|
|
|
|
+let rec binop_index op = match op with
|
|
|
|
+ | OpAdd -> 0
|
|
|
|
+ | OpMult -> 1
|
|
|
|
+ | OpDiv -> 2
|
|
|
|
+ | OpSub -> 3
|
|
|
|
+ | OpAssign -> 4
|
|
|
|
+ | OpEq -> 5
|
|
|
|
+ | OpNotEq -> 6
|
|
|
|
+ | OpGt -> 7
|
|
|
|
+ | OpGte -> 8
|
|
|
|
+ | OpLt -> 9
|
|
|
|
+ | OpLte -> 10
|
|
|
|
+ | OpAnd -> 11
|
|
|
|
+ | OpOr -> 12
|
|
|
|
+ | OpXor -> 13
|
|
|
|
+ | OpBoolAnd -> 14
|
|
|
|
+ | OpBoolOr -> 15
|
|
|
|
+ | OpShl -> 16
|
|
|
|
+ | OpShr -> 17
|
|
|
|
+ | OpUShr -> 18
|
|
|
|
+ | OpMod -> 19
|
|
|
|
+ | OpInterval -> 20
|
|
|
|
+ | OpArrow -> 21
|
|
|
|
+ | OpIn -> 22
|
|
|
|
+ | OpNullCoal -> 23
|
|
|
|
+ | OpAssignOp op -> 30 + binop_index op
|
|
|
|
+
|
|
|
|
+let unop_index op flag = match op,flag with
|
|
|
|
+ | Increment,Prefix -> 0
|
|
|
|
+ | Decrement,Prefix -> 1
|
|
|
|
+ | Not,Prefix -> 2
|
|
|
|
+ | Neg,Prefix -> 3
|
|
|
|
+ | NegBits,Prefix -> 4
|
|
|
|
+ | Spread,Prefix -> 5
|
|
|
|
+ | Increment,Postfix -> 6
|
|
|
|
+ | Decrement,Postfix -> 7
|
|
|
|
+ | Not,Postfix -> 8
|
|
|
|
+ | Neg,Postfix -> 9
|
|
|
|
+ | NegBits,Postfix -> 10
|
|
|
|
+ | Spread,Postfix -> 11
|
|
|
|
+
|
|
class ['key,'value] pool = object(self)
|
|
class ['key,'value] pool = object(self)
|
|
val lut = Hashtbl.create 0
|
|
val lut = Hashtbl.create 0
|
|
val items = DynArray.create ()
|
|
val items = DynArray.create ()
|
|
@@ -118,7 +159,7 @@ class string_pool (kind : chunk_kind) = object(self)
|
|
method is_empty =
|
|
method is_empty =
|
|
pool#is_empty
|
|
pool#is_empty
|
|
|
|
|
|
- method export : 'a . 'a IO.output -> unit = fun chex ->
|
|
|
|
|
|
+ method !export : 'a . 'a IO.output -> unit = fun chex ->
|
|
self#write_uleb128 (DynArray.length pool#items);
|
|
self#write_uleb128 (DynArray.length pool#items);
|
|
DynArray.iter (fun s ->
|
|
DynArray.iter (fun s ->
|
|
let b = Bytes.unsafe_of_string s in
|
|
let b = Bytes.unsafe_of_string s in
|
|
@@ -206,528 +247,7 @@ class ['a] hxb_writer
|
|
method write_pos (p : pos) =
|
|
method write_pos (p : pos) =
|
|
chunk#write_string p.pfile;
|
|
chunk#write_string p.pfile;
|
|
chunk#write_leb128 p.pmin;
|
|
chunk#write_leb128 p.pmin;
|
|
- chunk#write_leb128 p.pmax;
|
|
|
|
-
|
|
|
|
- method write_metadata_entry ((meta,el,p) : metadata_entry) =
|
|
|
|
- chunk#write_string (Meta.to_string meta);
|
|
|
|
- (* TODO: el -_- *)
|
|
|
|
- self#write_pos p
|
|
|
|
-
|
|
|
|
- method write_metadata ml =
|
|
|
|
- chunk#write_list ml self#write_metadata_entry
|
|
|
|
-
|
|
|
|
- (* References *)
|
|
|
|
-
|
|
|
|
- method write_class_ref (c : tclass) =
|
|
|
|
- chunk#write_uleb128 (classes#get_or_add c.cl_path c)
|
|
|
|
-
|
|
|
|
- method write_enum_ref (en : tenum) =
|
|
|
|
- chunk#write_uleb128 (enums#get_or_add en.e_path en)
|
|
|
|
-
|
|
|
|
- method write_typedef_ref (td : tdef) =
|
|
|
|
- chunk#write_uleb128 (typedefs#get_or_add td.t_path td)
|
|
|
|
-
|
|
|
|
- method write_abstract_ref (a : tabstract) =
|
|
|
|
- chunk#write_uleb128 (abstracts#get_or_add a.a_path a)
|
|
|
|
-
|
|
|
|
- method write_field_ref (source : field_source) (cf : tclass_field) =
|
|
|
|
- chunk#write_string cf.cf_name
|
|
|
|
-
|
|
|
|
- (* Type instances *)
|
|
|
|
-
|
|
|
|
- method write_type_instance t =
|
|
|
|
- let write_function_arg (n,o,t) =
|
|
|
|
- chunk#write_string n;
|
|
|
|
- chunk#write_bool o;
|
|
|
|
- self#write_type_instance t;
|
|
|
|
- in
|
|
|
|
- match t with
|
|
|
|
- | TMono r ->
|
|
|
|
- begin match r.tm_type with
|
|
|
|
- | None ->
|
|
|
|
- chunk#write_byte 0
|
|
|
|
- | Some t ->
|
|
|
|
- chunk#write_byte 1;
|
|
|
|
- self#write_type_instance t
|
|
|
|
- end
|
|
|
|
- | TInst({cl_kind = KTypeParameter _} as c,[]) ->
|
|
|
|
- begin try
|
|
|
|
- let i = field_type_parameters#get (snd c.cl_path) in
|
|
|
|
- chunk#write_byte 5;
|
|
|
|
- chunk#write_uleb128 i
|
|
|
|
- with Not_found -> try
|
|
|
|
- let i = type_type_parameters#get (snd c.cl_path) in
|
|
|
|
- chunk#write_byte 6;
|
|
|
|
- chunk#write_uleb128 i
|
|
|
|
- with Not_found ->
|
|
|
|
- error ("Unbound type parameter " ^ (s_type_path c.cl_path))
|
|
|
|
- end
|
|
|
|
- | TInst(c,[]) ->
|
|
|
|
- chunk#write_byte 10;
|
|
|
|
- self#write_class_ref c;
|
|
|
|
- | TEnum(en,[]) ->
|
|
|
|
- chunk#write_byte 11;
|
|
|
|
- self#write_enum_ref en;
|
|
|
|
- | TType(td,[]) ->
|
|
|
|
- chunk#write_byte 12;
|
|
|
|
- self#write_typedef_ref td;
|
|
|
|
- | TAbstract(a,[]) ->
|
|
|
|
- chunk#write_byte 13;
|
|
|
|
- self#write_abstract_ref a;
|
|
|
|
- | TInst(c,tl) ->
|
|
|
|
- chunk#write_byte 14;
|
|
|
|
- self#write_class_ref c;
|
|
|
|
- self#write_types tl
|
|
|
|
- | TEnum(en,tl) ->
|
|
|
|
- chunk#write_byte 15;
|
|
|
|
- self#write_enum_ref en;
|
|
|
|
- self#write_types tl
|
|
|
|
- | TType(td,tl) ->
|
|
|
|
- chunk#write_byte 16;
|
|
|
|
- self#write_typedef_ref td;
|
|
|
|
- self#write_types tl
|
|
|
|
- | TAbstract(a,tl) ->
|
|
|
|
- chunk#write_byte 17;
|
|
|
|
- self#write_abstract_ref a;
|
|
|
|
- self#write_types tl
|
|
|
|
- (* | TFun([],t) when ExtType.is_void (follow t) ->
|
|
|
|
- chunk#write_byte 30;
|
|
|
|
- | TFun(args,t) when ExtType.is_void (follow t) ->
|
|
|
|
- chunk#write_byte 31;
|
|
|
|
- chunk#write_list args write_function_arg; *)
|
|
|
|
- | TFun(args,t) ->
|
|
|
|
- chunk#write_byte 32;
|
|
|
|
- chunk#write_list args write_function_arg;
|
|
|
|
- self#write_type_instance t;
|
|
|
|
- | TLazy r ->
|
|
|
|
- self#write_type_instance (lazy_type r);
|
|
|
|
- | TDynamic None ->
|
|
|
|
- chunk#write_byte 40
|
|
|
|
- | TDynamic (Some t) ->
|
|
|
|
- chunk#write_byte 41;
|
|
|
|
- self#write_type_instance t;
|
|
|
|
- | TAnon an when PMap.is_empty an.a_fields ->
|
|
|
|
- chunk#write_byte 50;
|
|
|
|
- | TAnon an ->
|
|
|
|
- let pfm = Option.get (anon_id#identify true t) in
|
|
|
|
- chunk#write_byte 51;
|
|
|
|
- chunk#write_uleb128 (anons#get_or_add pfm.pfm_path an)
|
|
|
|
- (* begin match !(an.a_status) with
|
|
|
|
- | Closed -> chunk#write_byte 50
|
|
|
|
- | Const -> chunk#write_byte 51
|
|
|
|
- | Extend _ -> chunk#write_byte 52
|
|
|
|
- | Statics _ -> chunk#write_byte 53
|
|
|
|
- | EnumStatics _ -> chunk#write_byte 54
|
|
|
|
- | AbstractStatics _ -> chunk#write_byte 55
|
|
|
|
- end; *)
|
|
|
|
- (* let l = pmap_to_list an.a_fields in
|
|
|
|
- (* chunk#write_list l (fun (_,cf) -> self#write_class_field cf); *)
|
|
|
|
- begin match !(an.a_status) with
|
|
|
|
- | Extend tl -> self#write_types tl
|
|
|
|
- | Statics c -> self#write_class_ref c
|
|
|
|
- | EnumStatics en -> self#write_enum_ref en
|
|
|
|
- | AbstractStatics a -> self#write_abstract_ref a
|
|
|
|
- | Closed
|
|
|
|
- | Const ->
|
|
|
|
- ()
|
|
|
|
- end; *)
|
|
|
|
-
|
|
|
|
- method write_types tl =
|
|
|
|
- chunk#write_list tl self#write_type_instance
|
|
|
|
-
|
|
|
|
- (* Fields *)
|
|
|
|
-
|
|
|
|
- method set_field_type_parameters (params : typed_type_param list) =
|
|
|
|
- field_type_parameters <- new pool;
|
|
|
|
- List.iter (fun ttp ->
|
|
|
|
- ignore(field_type_parameters#add ttp.ttp_name ttp);
|
|
|
|
- ) params
|
|
|
|
-
|
|
|
|
- method write_type_parameter_forward ttp = match follow ttp.ttp_type with
|
|
|
|
- | TInst({cl_kind = KTypeParameter _} as c,_) ->
|
|
|
|
- chunk#write_string ttp.ttp_name;
|
|
|
|
- self#write_pos c.cl_name_pos
|
|
|
|
- | _ ->
|
|
|
|
- die "" __LOC__
|
|
|
|
-
|
|
|
|
- method write_type_parameter_data ttp = match follow ttp.ttp_type with
|
|
|
|
- | TInst({cl_kind = KTypeParameter tl1},tl2) ->
|
|
|
|
- self#write_types tl1;
|
|
|
|
- self#write_types tl2;
|
|
|
|
- | _ ->
|
|
|
|
- die "" __LOC__
|
|
|
|
-
|
|
|
|
- method write_field_kind = function
|
|
|
|
- | Method MethNormal -> chunk#write_byte 0;
|
|
|
|
- | Method MethInline -> chunk#write_byte 1;
|
|
|
|
- | Method MethDynamic -> chunk#write_byte 2;
|
|
|
|
- | Method MethMacro -> chunk#write_byte 3;
|
|
|
|
- (* normal read *)
|
|
|
|
- | Var {v_read = AccNormal; v_write = AccNormal } -> chunk#write_byte 10
|
|
|
|
- | Var {v_read = AccNormal; v_write = AccNo } -> chunk#write_byte 11
|
|
|
|
- | Var {v_read = AccNormal; v_write = AccNever } -> chunk#write_byte 12
|
|
|
|
- | Var {v_read = AccNormal; v_write = AccCtor } -> chunk#write_byte 13
|
|
|
|
- | Var {v_read = AccNormal; v_write = AccCall } -> chunk#write_byte 14
|
|
|
|
- (* inline read *)
|
|
|
|
- | Var {v_read = AccInline; v_write = AccNever } -> chunk#write_byte 20
|
|
|
|
- (* getter read *)
|
|
|
|
- | Var {v_read = AccCall; v_write = AccNormal } -> chunk#write_byte 30
|
|
|
|
- | Var {v_read = AccCall; v_write = AccNo } -> chunk#write_byte 31
|
|
|
|
- | Var {v_read = AccCall; v_write = AccNever } -> chunk#write_byte 32
|
|
|
|
- | Var {v_read = AccCall; v_write = AccCtor } -> chunk#write_byte 33
|
|
|
|
- | Var {v_read = AccCall; v_write = AccCall } -> chunk#write_byte 34
|
|
|
|
- (* weird/overlooked combinations *)
|
|
|
|
- | Var {v_read = r;v_write = w } ->
|
|
|
|
- chunk#write_byte 100;
|
|
|
|
- let f = function
|
|
|
|
- | AccNormal -> chunk#write_byte 0
|
|
|
|
- | AccNo -> chunk#write_byte 1
|
|
|
|
- | AccNever -> chunk#write_byte 2
|
|
|
|
- | AccCtor -> chunk#write_byte 3
|
|
|
|
- | AccCall -> chunk#write_byte 4
|
|
|
|
- | AccInline -> chunk#write_byte 5
|
|
|
|
- | AccRequire(s,so) ->
|
|
|
|
- chunk#write_byte 6;
|
|
|
|
- chunk#write_string s;
|
|
|
|
- chunk#write_option so chunk#write_string
|
|
|
|
- in
|
|
|
|
- f r;
|
|
|
|
- f w;
|
|
|
|
-
|
|
|
|
- method write_class_field cf =
|
|
|
|
- self#set_field_type_parameters cf.cf_params;
|
|
|
|
- chunk#write_string cf.cf_name;
|
|
|
|
- chunk#write_list cf.cf_params self#write_type_parameter_forward;
|
|
|
|
- chunk#write_list cf.cf_params self#write_type_parameter_data;
|
|
|
|
- self#write_type_instance cf.cf_type;
|
|
|
|
- chunk#write_i32 cf.cf_flags;
|
|
|
|
- self#write_pos cf.cf_pos;
|
|
|
|
- self#write_pos cf.cf_name_pos;
|
|
|
|
- chunk#write_option cf.cf_doc self#write_documentation;
|
|
|
|
- self#write_metadata cf.cf_meta;
|
|
|
|
- self#write_field_kind cf.cf_kind;
|
|
|
|
- chunk#write_list cf.cf_overloads self#write_class_field;
|
|
|
|
-
|
|
|
|
- (* Module types *)
|
|
|
|
-
|
|
|
|
- method select_type (path : path) =
|
|
|
|
- type_type_parameters <- type_param_lut#extract path
|
|
|
|
-
|
|
|
|
- method write_common_module_type (infos : tinfos) : unit =
|
|
|
|
- chunk#write_bool infos.mt_private;
|
|
|
|
- chunk#write_option infos.mt_doc self#write_documentation;
|
|
|
|
- self#write_metadata infos.mt_meta;
|
|
|
|
- chunk#write_list infos.mt_params self#write_type_parameter_forward;
|
|
|
|
- chunk#write_list infos.mt_params self#write_type_parameter_data;
|
|
|
|
- chunk#write_list infos.mt_using (fun (c,p) ->
|
|
|
|
- self#write_class_ref c;
|
|
|
|
- self#write_pos p;
|
|
|
|
- );
|
|
|
|
-
|
|
|
|
- method write_class_kind = function
|
|
|
|
- | KNormal ->
|
|
|
|
- chunk#write_byte 0
|
|
|
|
- | KTypeParameter tl ->
|
|
|
|
- chunk#write_byte 1;
|
|
|
|
- self#write_types tl;
|
|
|
|
- | KExpr e ->
|
|
|
|
- chunk#write_byte 2;
|
|
|
|
- (* TODO *)
|
|
|
|
- | KGeneric ->
|
|
|
|
- chunk#write_byte 3;
|
|
|
|
- | KGenericInstance(c,tl) ->
|
|
|
|
- chunk#write_byte 4;
|
|
|
|
- self#write_class_ref c;
|
|
|
|
- self#write_types tl
|
|
|
|
- | KMacroType ->
|
|
|
|
- chunk#write_byte 5;
|
|
|
|
- | KGenericBuild l ->
|
|
|
|
- chunk#write_byte 6;
|
|
|
|
- (* TODO *)
|
|
|
|
- | KAbstractImpl a ->
|
|
|
|
- chunk#write_byte 7;
|
|
|
|
- self#write_abstract_ref a;
|
|
|
|
- | KModuleFields md ->
|
|
|
|
- chunk#write_byte 8;
|
|
|
|
- (* TODO *)
|
|
|
|
-
|
|
|
|
- method write_class (c : tclass) =
|
|
|
|
- begin match c.cl_kind with
|
|
|
|
- | KAbstractImpl a ->
|
|
|
|
- self#select_type a.a_path
|
|
|
|
- | _ ->
|
|
|
|
- self#select_type c.cl_path;
|
|
|
|
- end;
|
|
|
|
- self#write_common_module_type (Obj.magic c);
|
|
|
|
- self#write_class_kind c.cl_kind;
|
|
|
|
- chunk#write_u32 (Int32.of_int c.cl_flags);
|
|
|
|
- chunk#write_option c.cl_super (fun (c,tl) ->
|
|
|
|
- self#write_class_ref c;
|
|
|
|
- self#write_types tl
|
|
|
|
- );
|
|
|
|
- chunk#write_list c.cl_implements (fun (c,tl) ->
|
|
|
|
- self#write_class_ref c;
|
|
|
|
- self#write_types tl
|
|
|
|
- );
|
|
|
|
- chunk#write_option c.cl_dynamic self#write_type_instance;
|
|
|
|
- chunk#write_option c.cl_array_access self#write_type_instance;
|
|
|
|
-
|
|
|
|
- method write_abstract (a : tabstract) =
|
|
|
|
- begin try
|
|
|
|
- self#select_type a.a_path
|
|
|
|
- with Not_found ->
|
|
|
|
- print_endline ("Could not select abstract " ^ (s_type_path a.a_path));
|
|
|
|
- end;
|
|
|
|
- self#write_common_module_type (Obj.magic a);
|
|
|
|
- (* ops *)
|
|
|
|
- (* unops *)
|
|
|
|
- chunk#write_option a.a_impl self#write_class_ref;
|
|
|
|
- let c = match a.a_impl with
|
|
|
|
- | None ->
|
|
|
|
- null_class
|
|
|
|
- | Some c ->
|
|
|
|
- c
|
|
|
|
- in
|
|
|
|
- self#write_type_instance a.a_this;
|
|
|
|
- chunk#write_list a.a_from self#write_type_instance;
|
|
|
|
- chunk#write_list a.a_from_field (fun (t,cf) ->
|
|
|
|
- self#set_field_type_parameters cf.cf_params;
|
|
|
|
- self#write_type_instance t;
|
|
|
|
- self#write_field_ref (ClassStatic c) cf;
|
|
|
|
- );
|
|
|
|
- chunk#write_list a.a_to self#write_type_instance;
|
|
|
|
- chunk#write_list a.a_to_field (fun (t,cf) ->
|
|
|
|
- self#set_field_type_parameters cf.cf_params;
|
|
|
|
- self#write_type_instance t;
|
|
|
|
- self#write_field_ref (ClassStatic c) cf;
|
|
|
|
- );
|
|
|
|
- chunk#write_list a.a_array (self#write_field_ref (ClassStatic c));
|
|
|
|
- chunk#write_option a.a_read (self#write_field_ref (ClassStatic c));
|
|
|
|
- chunk#write_option a.a_write (self#write_field_ref (ClassStatic c));
|
|
|
|
- chunk#write_option a.a_call (self#write_field_ref (ClassStatic c));
|
|
|
|
- chunk#write_bool a.a_enum
|
|
|
|
-
|
|
|
|
- (* Module *)
|
|
|
|
-
|
|
|
|
- method forward_declare_type (mt : module_type) =
|
|
|
|
- let i = match mt with
|
|
|
|
- | TClassDecl c ->
|
|
|
|
- ignore(classes#add c.cl_path c);
|
|
|
|
- ignore(own_classes#add c.cl_path c);
|
|
|
|
- 0
|
|
|
|
- | TEnumDecl _ ->
|
|
|
|
- 1
|
|
|
|
- | TTypeDecl _ ->
|
|
|
|
- 2
|
|
|
|
- | TAbstractDecl a ->
|
|
|
|
- ignore(abstracts#add a.a_path a);
|
|
|
|
- ignore(own_abstracts#add a.a_path a);
|
|
|
|
- 3
|
|
|
|
- in
|
|
|
|
- let infos = t_infos mt in
|
|
|
|
- chunk#write_byte i;
|
|
|
|
- self#write_path infos.mt_path;
|
|
|
|
- self#write_pos infos.mt_pos;
|
|
|
|
- self#write_pos infos.mt_name_pos;
|
|
|
|
- let params = new pool in
|
|
|
|
- type_type_parameters <- params;
|
|
|
|
- ignore(type_param_lut#add infos.mt_path params);
|
|
|
|
- List.iter (fun ttp ->
|
|
|
|
- ignore(type_type_parameters#add ttp.ttp_name ttp);
|
|
|
|
- ) infos.mt_params;
|
|
|
|
-
|
|
|
|
- method write_module (m : module_def) =
|
|
|
|
- self#start_chunk HHDR;
|
|
|
|
- self#write_path m.m_path;
|
|
|
|
- chunk#write_string (Path.UniqueKey.lazy_path m.m_extra.m_file);
|
|
|
|
-
|
|
|
|
- self#start_chunk TYPF;
|
|
|
|
- chunk#write_list m.m_types self#forward_declare_type;
|
|
|
|
-
|
|
|
|
- begin match own_classes#to_list with
|
|
|
|
- | [] ->
|
|
|
|
- ()
|
|
|
|
- | own_classes ->
|
|
|
|
- self#start_chunk CLSD;
|
|
|
|
- chunk#write_list own_classes self#write_class;
|
|
|
|
- self#start_chunk CFLD;
|
|
|
|
- chunk#write_list own_classes (fun c ->
|
|
|
|
- begin match c.cl_kind with
|
|
|
|
- | KAbstractImpl a ->
|
|
|
|
- self#select_type a.a_path
|
|
|
|
- | _ ->
|
|
|
|
- self#select_type c.cl_path;
|
|
|
|
- end;
|
|
|
|
- chunk#write_option c.cl_constructor self#write_class_field;
|
|
|
|
- chunk#write_list c.cl_ordered_fields self#write_class_field;
|
|
|
|
- chunk#write_list c.cl_ordered_statics self#write_class_field;
|
|
|
|
- )
|
|
|
|
- end;
|
|
|
|
- begin match own_abstracts#to_list with
|
|
|
|
- | [] ->
|
|
|
|
- ()
|
|
|
|
- | own_abstracts ->
|
|
|
|
- self#start_chunk ABSD;
|
|
|
|
- chunk#write_list own_abstracts self#write_abstract;
|
|
|
|
- end;
|
|
|
|
- begin match classes#to_list with
|
|
|
|
- | [] ->
|
|
|
|
- ()
|
|
|
|
- | l ->
|
|
|
|
- self#start_chunk CLSR;
|
|
|
|
- chunk#write_list l (fun c ->
|
|
|
|
- let m = c.cl_module in
|
|
|
|
- self#write_full_path (fst m.m_path) (snd m.m_path) (snd c.cl_path)
|
|
|
|
- )
|
|
|
|
- end;
|
|
|
|
- begin match abstracts#to_list with
|
|
|
|
- | [] ->
|
|
|
|
- ()
|
|
|
|
- | l ->
|
|
|
|
- self#start_chunk ABSR;
|
|
|
|
- chunk#write_list l (fun a ->
|
|
|
|
- let m = a.a_module in
|
|
|
|
- self#write_full_path (fst m.m_path) (snd m.m_path) (snd a.a_path)
|
|
|
|
- )
|
|
|
|
- end;
|
|
|
|
- self#start_chunk HEND;
|
|
|
|
-
|
|
|
|
- (* Export *)
|
|
|
|
-
|
|
|
|
- method export : 'a . 'a IO.output -> unit = fun ch ->
|
|
|
|
- cp#export ch;
|
|
|
|
- if not docs#is_empty then
|
|
|
|
- docs#export ch;
|
|
|
|
- let l = DynArray.to_list chunks in
|
|
|
|
- let l = List.sort (fun chunk1 chunk2 ->
|
|
|
|
- (Obj.magic chunk1#kind) - (Obj.magic chunk2#kind)
|
|
|
|
- ) l in
|
|
|
|
- List.iter (fun (chunk : chunk) ->
|
|
|
|
- chunk#export ch
|
|
|
|
- ) l
|
|
|
|
-end
|
|
|
|
-
|
|
|
|
-(*
|
|
|
|
-class hxb_constant_pool_writer = object(self)
|
|
|
|
- val lut = Hashtbl.create 0
|
|
|
|
- val pool = DynArray.create ()
|
|
|
|
-
|
|
|
|
- method get_index (s : string) =
|
|
|
|
- try
|
|
|
|
- Hashtbl.find lut s
|
|
|
|
- with Not_found ->
|
|
|
|
- let index = DynArray.length pool in
|
|
|
|
- Hashtbl.add lut s index;
|
|
|
|
- DynArray.add pool s;
|
|
|
|
- index
|
|
|
|
-
|
|
|
|
- method export : 'a . 'a IO.output -> unit = fun ch ->
|
|
|
|
- IO.write_real_i32 ch (Int32.of_int (DynArray.length pool));
|
|
|
|
- DynArray.iter (fun s ->
|
|
|
|
- let b = Bytes.of_string s in
|
|
|
|
- IO.write_real_i32 ch (Int32.of_int (Bytes.length b));
|
|
|
|
- IO.nwrite ch b;
|
|
|
|
- ) pool;
|
|
|
|
-end
|
|
|
|
-
|
|
|
|
-let pmap_to_list map = PMap.foldi (fun k x l -> (k,x) :: l) map []
|
|
|
|
-let hashtbl_to_list h = Hashtbl.fold (fun k x l -> (k,x) :: l) h []
|
|
|
|
-
|
|
|
|
-let rec binop_index op = match op with
|
|
|
|
- | OpAdd -> 0
|
|
|
|
- | OpMult -> 1
|
|
|
|
- | OpDiv -> 2
|
|
|
|
- | OpSub -> 3
|
|
|
|
- | OpAssign -> 4
|
|
|
|
- | OpEq -> 5
|
|
|
|
- | OpNotEq -> 6
|
|
|
|
- | OpGt -> 7
|
|
|
|
- | OpGte -> 8
|
|
|
|
- | OpLt -> 9
|
|
|
|
- | OpLte -> 10
|
|
|
|
- | OpAnd -> 11
|
|
|
|
- | OpOr -> 12
|
|
|
|
- | OpXor -> 13
|
|
|
|
- | OpBoolAnd -> 14
|
|
|
|
- | OpBoolOr -> 15
|
|
|
|
- | OpShl -> 16
|
|
|
|
- | OpShr -> 17
|
|
|
|
- | OpUShr -> 18
|
|
|
|
- | OpMod -> 19
|
|
|
|
- | OpInterval -> 20
|
|
|
|
- | OpArrow -> 21
|
|
|
|
- | OpIn -> 22
|
|
|
|
- | OpAssignOp op -> 30 + binop_index op
|
|
|
|
-
|
|
|
|
-let unop_index op flag = match op,flag with
|
|
|
|
- | Increment,Prefix -> 0
|
|
|
|
- | Decrement,Prefix -> 1
|
|
|
|
- | Not,Prefix -> 2
|
|
|
|
- | Neg,Prefix -> 3
|
|
|
|
- | NegBits,Prefix -> 4
|
|
|
|
- | Increment,Postfix -> 5
|
|
|
|
- | Decrement,Postfix -> 6
|
|
|
|
- | Not,Postfix -> 7
|
|
|
|
- | Neg,Postfix -> 8
|
|
|
|
- | NegBits,Postfix -> 9
|
|
|
|
-
|
|
|
|
-class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = object(self)
|
|
|
|
-
|
|
|
|
- (* basic *)
|
|
|
|
-
|
|
|
|
- method write_byte b =
|
|
|
|
- IO.write_byte ch b;
|
|
|
|
-
|
|
|
|
- method write_bool b =
|
|
|
|
- chunk#write_byte (if b then 1 else 0)
|
|
|
|
-
|
|
|
|
- method write_ui16 i =
|
|
|
|
- IO.write_ui16 ch i;
|
|
|
|
-
|
|
|
|
- method write_i16 i =
|
|
|
|
- IO.write_i16 ch i;
|
|
|
|
-
|
|
|
|
- method write_i32 i =
|
|
|
|
- IO.write_real_i32 ch (Int32.of_int i);
|
|
|
|
-
|
|
|
|
- method write_float f =
|
|
|
|
- IO.write_double ch f
|
|
|
|
-
|
|
|
|
- method write_string s =
|
|
|
|
- self#write_i32 (cp#get_index s);
|
|
|
|
-
|
|
|
|
- method write_bytes b =
|
|
|
|
- self#write_i32 (Bytes.length b);
|
|
|
|
- IO.nwrite ch b;
|
|
|
|
-
|
|
|
|
- method write_list8 : 'b . 'b list -> ('b -> unit) -> unit = fun l f ->
|
|
|
|
- chunk#write_byte (List.length l);
|
|
|
|
- List.iter f l;
|
|
|
|
-
|
|
|
|
- method write_list16 : 'b . 'b list -> ('b -> unit) -> unit = fun l f ->
|
|
|
|
- self#write_ui16 (List.length l);
|
|
|
|
- List.iter f l;
|
|
|
|
-
|
|
|
|
- method write_option : 'b . 'b option -> ('b -> unit) -> unit = fun v f -> match v with
|
|
|
|
- | None -> chunk#write_byte 0
|
|
|
|
- | Some v ->
|
|
|
|
- chunk#write_byte 1;
|
|
|
|
- f v
|
|
|
|
-
|
|
|
|
- method write_path (path : path) =
|
|
|
|
- self#write_list8 (fst path) chunk#write_string;
|
|
|
|
- chunk#write_string (snd path);
|
|
|
|
-
|
|
|
|
- method write_documentation (doc : doc_block) =
|
|
|
|
- chunk#write_option doc.doc_own chunk#write_string;
|
|
|
|
- self#write_list8 doc.doc_inherited chunk#write_string
|
|
|
|
-
|
|
|
|
- (* basic compounds *)
|
|
|
|
-
|
|
|
|
- method write_pos p =
|
|
|
|
- chunk#write_string p.pfile;
|
|
|
|
- self#write_i32 p.pmin;
|
|
|
|
- self#write_i32 p.pmax;
|
|
|
|
|
|
+ chunk#write_leb128 p.pmax;
|
|
|
|
|
|
method write_metadata_entry ((meta,el,p) : metadata_entry) =
|
|
method write_metadata_entry ((meta,el,p) : metadata_entry) =
|
|
chunk#write_string (Meta.to_string meta);
|
|
chunk#write_string (Meta.to_string meta);
|
|
@@ -735,39 +255,41 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
self#write_pos p
|
|
self#write_pos p
|
|
|
|
|
|
method write_metadata ml =
|
|
method write_metadata ml =
|
|
- self#write_list16 ml self#write_metadata_entry
|
|
|
|
-
|
|
|
|
- method write_type_params params =
|
|
|
|
- self#write_list16 params (fun (s,t) ->
|
|
|
|
- chunk#write_string s;
|
|
|
|
- match follow t with
|
|
|
|
- | TInst({cl_kind = KTypeParameter tl},_) ->
|
|
|
|
- self#write_types tl;
|
|
|
|
- | _ ->
|
|
|
|
- assert false
|
|
|
|
- )
|
|
|
|
|
|
+ chunk#write_list ml self#write_metadata_entry
|
|
|
|
|
|
- (* refs *)
|
|
|
|
|
|
+ (* References *)
|
|
|
|
|
|
- method write_class_ref c =
|
|
|
|
- self#write_path c.cl_path
|
|
|
|
|
|
+ method write_class_ref (c : tclass) =
|
|
|
|
+ (* chunk#write_uleb128 (classes#get_or_add c.cl_path c) *)
|
|
|
|
+ let i = classes#get_or_add c.cl_path c in
|
|
|
|
+ Printf.eprintf " Write class ref %d for %s\n" i (snd c.cl_path);
|
|
|
|
+ chunk#write_uleb128 i
|
|
|
|
|
|
- method write_enum_ref en =
|
|
|
|
- self#write_path en.e_path
|
|
|
|
|
|
+ method write_enum_ref (en : tenum) =
|
|
|
|
+ (* chunk#write_uleb128 (enums#get_or_add en.e_path en) *)
|
|
|
|
+ let i = enums#get_or_add en.e_path en in
|
|
|
|
+ Printf.eprintf " Write enum ref %d for %s\n" i (snd en.e_path);
|
|
|
|
+ chunk#write_uleb128 i
|
|
|
|
|
|
- method write_typedef_ref td =
|
|
|
|
- self#write_path td.t_path
|
|
|
|
|
|
+ method write_typedef_ref (td : tdef) =
|
|
|
|
+ (* chunk#write_uleb128 (typedefs#get_or_add td.t_path td) *)
|
|
|
|
+ let i = typedefs#get_or_add td.t_path td in
|
|
|
|
+ Printf.eprintf " Write typedef ref %d for %s\n" i (snd td.t_path);
|
|
|
|
+ chunk#write_uleb128 i
|
|
|
|
|
|
- method write_abstract_ref a =
|
|
|
|
- self#write_path a.a_path
|
|
|
|
|
|
+ method write_abstract_ref (a : tabstract) =
|
|
|
|
+ (* chunk#write_uleb128 (abstracts#get_or_add a.a_path a) *)
|
|
|
|
+ let i = abstracts#get_or_add a.a_path a in
|
|
|
|
+ Printf.eprintf " Write abstract ref %d for %s\n" i (snd a.a_path);
|
|
|
|
+ chunk#write_uleb128 i
|
|
|
|
|
|
- method write_field_ref cf =
|
|
|
|
|
|
+ method write_field_ref (source : field_source) (cf : tclass_field) =
|
|
chunk#write_string cf.cf_name
|
|
chunk#write_string cf.cf_name
|
|
|
|
|
|
method write_enum_field_ref ef =
|
|
method write_enum_field_ref ef =
|
|
chunk#write_string ef.ef_name
|
|
chunk#write_string ef.ef_name
|
|
|
|
|
|
- (* type instance *)
|
|
|
|
|
|
+ (* Type instances *)
|
|
|
|
|
|
method write_type_instance t =
|
|
method write_type_instance t =
|
|
let write_function_arg (n,o,t) =
|
|
let write_function_arg (n,o,t) =
|
|
@@ -778,11 +300,24 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
match t with
|
|
match t with
|
|
| TMono r ->
|
|
| TMono r ->
|
|
begin match r.tm_type with
|
|
begin match r.tm_type with
|
|
- | None -> chunk#write_byte 0
|
|
|
|
|
|
+ | None ->
|
|
|
|
+ chunk#write_byte 0
|
|
| Some t ->
|
|
| Some t ->
|
|
chunk#write_byte 1;
|
|
chunk#write_byte 1;
|
|
self#write_type_instance t
|
|
self#write_type_instance t
|
|
end
|
|
end
|
|
|
|
+ | TInst({cl_kind = KTypeParameter _} as c,[]) ->
|
|
|
|
+ begin try
|
|
|
|
+ let i = field_type_parameters#get (snd c.cl_path) in
|
|
|
|
+ chunk#write_byte 5;
|
|
|
|
+ chunk#write_uleb128 i
|
|
|
|
+ with Not_found -> try
|
|
|
|
+ let i = type_type_parameters#get (snd c.cl_path) in
|
|
|
|
+ chunk#write_byte 6;
|
|
|
|
+ chunk#write_uleb128 i
|
|
|
|
+ with Not_found ->
|
|
|
|
+ error ("Unbound type parameter " ^ (s_type_path c.cl_path))
|
|
|
|
+ end
|
|
| TInst(c,[]) ->
|
|
| TInst(c,[]) ->
|
|
chunk#write_byte 10;
|
|
chunk#write_byte 10;
|
|
self#write_class_ref c;
|
|
self#write_class_ref c;
|
|
@@ -811,33 +346,38 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
chunk#write_byte 17;
|
|
chunk#write_byte 17;
|
|
self#write_abstract_ref a;
|
|
self#write_abstract_ref a;
|
|
self#write_types tl
|
|
self#write_types tl
|
|
- | TFun([],t) when ExtType.is_void (follow t) ->
|
|
|
|
|
|
+ (* | TFun([],t) when ExtType.is_void (follow t) ->
|
|
chunk#write_byte 30;
|
|
chunk#write_byte 30;
|
|
| TFun(args,t) when ExtType.is_void (follow t) ->
|
|
| TFun(args,t) when ExtType.is_void (follow t) ->
|
|
chunk#write_byte 31;
|
|
chunk#write_byte 31;
|
|
- self#write_list16 args write_function_arg;
|
|
|
|
|
|
+ chunk#write_list args write_function_arg; *)
|
|
| TFun(args,t) ->
|
|
| TFun(args,t) ->
|
|
chunk#write_byte 32;
|
|
chunk#write_byte 32;
|
|
- self#write_list16 args write_function_arg;
|
|
|
|
|
|
+ chunk#write_list args write_function_arg;
|
|
|
|
+ self#write_type_instance t;
|
|
| TLazy r ->
|
|
| TLazy r ->
|
|
self#write_type_instance (lazy_type r);
|
|
self#write_type_instance (lazy_type r);
|
|
- | TDynamic t ->
|
|
|
|
- if t == t_dynamic then chunk#write_byte 40
|
|
|
|
- else begin
|
|
|
|
- chunk#write_byte 41;
|
|
|
|
- self#write_type_instance t;
|
|
|
|
- end
|
|
|
|
|
|
+ | TDynamic None ->
|
|
|
|
+ chunk#write_byte 40
|
|
|
|
+ | TDynamic (Some t) ->
|
|
|
|
+ chunk#write_byte 41;
|
|
|
|
+ self#write_type_instance t;
|
|
|
|
+ | TAnon an when PMap.is_empty an.a_fields ->
|
|
|
|
+ chunk#write_byte 50;
|
|
| TAnon an ->
|
|
| TAnon an ->
|
|
- begin match !(an.a_status) with
|
|
|
|
|
|
+ let pfm = Option.get (anon_id#identify true t) in
|
|
|
|
+ chunk#write_byte 51;
|
|
|
|
+ chunk#write_uleb128 (anons#get_or_add pfm.pfm_path an)
|
|
|
|
+ (* begin match !(an.a_status) with
|
|
| Closed -> chunk#write_byte 50
|
|
| Closed -> chunk#write_byte 50
|
|
| Const -> chunk#write_byte 51
|
|
| Const -> chunk#write_byte 51
|
|
| Extend _ -> chunk#write_byte 52
|
|
| Extend _ -> chunk#write_byte 52
|
|
| Statics _ -> chunk#write_byte 53
|
|
| Statics _ -> chunk#write_byte 53
|
|
| EnumStatics _ -> chunk#write_byte 54
|
|
| EnumStatics _ -> chunk#write_byte 54
|
|
| AbstractStatics _ -> chunk#write_byte 55
|
|
| AbstractStatics _ -> chunk#write_byte 55
|
|
- end;
|
|
|
|
- let l = pmap_to_list an.a_fields in
|
|
|
|
- self#write_list16 l (fun (_,cf) -> self#write_class_field cf);
|
|
|
|
|
|
+ end; *)
|
|
|
|
+ (* let l = pmap_to_list an.a_fields in
|
|
|
|
+ (* chunk#write_list l (fun (_,cf) -> self#write_class_field cf); *)
|
|
begin match !(an.a_status) with
|
|
begin match !(an.a_status) with
|
|
| Extend tl -> self#write_types tl
|
|
| Extend tl -> self#write_types tl
|
|
| Statics c -> self#write_class_ref c
|
|
| Statics c -> self#write_class_ref c
|
|
@@ -846,10 +386,10 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
| Closed
|
|
| Closed
|
|
| Const ->
|
|
| Const ->
|
|
()
|
|
()
|
|
- end;
|
|
|
|
|
|
+ end; *)
|
|
|
|
|
|
method write_types tl =
|
|
method write_types tl =
|
|
- self#write_list16 tl self#write_type_instance
|
|
|
|
|
|
+ chunk#write_list tl self#write_type_instance
|
|
|
|
|
|
(* texpr *)
|
|
(* texpr *)
|
|
|
|
|
|
@@ -865,11 +405,12 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
| VInlined -> 7
|
|
| VInlined -> 7
|
|
| VInlinedConstructorVariable -> 8
|
|
| VInlinedConstructorVariable -> 8
|
|
| VExtractorVariable -> 9
|
|
| VExtractorVariable -> 9
|
|
|
|
+ | VAbstractThis -> 10
|
|
in
|
|
in
|
|
chunk#write_byte b
|
|
chunk#write_byte b
|
|
|
|
|
|
method write_var v =
|
|
method write_var v =
|
|
- self#write_i32 v.v_id;
|
|
|
|
|
|
+ chunk#write_i32 v.v_id;
|
|
chunk#write_string v.v_name;
|
|
chunk#write_string v.v_name;
|
|
self#write_type_instance v.v_type;
|
|
self#write_type_instance v.v_type;
|
|
self#write_var_kind v.v_kind;
|
|
self#write_var_kind v.v_kind;
|
|
@@ -883,14 +424,15 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
self#write_pos v.v_pos;
|
|
self#write_pos v.v_pos;
|
|
|
|
|
|
method write_texpr (e : texpr) =
|
|
method write_texpr (e : texpr) =
|
|
|
|
+ Printf.eprintf " Print texpr\n";
|
|
self#write_pos e.epos;
|
|
self#write_pos e.epos;
|
|
let curmin = ref e.epos.pmin in
|
|
let curmin = ref e.epos.pmin in
|
|
let curmax = ref e.epos.pmax in
|
|
let curmax = ref e.epos.pmax in
|
|
let check_diff p =
|
|
let check_diff p =
|
|
let dmin = p.pmin - !curmin in
|
|
let dmin = p.pmin - !curmin in
|
|
let dmax = p.pmax - !curmax in
|
|
let dmax = p.pmax - !curmax in
|
|
- self#write_i16 dmin;
|
|
|
|
- self#write_i16 dmax;
|
|
|
|
|
|
+ chunk#write_i16 dmin;
|
|
|
|
+ chunk#write_i16 dmax;
|
|
curmin := p.pmin;
|
|
curmin := p.pmin;
|
|
curmax := p.pmax;
|
|
curmax := p.pmax;
|
|
in
|
|
in
|
|
@@ -913,7 +455,7 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
chunk#write_byte 4;
|
|
chunk#write_byte 4;
|
|
| TInt i32 ->
|
|
| TInt i32 ->
|
|
chunk#write_byte 5;
|
|
chunk#write_byte 5;
|
|
- IO.write_real_i32 ch i32;
|
|
|
|
|
|
+ chunk#write_u32 i32;
|
|
| TFloat f ->
|
|
| TFloat f ->
|
|
chunk#write_byte 6;
|
|
chunk#write_byte 6;
|
|
chunk#write_string f;
|
|
chunk#write_string f;
|
|
@@ -924,7 +466,7 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
(* vars 20-29 *)
|
|
(* vars 20-29 *)
|
|
| TLocal v ->
|
|
| TLocal v ->
|
|
chunk#write_byte 20;
|
|
chunk#write_byte 20;
|
|
- self#write_i32 v.v_id;
|
|
|
|
|
|
+ chunk#write_i32 v.v_id;
|
|
| TVar(v,None) ->
|
|
| TVar(v,None) ->
|
|
chunk#write_byte 21;
|
|
chunk#write_byte 21;
|
|
self#write_var v;
|
|
self#write_var v;
|
|
@@ -949,17 +491,18 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
chunk#write_byte l;
|
|
chunk#write_byte l;
|
|
end else if l < 0xFFFF then begin
|
|
end else if l < 0xFFFF then begin
|
|
chunk#write_byte 37;
|
|
chunk#write_byte 37;
|
|
- self#write_ui16 l;
|
|
|
|
|
|
+ chunk#write_ui16 l;
|
|
end else begin
|
|
end else begin
|
|
chunk#write_byte 38;
|
|
chunk#write_byte 38;
|
|
- self#write_i32 l;
|
|
|
|
|
|
+ chunk#write_i32 l;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
List.iter loop el
|
|
List.iter loop el
|
|
(* function 50-59 *)
|
|
(* function 50-59 *)
|
|
| TFunction tf ->
|
|
| TFunction tf ->
|
|
chunk#write_byte 50;
|
|
chunk#write_byte 50;
|
|
- self#write_list16 tf.tf_args (fun (v,eo) ->
|
|
|
|
|
|
+ (* list16 *)
|
|
|
|
+ chunk#write_list tf.tf_args (fun (v,eo) ->
|
|
self#write_var v;
|
|
self#write_var v;
|
|
chunk#write_option eo loop
|
|
chunk#write_option eo loop
|
|
);
|
|
);
|
|
@@ -978,7 +521,8 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
loop_el el;
|
|
loop_el el;
|
|
| TObjectDecl fl ->
|
|
| TObjectDecl fl ->
|
|
chunk#write_byte 63;
|
|
chunk#write_byte 63;
|
|
- self#write_list16 fl (fun ((name,p,qs),e) ->
|
|
|
|
|
|
+ (* list16 *)
|
|
|
|
+ chunk#write_list fl (fun ((name,p,qs),e) ->
|
|
chunk#write_string name;
|
|
chunk#write_string name;
|
|
self#write_pos p;
|
|
self#write_pos p;
|
|
begin match qs with
|
|
begin match qs with
|
|
@@ -1005,18 +549,20 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
loop e1;
|
|
loop e1;
|
|
loop e2;
|
|
loop e2;
|
|
loop e3;
|
|
loop e3;
|
|
- | TSwitch(e1,cases,def) ->
|
|
|
|
|
|
+ | TSwitch s ->
|
|
chunk#write_byte 82;
|
|
chunk#write_byte 82;
|
|
- loop e1;
|
|
|
|
- self#write_list16 cases (fun (el,e) ->
|
|
|
|
- loop_el el;
|
|
|
|
- loop e;
|
|
|
|
|
|
+ loop s.switch_subject;
|
|
|
|
+ (* list16 *)
|
|
|
|
+ chunk#write_list s.switch_cases (fun c ->
|
|
|
|
+ loop_el c.case_patterns;
|
|
|
|
+ loop c.case_expr;
|
|
);
|
|
);
|
|
- chunk#write_option def loop;
|
|
|
|
|
|
+ chunk#write_option s.switch_default loop;
|
|
| TTry(e1,catches) ->
|
|
| TTry(e1,catches) ->
|
|
chunk#write_byte 83;
|
|
chunk#write_byte 83;
|
|
loop e1;
|
|
loop e1;
|
|
- self#write_list16 catches (fun (v,e) ->
|
|
|
|
|
|
+ (* list16 *)
|
|
|
|
+ chunk#write_list catches (fun (v,e) ->
|
|
self#write_var v;
|
|
self#write_var v;
|
|
loop e
|
|
loop e
|
|
);
|
|
);
|
|
@@ -1050,32 +596,34 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
chunk#write_byte 101;
|
|
chunk#write_byte 101;
|
|
loop e1;
|
|
loop e1;
|
|
self#write_enum_field_ref ef;
|
|
self#write_enum_field_ref ef;
|
|
- self#write_i32 i;
|
|
|
|
|
|
+ chunk#write_i32 i;
|
|
| TField(e1,FInstance(c,tl,cf)) ->
|
|
| TField(e1,FInstance(c,tl,cf)) ->
|
|
chunk#write_byte 102;
|
|
chunk#write_byte 102;
|
|
loop e1;
|
|
loop e1;
|
|
self#write_class_ref c;
|
|
self#write_class_ref c;
|
|
self#write_types tl;
|
|
self#write_types tl;
|
|
- self#write_field_ref cf;
|
|
|
|
|
|
+ self#write_field_ref (ClassMember c) cf; (* TODO check source *)
|
|
| TField(e1,FStatic(c,cf)) ->
|
|
| TField(e1,FStatic(c,cf)) ->
|
|
chunk#write_byte 103;
|
|
chunk#write_byte 103;
|
|
loop e1;
|
|
loop e1;
|
|
self#write_class_ref c;
|
|
self#write_class_ref c;
|
|
- self#write_field_ref cf;
|
|
|
|
|
|
+ self#write_field_ref (ClassMember c) cf; (* TODO check source *)
|
|
| TField(e1,FAnon cf) ->
|
|
| TField(e1,FAnon cf) ->
|
|
chunk#write_byte 104;
|
|
chunk#write_byte 104;
|
|
loop e1;
|
|
loop e1;
|
|
- self#write_field_ref cf;
|
|
|
|
|
|
+ (* TODO *)
|
|
|
|
+ (* self#write_field_ref (ClassMember c) cf; (1* TODO check source *1) *)
|
|
| TField(e1,FClosure(Some(c,tl),cf)) ->
|
|
| TField(e1,FClosure(Some(c,tl),cf)) ->
|
|
chunk#write_byte 105;
|
|
chunk#write_byte 105;
|
|
loop e1;
|
|
loop e1;
|
|
self#write_class_ref c;
|
|
self#write_class_ref c;
|
|
self#write_types tl;
|
|
self#write_types tl;
|
|
- self#write_field_ref cf;
|
|
|
|
|
|
+ self#write_field_ref (ClassMember c) cf; (* TODO check source *)
|
|
| TField(e1,FClosure(None,cf)) ->
|
|
| TField(e1,FClosure(None,cf)) ->
|
|
chunk#write_byte 106;
|
|
chunk#write_byte 106;
|
|
loop e1;
|
|
loop e1;
|
|
- self#write_field_ref cf;
|
|
|
|
|
|
+ (* TODO *)
|
|
|
|
+ (* self#write_field_ref (ClassMember c) cf; (1* TODO check source *1) *)
|
|
| TField(e1,FEnum(en,ef)) ->
|
|
| TField(e1,FEnum(en,ef)) ->
|
|
chunk#write_byte 107;
|
|
chunk#write_byte 107;
|
|
loop e1;
|
|
loop e1;
|
|
@@ -1124,12 +672,32 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
chunk#write_byte 250;
|
|
chunk#write_byte 250;
|
|
chunk#write_string s;
|
|
chunk#write_string s;
|
|
and loop_el el =
|
|
and loop_el el =
|
|
- self#write_ui16 (List.length el);
|
|
|
|
|
|
+ chunk#write_ui16 (List.length el);
|
|
List.iter loop el
|
|
List.iter loop el
|
|
in
|
|
in
|
|
loop e
|
|
loop e
|
|
|
|
|
|
- (* field *)
|
|
|
|
|
|
+ (* Fields *)
|
|
|
|
+
|
|
|
|
+ method set_field_type_parameters (params : typed_type_param list) =
|
|
|
|
+ field_type_parameters <- new pool;
|
|
|
|
+ List.iter (fun ttp ->
|
|
|
|
+ ignore(field_type_parameters#add ttp.ttp_name ttp);
|
|
|
|
+ ) params
|
|
|
|
+
|
|
|
|
+ method write_type_parameter_forward ttp = match follow ttp.ttp_type with
|
|
|
|
+ | TInst({cl_kind = KTypeParameter _} as c,_) ->
|
|
|
|
+ chunk#write_string ttp.ttp_name;
|
|
|
|
+ self#write_pos c.cl_name_pos
|
|
|
|
+ | _ ->
|
|
|
|
+ die "" __LOC__
|
|
|
|
+
|
|
|
|
+ method write_type_parameter_data ttp = match follow ttp.ttp_type with
|
|
|
|
+ | TInst({cl_kind = KTypeParameter tl1},tl2) ->
|
|
|
|
+ self#write_types tl1;
|
|
|
|
+ self#write_types tl2;
|
|
|
|
+ | _ ->
|
|
|
|
+ die "" __LOC__
|
|
|
|
|
|
method write_field_kind = function
|
|
method write_field_kind = function
|
|
| Method MethNormal -> chunk#write_byte 0;
|
|
| Method MethNormal -> chunk#write_byte 0;
|
|
@@ -1169,30 +737,38 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
f w;
|
|
f w;
|
|
|
|
|
|
method write_class_field cf =
|
|
method write_class_field cf =
|
|
- self#write_field_ref cf;
|
|
|
|
- self#write_i32 cf.cf_flags;
|
|
|
|
|
|
+ Printf.eprintf " Write class field %s\n" cf.cf_name;
|
|
|
|
+ self#set_field_type_parameters cf.cf_params;
|
|
|
|
+ chunk#write_string cf.cf_name;
|
|
|
|
+ (* chunk#write_list cf.cf_params self#write_type_parameter_forward; *)
|
|
|
|
+ (* chunk#write_list cf.cf_params self#write_type_parameter_data; *)
|
|
self#write_type_instance cf.cf_type;
|
|
self#write_type_instance cf.cf_type;
|
|
|
|
+ chunk#write_i32 cf.cf_flags;
|
|
self#write_pos cf.cf_pos;
|
|
self#write_pos cf.cf_pos;
|
|
self#write_pos cf.cf_name_pos;
|
|
self#write_pos cf.cf_name_pos;
|
|
chunk#write_option cf.cf_doc self#write_documentation;
|
|
chunk#write_option cf.cf_doc self#write_documentation;
|
|
self#write_metadata cf.cf_meta;
|
|
self#write_metadata cf.cf_meta;
|
|
- self#write_type_params cf.cf_params;
|
|
|
|
self#write_field_kind cf.cf_kind;
|
|
self#write_field_kind cf.cf_kind;
|
|
chunk#write_option cf.cf_expr self#write_texpr;
|
|
chunk#write_option cf.cf_expr self#write_texpr;
|
|
- (* TODO: expr_unoptimized *)
|
|
|
|
- self#write_list16 cf.cf_overloads self#write_class_field;
|
|
|
|
|
|
+ chunk#write_option cf.cf_expr_unoptimized self#write_texpr;
|
|
|
|
+ chunk#write_list cf.cf_overloads self#write_class_field;
|
|
|
|
+
|
|
|
|
+ (* Module types *)
|
|
|
|
|
|
- method write_enum_field ef =
|
|
|
|
- self#write_enum_field_ref ef;
|
|
|
|
- self#write_type_instance ef.ef_type;
|
|
|
|
- self#write_pos ef.ef_pos;
|
|
|
|
- self#write_pos ef.ef_name_pos;
|
|
|
|
- chunk#write_option ef.ef_doc self#write_documentation;
|
|
|
|
- self#write_i32 ef.ef_index;
|
|
|
|
- self#write_type_params ef.ef_params;
|
|
|
|
- self#write_metadata ef.ef_meta;
|
|
|
|
|
|
+ method select_type (path : path) =
|
|
|
|
+ type_type_parameters <- type_param_lut#extract path
|
|
|
|
|
|
- (* module *)
|
|
|
|
|
|
+ method write_common_module_type (infos : tinfos) : unit =
|
|
|
|
+ chunk#write_bool infos.mt_private;
|
|
|
|
+ (* TODO: fix that *)
|
|
|
|
+ (* chunk#write_option infos.mt_doc self#write_documentation; *)
|
|
|
|
+ self#write_metadata infos.mt_meta;
|
|
|
|
+ chunk#write_list infos.mt_params self#write_type_parameter_forward;
|
|
|
|
+ chunk#write_list infos.mt_params self#write_type_parameter_data;
|
|
|
|
+ chunk#write_list infos.mt_using (fun (c,p) ->
|
|
|
|
+ self#write_class_ref c;
|
|
|
|
+ self#write_pos p;
|
|
|
|
+ );
|
|
|
|
|
|
method write_class_kind = function
|
|
method write_class_kind = function
|
|
| KNormal ->
|
|
| KNormal ->
|
|
@@ -1221,115 +797,158 @@ class ['a] hxb_writer (ch : 'a IO.output) (cp : hxb_constant_pool_writer) = obje
|
|
chunk#write_byte 8;
|
|
chunk#write_byte 8;
|
|
(* TODO *)
|
|
(* TODO *)
|
|
|
|
|
|
- method write_module_type mt =
|
|
|
|
- let infos = t_infos mt in
|
|
|
|
- self#write_path infos.mt_path;
|
|
|
|
- self#write_pos infos.mt_pos;
|
|
|
|
- self#write_pos infos.mt_name_pos;
|
|
|
|
- chunk#write_bool infos.mt_private;
|
|
|
|
- chunk#write_option infos.mt_doc self#write_documentation;
|
|
|
|
- self#write_metadata infos.mt_meta;
|
|
|
|
- self#write_type_params infos.mt_params;
|
|
|
|
- self#write_list8 infos.mt_using (fun (c,p) ->
|
|
|
|
|
|
+ method write_class (c : tclass) =
|
|
|
|
+ begin match c.cl_kind with
|
|
|
|
+ | KAbstractImpl a ->
|
|
|
|
+ self#select_type a.a_path
|
|
|
|
+ | _ ->
|
|
|
|
+ self#select_type c.cl_path;
|
|
|
|
+ end;
|
|
|
|
+ self#write_common_module_type (Obj.magic c);
|
|
|
|
+ self#write_class_kind c.cl_kind;
|
|
|
|
+ chunk#write_u32 (Int32.of_int c.cl_flags);
|
|
|
|
+ chunk#write_option c.cl_super (fun (c,tl) ->
|
|
self#write_class_ref c;
|
|
self#write_class_ref c;
|
|
- self#write_pos p;
|
|
|
|
|
|
+ self#write_types tl
|
|
);
|
|
);
|
|
- match mt with
|
|
|
|
- | TClassDecl c ->
|
|
|
|
- chunk#write_byte 0;
|
|
|
|
- self#write_class_kind c.cl_kind;
|
|
|
|
- (* TODO *)
|
|
|
|
- (* chunk#write_bool c.cl_extern;
|
|
|
|
- chunk#write_bool c.cl_final;
|
|
|
|
- chunk#write_bool c.cl_interface; *)
|
|
|
|
- let write_relation (cr,tl) =
|
|
|
|
- self#write_class_ref cr;
|
|
|
|
- self#write_types tl;
|
|
|
|
- in
|
|
|
|
- chunk#write_option c.cl_super write_relation;
|
|
|
|
- self#write_list16 c.cl_implements write_relation;
|
|
|
|
- self#write_list16 c.cl_ordered_statics self#write_class_field;
|
|
|
|
- self#write_list16 c.cl_ordered_fields self#write_class_field;
|
|
|
|
- chunk#write_option c.cl_dynamic self#write_type_instance;
|
|
|
|
- chunk#write_option c.cl_array_access self#write_type_instance;
|
|
|
|
- chunk#write_option c.cl_constructor self#write_class_field;
|
|
|
|
- chunk#write_option c.cl_init self#write_texpr;
|
|
|
|
- | TEnumDecl en ->
|
|
|
|
- chunk#write_byte 1;
|
|
|
|
- self#write_module_type (TTypeDecl en.e_type);
|
|
|
|
- chunk#write_bool en.e_extern;
|
|
|
|
- self#write_list16 en.e_names (fun s ->
|
|
|
|
- let ef = PMap.find s en.e_constrs in
|
|
|
|
- self#write_enum_field ef;
|
|
|
|
- );
|
|
|
|
- | TTypeDecl td ->
|
|
|
|
- chunk#write_byte 2;
|
|
|
|
- self#write_type_instance td.t_type;
|
|
|
|
- | TAbstractDecl a ->
|
|
|
|
- chunk#write_byte 3;
|
|
|
|
- self#write_list16 a.a_ops (fun (op,cf) ->
|
|
|
|
- chunk#write_byte (binop_index op);
|
|
|
|
- self#write_field_ref cf
|
|
|
|
- );
|
|
|
|
- self#write_list16 a.a_unops (fun (op,flag,cf) ->
|
|
|
|
- chunk#write_byte (unop_index op flag);
|
|
|
|
- self#write_field_ref cf;
|
|
|
|
- );
|
|
|
|
- chunk#write_option a.a_impl self#write_class_ref;
|
|
|
|
- self#write_type_instance a.a_this;
|
|
|
|
- self#write_types a.a_from;
|
|
|
|
- self#write_list16 a.a_from_field (fun (t,cf) ->
|
|
|
|
- self#write_type_instance t;
|
|
|
|
- self#write_field_ref cf
|
|
|
|
- );
|
|
|
|
- self#write_types a.a_to;
|
|
|
|
- self#write_list16 a.a_to_field (fun (t,cf) ->
|
|
|
|
- self#write_type_instance t;
|
|
|
|
- self#write_field_ref cf
|
|
|
|
- );
|
|
|
|
- self#write_list16 a.a_array self#write_field_ref;
|
|
|
|
- chunk#write_option a.a_read self#write_field_ref;
|
|
|
|
- chunk#write_option a.a_write self#write_field_ref;
|
|
|
|
-
|
|
|
|
- method write_module m =
|
|
|
|
- self#write_i32 m.m_id;
|
|
|
|
- self#write_path m.m_path;
|
|
|
|
- self#write_list16 m.m_types self#write_module_type;
|
|
|
|
- let extra = m.m_extra in
|
|
|
|
- chunk#write_string (Path.UniqueKey.lazy_path extra.m_file);
|
|
|
|
- chunk#write_string (Digest.to_hex extra.m_sign);
|
|
|
|
- self#write_list16 extra.m_display.m_inline_calls (fun (p1,p2) ->
|
|
|
|
- self#write_pos p1;
|
|
|
|
- self#write_pos p2;
|
|
|
|
|
|
+ chunk#write_list c.cl_implements (fun (c,tl) ->
|
|
|
|
+ self#write_class_ref c;
|
|
|
|
+ self#write_types tl
|
|
);
|
|
);
|
|
- (* TODO *)
|
|
|
|
- (* self#write_list16 extra.m_display.m_type_hints (fun (p,t) ->
|
|
|
|
- self#write_pos p;
|
|
|
|
|
|
+ chunk#write_option c.cl_dynamic self#write_type_instance;
|
|
|
|
+ chunk#write_option c.cl_array_access self#write_type_instance;
|
|
|
|
+
|
|
|
|
+ method write_abstract (a : tabstract) =
|
|
|
|
+ begin try
|
|
|
|
+ self#select_type a.a_path
|
|
|
|
+ with Not_found ->
|
|
|
|
+ print_endline ("Could not select abstract " ^ (s_type_path a.a_path));
|
|
|
|
+ end;
|
|
|
|
+ self#write_common_module_type (Obj.magic a);
|
|
|
|
+ (* ops *)
|
|
|
|
+ (* unops *)
|
|
|
|
+ chunk#write_option a.a_impl self#write_class_ref;
|
|
|
|
+ let c = match a.a_impl with
|
|
|
|
+ | None ->
|
|
|
|
+ null_class
|
|
|
|
+ | Some c ->
|
|
|
|
+ c
|
|
|
|
+ in
|
|
|
|
+ self#write_type_instance a.a_this;
|
|
|
|
+ chunk#write_list a.a_from self#write_type_instance;
|
|
|
|
+ chunk#write_list a.a_from_field (fun (t,cf) ->
|
|
|
|
+ self#set_field_type_parameters cf.cf_params;
|
|
self#write_type_instance t;
|
|
self#write_type_instance t;
|
|
- ); *)
|
|
|
|
- self#write_list8 extra.m_check_policy (fun pol -> chunk#write_byte (Obj.magic pol)); (* TODO: don't be lazy *)
|
|
|
|
- self#write_float extra.m_time;
|
|
|
|
- (* chunk#write_option extra.m_dirty (fun m -> self#write_path m.m_path); *) (* TODO *)
|
|
|
|
- self#write_i32 extra.m_added;
|
|
|
|
- self#write_i32 extra.m_mark;
|
|
|
|
- self#write_list16 (pmap_to_list extra.m_deps) (fun (i,m) ->
|
|
|
|
- self#write_i32 i;
|
|
|
|
- self#write_path m.m_path;
|
|
|
|
- );
|
|
|
|
- self#write_i32 extra.m_processed;
|
|
|
|
- chunk#write_byte (Obj.magic extra.m_kind); (* TODO: don't be lazy *)
|
|
|
|
- self#write_list16 (pmap_to_list extra.m_binded_res) (fun (s1,s2) ->
|
|
|
|
- chunk#write_string s1;
|
|
|
|
- chunk#write_bytes (Bytes.unsafe_of_string s2);
|
|
|
|
- );
|
|
|
|
- self#write_list16 extra.m_if_feature (fun (s,(c,cf,b)) ->
|
|
|
|
- chunk#write_string s;
|
|
|
|
- self#write_class_ref c;
|
|
|
|
- self#write_field_ref cf;
|
|
|
|
- chunk#write_bool b;
|
|
|
|
|
|
+ self#write_field_ref (ClassStatic c) cf;
|
|
);
|
|
);
|
|
- self#write_list16 (hashtbl_to_list extra.m_features) (fun (s,b) ->
|
|
|
|
- chunk#write_string s;
|
|
|
|
- chunk#write_bool b;
|
|
|
|
|
|
+ chunk#write_list a.a_to self#write_type_instance;
|
|
|
|
+ chunk#write_list a.a_to_field (fun (t,cf) ->
|
|
|
|
+ self#set_field_type_parameters cf.cf_params;
|
|
|
|
+ self#write_type_instance t;
|
|
|
|
+ self#write_field_ref (ClassStatic c) cf;
|
|
);
|
|
);
|
|
-end *)
|
|
|
|
|
|
+ chunk#write_list a.a_array (self#write_field_ref (ClassStatic c));
|
|
|
|
+ chunk#write_option a.a_read (self#write_field_ref (ClassStatic c));
|
|
|
|
+ chunk#write_option a.a_write (self#write_field_ref (ClassStatic c));
|
|
|
|
+ chunk#write_option a.a_call (self#write_field_ref (ClassStatic c));
|
|
|
|
+ chunk#write_bool a.a_enum
|
|
|
|
+
|
|
|
|
+ (* Module *)
|
|
|
|
+
|
|
|
|
+ method forward_declare_type (mt : module_type) =
|
|
|
|
+ let i = match mt with
|
|
|
|
+ | TClassDecl c ->
|
|
|
|
+ ignore(classes#add c.cl_path c);
|
|
|
|
+ ignore(own_classes#add c.cl_path c);
|
|
|
|
+ 0
|
|
|
|
+ | TEnumDecl _ ->
|
|
|
|
+ 1
|
|
|
|
+ | TTypeDecl _ ->
|
|
|
|
+ 2
|
|
|
|
+ | TAbstractDecl a ->
|
|
|
|
+ ignore(abstracts#add a.a_path a);
|
|
|
|
+ ignore(own_abstracts#add a.a_path a);
|
|
|
|
+ 3
|
|
|
|
+ in
|
|
|
|
+ let infos = t_infos mt in
|
|
|
|
+ chunk#write_byte i;
|
|
|
|
+ self#write_path infos.mt_path;
|
|
|
|
+ self#write_pos infos.mt_pos;
|
|
|
|
+ self#write_pos infos.mt_name_pos;
|
|
|
|
+ let params = new pool in
|
|
|
|
+ type_type_parameters <- params;
|
|
|
|
+ ignore(type_param_lut#add infos.mt_path params);
|
|
|
|
+ List.iter (fun ttp ->
|
|
|
|
+ ignore(type_type_parameters#add ttp.ttp_name ttp);
|
|
|
|
+ ) infos.mt_params;
|
|
|
|
+
|
|
|
|
+ method write_module (m : module_def) =
|
|
|
|
+ self#start_chunk HHDR;
|
|
|
|
+ self#write_path m.m_path;
|
|
|
|
+ chunk#write_string (Path.UniqueKey.lazy_path m.m_extra.m_file);
|
|
|
|
+
|
|
|
|
+ self#start_chunk TYPF;
|
|
|
|
+ chunk#write_list m.m_types self#forward_declare_type;
|
|
|
|
+
|
|
|
|
+ begin match own_classes#to_list with
|
|
|
|
+ | [] ->
|
|
|
|
+ ()
|
|
|
|
+ | own_classes ->
|
|
|
|
+ self#start_chunk CLSD;
|
|
|
|
+ chunk#write_list own_classes self#write_class;
|
|
|
|
+ self#start_chunk CFLD;
|
|
|
|
+ chunk#write_list own_classes (fun c ->
|
|
|
|
+ begin match c.cl_kind with
|
|
|
|
+ | KAbstractImpl a ->
|
|
|
|
+ self#select_type a.a_path
|
|
|
|
+ | _ ->
|
|
|
|
+ self#select_type c.cl_path;
|
|
|
|
+ end;
|
|
|
|
+ chunk#write_option c.cl_constructor self#write_class_field;
|
|
|
|
+ chunk#write_list c.cl_ordered_fields self#write_class_field;
|
|
|
|
+ chunk#write_list c.cl_ordered_statics self#write_class_field;
|
|
|
|
+ )
|
|
|
|
+ end;
|
|
|
|
+ begin match own_abstracts#to_list with
|
|
|
|
+ | [] ->
|
|
|
|
+ ()
|
|
|
|
+ | own_abstracts ->
|
|
|
|
+ self#start_chunk ABSD;
|
|
|
|
+ chunk#write_list own_abstracts self#write_abstract;
|
|
|
|
+ end;
|
|
|
|
+ begin match classes#to_list with
|
|
|
|
+ | [] ->
|
|
|
|
+ ()
|
|
|
|
+ | l ->
|
|
|
|
+ self#start_chunk CLSR;
|
|
|
|
+ chunk#write_list l (fun c ->
|
|
|
|
+ let m = c.cl_module in
|
|
|
|
+ self#write_full_path (fst m.m_path) (snd m.m_path) (snd c.cl_path)
|
|
|
|
+ )
|
|
|
|
+ end;
|
|
|
|
+ begin match abstracts#to_list with
|
|
|
|
+ | [] ->
|
|
|
|
+ ()
|
|
|
|
+ | l ->
|
|
|
|
+ self#start_chunk ABSR;
|
|
|
|
+ chunk#write_list l (fun a ->
|
|
|
|
+ let m = a.a_module in
|
|
|
|
+ self#write_full_path (fst m.m_path) (snd m.m_path) (snd a.a_path)
|
|
|
|
+ )
|
|
|
|
+ end;
|
|
|
|
+ self#start_chunk HEND;
|
|
|
|
+
|
|
|
|
+ (* Export *)
|
|
|
|
+
|
|
|
|
+ method export : 'a . 'a IO.output -> unit = fun ch ->
|
|
|
|
+ cp#export ch;
|
|
|
|
+ if not docs#is_empty then
|
|
|
|
+ docs#export ch;
|
|
|
|
+ let l = DynArray.to_list chunks in
|
|
|
|
+ let l = List.sort (fun chunk1 chunk2 ->
|
|
|
|
+ (Obj.magic chunk1#kind) - (Obj.magic chunk2#kind)
|
|
|
|
+ ) l in
|
|
|
|
+ List.iter (fun (chunk : chunk) ->
|
|
|
|
+ chunk#export ch
|
|
|
|
+ ) l
|
|
|
|
+end
|