swflib/abcOut.ml

   1 open Base
   2
   3 module type Inst = sig
   4   type t
   5   val to_bytes : t -> BytesOut.t list
   6 end
   7
   8 module Make(Inst : Inst) = struct
   9   open BytesOut
  10   open AbcType
  11
  12   let dummy _ = [u30 0]
  13
  14   let array ~f xs =
  15     let ys =
  16       HList.concat_map f xs in
  17       (u30 (List.length xs))::ys
  18
  19   (* Constant Pool *)
  20   let empty_cpool =
  21     { int=[]; uint=[]; double=[]; string=[]; namespace=[]; namespace_set=[]; multiname=[]}
  22
  23   let cpool_map f xs =
  24     let ys =
  25       HList.concat_map f xs in
  26     let size =
  27       1+ List.length xs in
  28       (u30 size)::ys
  29
  30   let of_string str =
  31     array ~f:(fun c -> [u8 (Char.code c)]) @@ ExtString.String.explode str
  32
  33   let of_ns =
  34     function
  35         Namespace name ->
  36           [u8 0x08; u30 name]
  37       | PackageNamespace name ->
  38           [u8 0x16; u30 name]
  39       | PackageInternalNamespace name ->
  40           [u8 0x17; u30 name];
  41       | ProtectedNamespace name ->
  42           [u8 0x18; u30 name]
  43       | ExplicitNamespace name ->
  44           [u8 0x19; u30 name]
  45       | StaticProtectedNamespace name ->
  46           [u8 0x1A; u30 name]
  47       | PrivateNamespace name ->
  48           [u8 0x05; u30 name]
  49
  50   let of_ns_set =
  51     array ~f:(fun ns->[u30 ns])
  52
  53   let of_multiname =
  54     function
  55         QName (ns,name) ->
  56           [u8 0x07;u30 ns; u30 name]
  57       | QNameA (ns,name) ->
  58           [u8 0x0D;u30 ns; u30 name]
  59       | RTQName name ->
  60           [u8 0x0F; u30 name]
  61       | RTQNameA name ->
  62           [u8 0x10; u30 name]
  63       | RTQNameL ->
  64           [u8 0x11]
  65       | RTQNameLA ->
  66           [u8 0x12]
  67       | Multiname (name,ns_set) ->
  68           [u8 0x09; u30 name; u30 ns_set]
  69       | MultinameA (name,ns_set) ->
  70           [u8 0x0E; u30 name; u30 ns_set]
  71       | MultinameL name ->
  72           [u8 0x1B; u30 name]
  73       | MultinameLA name  ->
  74           [u8 0x1C; u30 name]
  75
  76
  77   let of_cpool cpool =
  78     List.concat [
  79       cpool_map (fun x->[s32 x]) cpool.int;
  80       cpool_map (fun x->[u32 x]) cpool.uint;
  81       cpool_map (fun x->[d64 x]) cpool.double;
  82       cpool_map of_string    cpool.string;
  83       cpool_map of_ns        cpool.namespace;
  84       cpool_map of_ns_set    cpool.namespace_set;
  85       cpool_map of_multiname cpool.multiname;
  86     ]
  87
  88   (* Trait *)
  89   let flags pats xs =
  90     let to_bit x =
  91       List.assoc x pats in
  92       List.fold_left (lor) 0 @@ List.map to_bit xs
  93
  94   let of_trait_attrs =
  95     flags [ATTR_Final   ,0x01;
  96            ATTR_Override,0x02]
  97
  98   (* kind field contains two four-bit fields. The lower four bits determine the kind of this trait.
  99      The upper four bits comprise a bit vector providing attributes of the trait. *)
 100   let kind attr kind =
 101     u8 @@ ((of_trait_attrs attr) lsl 4) lor kind
 102
 103   let of_trait_body =
 104     function
 105         SlotTrait (slot_id,type_name,vindex,vkind) ->
 106           if vindex = 0 then
 107             [u8 0;u30 slot_id; u30 type_name;u30 0]
 108           else
 109             [u8 0;u30 slot_id; u30 type_name;u30 vindex;u8 vkind]
 110       | MethodTrait (disp_id,meth,attrs) ->
 111           [kind attrs 1;u30 disp_id; u30 meth]
 112       | GetterTrait (disp_id,meth,attrs) ->
 113           [kind attrs 2;u30 disp_id; u30 meth]
 114       | SetterTrait (disp_id,meth,attrs) ->
 115           [kind attrs 3;u30 disp_id; u30 meth]
 116       | ClassTrait  (slot_id,classi) ->
 117           [u8 4; u30 slot_id; u30 classi]
 118       | FunctionTrait (slot_id,func) ->
 119           [u8 5;u30 slot_id; u30 func]
 120       | ConstTrait (slot_id,type_name,vindex,vkind) ->
 121           if vindex = 0 then
 122             [u8 6;u30 slot_id; u30 type_name;u30 0]
 123           else
 124             [u8 6;u30 slot_id; u30 type_name;u30 vindex;u8 vkind]
 125
 126   let of_trait {trait_name=name; data=data} =
 127     List.concat [[u30 name];
 128                  of_trait_body data]
 129
 130   (* method *)
 131   let of_option_info xs =
 132     let detail value kind =
 133       [u30 value; u8 kind] in
 134     array xs ~f:begin function
 135         IntVal n ->
 136           detail n 0x03
 137       | UIntVal n ->
 138           detail n 0x04
 139       | DoubleVal n ->
 140           detail n 0x06
 141       | StringVal n ->
 142           detail n 0x01
 143       | BoolVal true ->
 144           detail 0 0x0B
 145       | BoolVal false ->
 146           detail 0 0x0A
 147       | NullVal ->
 148           detail 0 0x0C
 149       | UndefinedVal ->
 150           detail 0 0x00
 151       | NamespaceVal n ->
 152           detail n 0x08
 153       | PackageNamespaceVal n ->
 154           detail n 0x016
 155       | PackageInternalNamespaceVal n ->
 156           detail n 0x17
 157       | ProtectedNamespaceVal n ->
 158           detail n 0x18
 159       | ExplicitNamespaceVal n ->
 160           detail n 0x19
 161       | StaticProtectedNamespaceVal n ->
 162           detail n 0x1A
 163       | PrivateNamespaceVal n ->
 164           detail n 0x15
 165     end
 166
 167   let of_method_flags xs =
 168     let (flags, option, names) =
 169       StdLabels.List.fold_left xs ~init:(0,[],[]) ~f:begin fun (flags,option,names) x ->
 170       match x with
 171           NeedArguments ->
 172             (0x01 lor flags, option, names)
 173         | NeedActivation ->
 174             (0x02 lor flags, option, names)
 175         | NeedRest ->
 176             (0x04 lor flags, option, names)
 177         | SetDxns ->
 178             (0x40 lor flags, option, names)
 179         | HasOptional xs ->
 180             (0x08 lor flags, of_option_info xs, names)
 181         | HasParamNames xs ->
 182             (0x80 lor flags, option, List.map u30 xs)
 183       end in
 184       List.concat [ [u8 flags];
 185                     option;
 186                     names]
 187
 188   let of_method_info info =
 189     List.concat [[u30 (List.length info.params);
 190                   u30 info.return];
 191                  List.map u30 info.params;
 192                  [u30 info.method_name];
 193                  of_method_flags info.method_flags]
 194
 195   let of_script {init=init; script_traits=traits} =
 196     (u30 init)::array ~f:of_trait traits
 197
 198   let of_method_body body =
 199     let t =
 200       Label.make () in
 201       List.concat [
 202         [ u30 body.method_sig;
 203           u30 body.max_stack;
 204           u30 body.local_count;
 205           u30 body.init_scope_depth;
 206           u30 body.max_scope_depth];
 207         [backpatch 0 (fun addr map -> to_int_list [u30 (find map t - addr)])];
 208         HList.concat_map Inst.to_bytes body.code;
 209         [label t];
 210         dummy body.exceptions;
 211         array ~f:of_trait body.method_traits]
 212
 213   let of_class  {cinit=init; class_traits=traits} =
 214     List.concat [
 215       [u30 init];
 216       array ~f:of_trait traits]
 217
 218   let of_instance {instance_name = name;
 219                    super_name = sname;
 220                    instance_flags = flags;
 221                    interfaces = inf;
 222                    iinit = init;
 223                    instance_traits = traits} =
 224     let flag =
 225       function
 226           Sealed        -> 0x01
 227         | Final         -> 0x02
 228         | Interface     -> 0x04
 229         | ProtectedNs _ -> 0x08 in
 230     let flags' =
 231       List.fold_left (fun x y -> x lor (flag y)) 0 flags in
 232     let ns =
 233       flags
 234       +> HList.concat_map begin function
 235           ProtectedNs ns -> [u30 ns]
 236         | Sealed | Final | Interface -> []
 237       end
 238       +> function [] -> [] | x::_ -> [x] in
 239       List.concat [
 240         [u30 name;
 241          u30 sname;
 242          u8  flags'];
 243         ns;
 244         array ~f:(fun x -> [u30 x]) inf;
 245         [u30 init];
 246         array ~f:of_trait traits]
 247
 248   let to_bytes { cpool;
 249                  method_info=info;
 250                  metadata;
 251                  classes;
 252                  instances;
 253                  scripts;
 254                  method_bodies=bodies; } =
 255     List.concat [
 256       [ u16 16; u16 46; ];
 257       of_cpool cpool;
 258       array ~f:of_method_info info;
 259       dummy metadata;
 260       array ~f:of_instance instances;
 261       HList.concat_map of_class classes;
 262       array ~f:of_script scripts;
 263       array ~f:of_method_body bodies
 264     ]
 265 end